monthcal.pas

Delphi控件源码

function TCommonCalendar.DoStoreMinDate: Boolean;
begin
  Result := FMinDate <> 0.0;
end;

function TCommonCalendar.GetDate: TDate;
begin
  Result := TDate(FDateTime);
end;

procedure TCommonCalendar.SetCalColors(Value: TDateTimeColors);
begin
  if FCalColors <> Value then FCalColors.Assign(Value);
end;

procedure TCommonCalendar.SetDate(Value: TDate);
var
  TruncValue: TDate;
begin
  TruncValue := Trunc(Value);
  Value := TruncValue + Frac(FDateTime);
  if Value = 0.0 then CheckEmptyDate;
  try
    CheckValidDate(TruncValue);
    SetDateTime(Value);
  except
    SetDateTime(FDateTime);
    raise;
  end;
end;

procedure TCommonCalendar.SetDateTime(Value: TDateTime);
var
  ST: TSystemTime;
begin
  DateTimeToSystemTime(Value, ST);
  if FMultiSelect then
    SetSelectedRange(Value, FEndDate)
  else begin
    if HandleAllocated then
      if not MsgSetDateTime(ST) then
        raise ECommonCalendarError.Create(sFailSetCalDateTime);
    FDateTime := Value;
  end;
end;

procedure TCommonCalendar.SetEndDate(Value: TDate);
var
  TruncValue: TDate;
begin
  TruncValue := Trunc(Value);
  if Trunc(FEndDate) <> TruncValue then
  begin
    Value := TruncValue + 0.0;
    if Value = 0.0 then CheckEmptyDate;
    CheckValidDate(TruncValue);
    SetSelectedRange(Date, TruncValue);
  end;
end;

procedure TCommonCalendar.SetFirstDayOfWeek(Value: TCalDayOfWeek);
var
  DOWFlag: Integer;
  A: array[0..1] of char;
begin
  if HandleAllocated then
  begin
    if Value = dowLocaleDefault then
    begin
      GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IFIRSTDAYOFWEEK, A, SizeOf(A));
      DOWFlag := Ord(A[0]) - Ord('0');
    end
    else
      DOWFlag := Ord(Value);
    if CalendarHandle <> 0 then
      MonthCal_SetFirstDayOfWeek(CalendarHandle, DOWFlag);
  end;
  FFirstDayOfWeek := Value;
end;

procedure TCommonCalendar.SetMaxDate(Value: TDate);
begin
  if (FMinDate <> 0.0) and (Value < FMinDate) then
    raise CalExceptionClass.CreateFmt(sDateTimeMin, [DateToStr(FMinDate)]);
  if FMaxDate <> Value then
  begin
    SetRange(FMinDate, Value);
    FMaxDate := Value;
  end;
end;

procedure TCommonCalendar.SetMaxSelectRange(Value: Integer);
begin
  if FMultiSelect and HandleAllocated then
    if not MonthCal_SetMaxSelCount(CalendarHandle, Value) then
      raise ECommonCalendarError.Create(sFailSetCalMaxSelRange);
  FMaxSelectRange := Value;
end;

procedure TCommonCalendar.SetMinDate(Value: TDate);
begin
  if (FMaxDate <> 0.0) and (Value > FMaxDate) then
    raise CalExceptionClass.CreateFmt(SDateTimeMax, [DateToStr(FMaxDate)]);
  if FMinDate <> Value then
  begin
    SetRange(Value, FMaxDate);
    FMinDate := Value;
  end;
end;

procedure TCommonCalendar.SetMonthDelta(Value: Integer);
begin
  if HandleAllocated and (CalendarHandle <> 0) then
    MonthCal_SetMonthDelta(CalendarHandle, Value);
  FMonthDelta := Value;
end;

procedure TCommonCalendar.SetMultiSelect(Value: Boolean);
begin
  if FMultiSelect <> Value then
  begin
    FMultiSelect := Value;
    if Value then FEndDate := FDateTime
    else FEndDate := 0.0;
    RecreateWnd;
  end;
end;

procedure TCommonCalendar.SetRange(MinVal, MaxVal: TDate);
var
  STA: packed array[1..2] of TSystemTime;
  Flags: DWORD;
  TruncDate, TruncEnd, TruncMin, TruncMax: DWORD{Int64};
begin
  Flags := 0;
  TruncMin := Trunc(MinVal);
  TruncMax := Trunc(MaxVal);
  TruncDate := Trunc(FDateTime);
  TruncEnd := Trunc(FEndDate);
  if TruncMin <> 0 then
  begin
    if TruncDate < TruncMin then SetDate(MinVal);
    if TruncEnd < TruncMin then SetEndDate(MinVal);
    Flags := Flags or GDTR_MIN;
    DateTimeToSystemTime(TruncMin, STA[1]);
  end;
  if TruncMax <> 0 then
  begin
    if TruncDate > TruncMax then SetDate(MaxVal);
    if TruncEnd > TruncMax then SetEndDate(MaxVal);
    Flags := Flags or GDTR_MAX;
    DateTimeToSystemTime(TruncMax, STA[2]);
  end;
  if HandleAllocated then
    if not MsgSetRange(Flags, @STA[1]) then
      raise ECommonCalendarError.Create(sFailSetCalMinMaxRange);
end;

procedure TCommonCalendar.SetSelectedRange(Date, EndDate: TDate);
var
  DateArray: array[1..2] of TSystemTime;
begin
  if not FMultiSelect then
    SetDateTime(Date)
  else begin
    DateTimeToSystemTime(Date, DateArray[1]);
    DateTimeToSystemTime(EndDate, DateArray[2]);
    if HandleAllocated then
      if not MonthCal_SetSelRange(Handle, @DateArray[1]) then
        raise ECommonCalendarError.Create(sFailsetCalSelRange);
    FDateTime := Date;
    FEndDate := EndDate;
  end;
end;

procedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean);
var
  Style: Integer;
begin
  if Ctl.HandleAllocated then
  begin
    Style := GetWindowLong(Ctl.Handle, GWL_STYLE);
    if not UseStyle then Style := Style and not Value
    else Style := Style or Value;
    SetWindowLong(Ctl.Handle, GWL_STYLE, Style);
  end;
end;

procedure TCommonCalendar.SetShowToday(Value: Boolean);
begin
  if FShowToday <> Value then
  begin
    FShowToday := Value;
    SetComCtlStyle(Self, MCS_NOTODAY, not Value);
  end;
end;

procedure TCommonCalendar.SetShowTodayCircle(Value: Boolean);
begin
  if FShowTodayCircle <> Value then
  begin
    FShowTodayCircle := Value;
    SetComCtlStyle(Self, MCS_NOTODAYCIRCLE, not Value);
  end;
end;

procedure TCommonCalendar.SetWeekNumbers(Value: Boolean);
begin
  if FWeekNumbers <> Value then
  begin
    FWeekNumbers := Value;
    SetComCtlStyle(Self, MCS_WEEKNUMBERS, Value);
  end;
end;

function IsBlankSysTime(const ST: TSystemTime): Boolean;
begin
  with ST do
    Result := (wYear = 0) and (wMonth = 0) and (wDayOfWeek = 0) and
      (wDay = 0) and (wHour = 0) and (wMinute = 0) and (wSecond = 0) and
      (wMilliseconds = 0);
end;

{ TMonthCalendar }

constructor TMonthCalendar.Create(AOwner: TComponent);
begin
  FCalExceptionClass := EMonthCalError;
  inherited Create(AOwner);
  Width := 176;
  Height := 153;
end;

procedure TMonthCalendar.CMFontChanged(var Message: TMessage);
begin
  inherited;
  if HandleAllocated then Perform(WM_SIZE, 0, 0);
end;

procedure TMonthCalendar.CNNotify(var Message: TWMNotify);
var
  ST: PSystemTime;
  I, MonthNo: Integer;
  CurState: PMonthDayState;
begin
  with Message, NMHdr^ do
  begin
    case code of
      MCN_GETDAYSTATE:
        with PNmDayState(NMHdr)^ do
        begin
          FillChar(prgDayState^, cDayState * SizeOf(TMonthDayState), 0);
          if Assigned(FOnGetMonthInfo) then
          begin
            CurState := prgDayState;
            for I := 0 to cDayState - 1 do
            begin
              MonthNo := stStart.wMonth + I;
              if MonthNo > 12 then MonthNo := MonthNo - 12;
              FOnGetMonthInfo(Self, MonthNo, CurState^);
              Inc(CurState);
            end;
          end;
        end;
      MCN_SELECT, MCN_SELCHANGE:
        begin
          ST := @PNMSelChange(NMHdr).stSelStart;
          if not IsBlankSysTime(ST^) then
            FDateTime := SystemTimeToDateTime(ST^);
          if FMultiSelect then
          begin
            ST := @PNMSelChange(NMHdr).stSelEnd;
            if not IsBlankSysTime(ST^) then
              FEndDate := SystemTimeToDateTime(ST^);
          end;
        end;
    end;
  end;
  inherited;
end;

procedure TMonthCalendar.ConstrainedResize(var MinWidth, MinHeight, MaxWidth,
  MaxHeight: Integer);
var
  R: TRect;
  CtlMinWidth, CtlMinHeight: Integer;
begin
  if HandleAllocated then
  begin
    MonthCal_GetMinReqRect(Handle, R);
    with R do
    begin
      CtlMinHeight := Bottom - Top;
      CtlMinWidth := Right - Left;
    end;
    if MinHeight < CtlMinHeight then MinHeight := CtlMinHeight;
    if MinWidth < CtlMinWidth then MinWidth := CtlMinWidth;
  end;
  //inherited ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight);
end;

procedure TMonthCalendar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, MONTHCAL_CLASS);
  with Params do
  begin
    Style := Style or GetCalStyles;
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
      CS_DBLCLKS;
  end;
end;

function TMonthCalendar.GetCalendarHandle: HWND;
begin
  Result := Handle;
end;

function TMonthCalendar.MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean;
begin
  Result := True;
  if HandleAllocated then
    Result := MonthCal_SetColor(Handle, ColorIndex, ColorValue) <> True{DWORD($FFFFFFFF)};
end;

function TMonthCalendar.MsgSetDateTime(Value: TSystemTime): Boolean;
begin
  Result := True;
  if HandleAllocated then
    Result := MonthCal_SetCurSel(Handle, Value);
end;

function TMonthCalendar.MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean;
begin
  Result := True;
  if HandleAllocated then
    if Flags <> 0 then Result := MonthCal_SetRange(Handle, Flags, SysTime);
end;

function TMonthCalendar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
var
  R: TRect;
begin
  if HandleAllocated then
  begin
    Result := True;
    Perform(MCM_GETMINREQRECT, 0, Longint(@R));
    with R do
    begin
      NewWidth := Right - Left;
      NewHeight := Bottom - Top;
    end;
  end
  else Result := False;
end;


end.