smonthcalendar.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

procedure TsMonthCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

procedure TsMonthCalendar.NextMonth;
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
  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);
begin
  inherited;
  if Message.MSG = SM_ALPHACMD then case Message.WParamHi of
    AC_REMOVESKIN, AC_REFRESH : if (LongWord(Message.LParam) = LongWord(SkinData.SkinManager)) then begin
      UpdateCalendar; // Shagrat
      FGrid.Repaint;
      if ShowTitle then SendMessage(FDragBar.Handle, Message.Msg, Message.WParam, Message.LParam);
    end;
  end;
end;

procedure TsMonthCalendar.SetShowTitle(const Value: boolean);
begin
  if FShowTitle <> Value then begin
    FShowTitle := Value;
    FDragBar.Visible := Value;
    if Value then FDragBar.Parent := Self else FDragBar.Parent := nil;
  end;
end;

procedure TsMonthCalendar.Loaded;
begin
  inherited;
//  FDragBar.Visible := FShowTitle;
  if Assigned(FDragBar) and FDragBar.Visible then begin
    FDragBar.SkinData.FSkinManager := SkinData.FSkinManager;
    FBtns[0].SkinData.FSkinManager := SkinData.FSkinManager;
    FBtns[1].SkinData.FSkinManager := SkinData.FSkinManager;
    FBtns[2].SkinData.FSkinManager := SkinData.FSkinManager;
    FBtns[3].SkinData.FSkinManager := SkinData.FSkinManager;
  end;
end;

procedure TsMonthCalendar.SetShowCurrentDate(const Value: boolean);
begin
  if FShowCurrentDate <> Value then begin
    FShowCurrentDate := Value;
    Invalidate;
  end;
end;

{ TsCalendGrid }

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

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

procedure TsCalendGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
  R : TRect;
  SelColor: TColor;
  d : TDateTime;
  c : 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);
  Canvas.Brush.Color := Color;
  if FOwner.ShowCurrentDate and (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),
                       FOwner.SkinData.FCacheBmp.Canvas.Handle,
                       Left + R.Left, Top + R.Top, SRCCOPY);
  Canvas.Brush.Style := bsClear;
  if FOwner.ShowCurrentDate and IsToday and (ACol <> 7) then begin
    R := ARect;
    InflateRect(R, -1, -1);
    inc(R.Left);
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Color := SelColor;
    Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 2, 2);
    Canvas.Font.Color := SelColor;
  end
  else if FOwner.IsWeekend(ACol, ARow) then begin
    Canvas.Font.Color := FOwner.WeekendColor;
  end else begin
    if Assigned(FOwner.SkinData.SkinManager) and (FOwner.SkinData.SkinManager.GetGlobalFontColor <> clFuchsia)
      then Canvas.Font.Color := FOwner.SkinData.SkinManager.GetGlobalFontColor
      else Canvas.Font.Color := clWindowText;
  end;
  if (gdSelected in AState) and not FOwner.SkinData.Skinned then begin
    Canvas.Brush.Color := Color;
  end;
  if Assigned(FOwner.FOnGetCellParams) then begin
    if (ARow > 0) and (TheText <> '') then begin
      d := EncodeDate(FOwner.Year, FOwner.Month, StrToInt(Thetext));
      c := clFuchsia;
      FOwner.FOnGetCellParams(Self, d, Canvas.Font, c);
      if c <> clFuchsia then begin
        Canvas.Brush.Color := c;
        Canvas.Brush.Style := bsSolid
      end;
    end;
  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 FOwner.SkinData.Skinned and (gdSelected in AState) and (Canvas.Brush.Style <> bsSolid) and Focused then begin // standard
    InflateRect(ARect, -1, -1);
    FocusRect(Canvas, ARect);
  end;
end;

procedure TsCalendGrid.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_UP, VK_DOWN : Shift := Shift - [ssCtrl]; // v4.63 
    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;
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.WMSize(var Message: TWMSize);
begin
  DefaultColWidth  := Message.Width  div 7;
  DefaultRowHeight := Message.Height div 7;
end;

procedure TsCalendGrid.WndProc(var Message: TMessage);
var
  SaveIndex: Integer;
  DC: HDC;
  PS: TPaintStruct;
begin
  case Message.Msg of
    WM_ERASEBKGND, CM_MOUSEENTER, CM_MOUSELEAVE, WM_MOUSEMOVE :
    else inherited;
  end;
  case Message.Msg of
    WM_LBUTTONDBLCLK : if Assigned(FOwner.OnDblClick) then FOwner.OnDblClick(FOwner);
    WM_PAINT : begin
      inherited;
      // Filling of right line
      BeginPaint(Handle, PS);
      if TWMPAINT(Message).DC = 0 then DC := GetDC(Handle) else DC := TWMPAINT(Message).DC;
      SaveIndex := SaveDC(DC);
      try
        BitBlt(DC, ColCount * DefaultColWidth, 0, Width - ColCount * DefaultColWidth, Height, FOwner.SkinData.FCacheBmp.Canvas.Handle, Left, Top, SRCCOPY);
      finally
        RestoreDC(DC, SaveIndex);
        if TWMPAINT(Message).DC = 0 then ReleaseDC(Handle, DC);
        EndPaint(Handle, PS);
      end;
    end;
    WM_LBUTTONUP : DblClick;
  end;
{$IFDEF LOGGED}
  AddToLog(Message);
{$ENDIF}
end;

end.