smonthcalendar.pas

AlphaControls是一个Delphi标准控件的集合

begin
  ChangeMonth(1);
end;

procedure TsMonthCalendar.NextYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year + 1;
end;

procedure TsMonthCalendar.PrevYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year - 1;
end;

procedure TsMonthCalendar.CalendarUpdate(DayOnly: Boolean);
var
  AYear, AMonth, ADay: Word;
  FirstDate: TDateTime;
begin
  FUpdating := True;
  try
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - (FirstDay + 1) + 7) mod 7);
    if FMonthOffset = 2 then FMonthOffset := -5;
    FGrid.MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1, False, False);
    if not DayOnly then begin
      FDragBar.Caption := LongMonthNames[AMonth] + ' ' + IntToStr(AYear);
      FGrid.Invalidate;
    end;
  finally
    FUpdating := False;
  end;
end;

procedure TsMonthCalendar.UpdateCalendar;
begin
  CalendarUpdate(False);
end;

function TsMonthCalendar.FirstDay: integer;
var
  A: array[0..1] of char;
begin
  if FStartOfWeek = dowLocaleDefault then begin
    GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IFIRSTDAYOFWEEK, A, SizeOf(A));
    Result := Ord(A[0]) - Ord('0');
  end
  else Result := Ord(FStartOfWeek);
end;

destructor TsMonthCalendar.Destroy;
begin
  inherited;
end;

procedure TsMonthCalendar.Invalidate;
begin
  if (csDesigning in ComponentState) and Assigned(FsStyle) then begin
    if not RestrictDrawing then FsStyle.BGChanged := True;
  end;
  inherited;
end;

procedure TsMonthCalendar.PrevYearBtnClick(Sender: TObject);
begin
  PrevYear;
end;

procedure TsMonthCalendar.NextYearBtnClick(Sender: TObject);
begin
  NextYear;
end;

procedure TsMonthCalendar.PrevMonthBtnClick(Sender: TObject);
begin
  PrevMonth;
end;

procedure TsMonthCalendar.NextMonthBtnClick(Sender: TObject);
begin
  NextMonth;
end;


procedure TsMonthCalendar.TopPanelDblClick(Sender: TObject);
begin
  CalendarDate := Date;//Trunc(Now);
end;

procedure TsMonthCalendar.WndProc(var Message: TMessage);
var
  i : integer;
begin
  case Message.MSG of
    SM_CLEARINDEXES, SM_REMOVESKIN, SM_SETNEWSKIN, SM_REFRESH : begin
      for i := 0 to ComponentCount - 1 do begin
        if Components[i] is TControl then begin
          TControl(Components[i]).Perform(Message.Msg, 0, 0);
        end;
      end;
    end;
  end;
  inherited;
end;

{ TsCalendGrid }

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

constructor TsCalendGrid.Create(AOwner: TComponent);
begin
  inherited;
  FOwner := TsMonthCalendar(AOwner);
  Ctl3D := False;
  BorderStyle := bsNone;
  FixedCols := 0;
  FixedRows := 1;
  ColCount := 8;
  RowCount := 8;
  ScrollBars := ssNone;
  ControlStyle := ControlStyle + [csOpaque];
  Options := [];
  Align := alClient;
end;

procedure TsCalendGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
  R : TRect;
  SelColor: TColor;
  function IsToday: boolean; begin
    Result := (ARow <> 0)
       and (TheText <> '')
       and (EncodeDate(FOwner.Year, FOwner.Month, StrToInt(TheText)) = Date)
  end;
begin
  TheText := FOwner.CellText[ACol, ARow];
  SelColor := ChangeColor(FOwner.WeekendColor, clBlack, 0.5);
  if gdSelected in AState then begin
    Canvas.Font.Style := [fsBold];
    Canvas.Font.Color := clBlack;
  end
  else begin
    Canvas.Font.Style := [];
  end;
  R := ARect;
  if ACol = 6 then R.Right := Width;
  if ARow = 6 then R.Bottom := Height;
  BitBlt(Canvas.Handle, R.Left,
                       R.Top,
                       WidthOf(R),
                       HeightOf(R),
                       TsCustomPanel(Parent).sStyle.FCacheBmp.Canvas.Handle,
                       Left + R.Left, Top + R.Top,
                       SRCCOPY);

  Canvas.Brush.Style := bsClear;
  if IsToday then begin
    R := ARect;
    InflateRect(R, -1, -1);
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Color := SelColor;
    Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 1, 1);
    Canvas.Font.Color := SelColor;
  end
  else if FOwner.IsWeekend(ACol, ARow) then begin
    Canvas.Font.Color := FOwner.WeekendColor;
  end;
  Canvas.TextRect(ARect,
                  ARect.Left + (ARect.Right - ARect.Left - Canvas.TextWidth(TheText)) div 2,
                  ARect.Top + (ARect.Bottom - ARect.Top - Canvas.TextHeight(TheText)) div 2,
                  TheText);

  if gdSelected in AState then begin
    sGraphUtils.BeveledBorder(Canvas.Handle,
                              ColorToRGB(clWhite),
                              ColorToRGB(clBlack),
                              SelColor, ARect, 1, sConst.bsLowered, True);
  end;

end;

procedure TsCalendGrid.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_LEFT, VK_SUBTRACT: if Shift = [] then begin
      if (FOwner.Day > 1)
        then FOwner.Day := FOwner.Day - 1
        else FOwner.CalendarDate := FOwner.CalendarDate - 1;
      Exit;
    end;
    VK_RIGHT, VK_ADD: if Shift = [] then begin
      if (FOwner.Day < FOwner.DaysThisMonth)
        then FOwner.Day := FOwner.Day + 1
        else FOwner.CalendarDate := FOwner.CalendarDate + 1;
      Exit;
    end;
    VK_NEXT: begin
      if ssCtrl in Shift
        then FOwner.NextYear
        else FOwner.NextMonth;
      Exit;
    end;
    VK_PRIOR: begin
      if ssCtrl in Shift
        then FOwner.PrevYear
        else FOwner.PrevMonth;
      Exit;
    end;
  end;
  inherited KeyDown(Key, Shift);
end;

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

procedure TsCalendGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Integer);
var
  Coord: TGridCoord;
begin
  Coord := MouseCoord(X, Y);
  ACol := Coord.X;
  ARow := Coord.Y;
end;

procedure TsCalendGrid.Paint;
begin
  if (csDestroying in ComponentState) or (csLoading in ComponentState) then Exit;
  inherited;
  sGraphUtils.FadeRect(TsCustomPanel(Parent).sStyle.FCacheBmp.Canvas,
                       Rect(Left + DefaultColWidth * 7,
                            Top - 2,
                            Left + WIdth,
                            Top + Height + 2),
                       Canvas.Handle,
                       Point(DefaultColWidth * 7, -2),
                       100,
                       ColorToRGB(TsCustomPanel(Parent).sStyle.Painting.Color),
                       0, ssRectangle);

  sGraphUtils.FadeRect(TsCustomPanel(Parent).sStyle.FCacheBmp.Canvas,
                       Rect(Left,
                            Top + DefaultRowHeight * 7,
                            Left + WIdth,
                            Top + Height),
                       Canvas.Handle,
                       Point(DefaultColWidth * 7, 0),
                       100,
                       ColorToRGB(TsCustomPanel(Parent).sStyle.Painting.Color),
                       0, ssRectangle);

end;

function TsCalendGrid.SelectCell(ACol, ARow: Integer): Boolean;
begin
  if ((not FOwner.FUpdating) and FOwner.FReadOnly) or (FOwner.CellText[ACol, ARow] = '')
    then Result := False
    else Result := inherited SelectCell(ACol, ARow);
end;

procedure TsCalendGrid.WMEraseBkgnd(var Message: TWMSize);
begin
  Message.Result := 1;
end;

procedure TsCalendGrid.WMSize(var Message: TWMSize);
//var
//  w : integer;
//  GridLinesH, GridLinesW: Integer;
begin
{
  GridLinesH := 6 * GridLineWidth * integer((goHorzLine in Options) or (goFixedHorzLine in Options));
  GridLinesW := 6 * GridLineWidth * integer((goVertLine in Options) or (goFixedVertLine in Options));
  DefaultColWidth := (Message.Width - GridLinesW) div 7;
  DefaultRowHeight := (Message.Height - GridLinesH) div 6;
}
//  Message.Width := (Message.Width div 7) +
  DefaultColWidth  := Message.Width  div 7;
  DefaultRowHeight := Message.Height div 7;
end;

procedure TsCalendGrid.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    CM_MOUSEENTER, CM_MOUSELEAVE, WM_MOUSEMOVE : begin
       Message.Result := 1;
    end
    else inherited;
  end;             
end;

end.