jclschedule.pas

East make Tray Icon in delphi

    Result := Result - (7 * (Index div 5)) - (Index mod 5);
  end;
  if (Result < 0) or (Result > DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1))) then
    Result := 0;
end;

function FirstWeekendDay(const Year, Month: Integer): Integer;
var
  Dummy: Integer;
begin
  Result := FirstWeekendDayPrim(Year, Month, Dummy);
end;

function LastWeekendDay(const Year, Month: Integer): Integer;
var
  Dummy: Integer;
begin
  Result := LastWeekendDayPrim(Year, Month, Dummy);
end;

function IndexedWeekendDay(const Year, Month: Integer; Index: Integer): Integer;
var
  DOW: Integer;
begin
  if Index > 0 then
    Result := FirstWeekendDayPrim(Year, Month, DOW)
  else
  if Index < 0 then
    Result := LastWeekendDayPrim(Year, Month, DOW)
  else
    Result := 0;
  if Index > 1 then                         // n-th weekend day from the start of the month
  begin
    if (DOW > 6) and not Odd(Index) then   // Adjust to first saturday
    begin
      Inc(Result, 6);
      Dec(Index);
    end;
    if Index > 1 then
    begin
      Dec(Index);
      Result := Result + (7 * (Index div 2)) + (Index mod 2);
    end;
  end
  else
  if Index < -1 then                   // n-th weekend day from the start of the month
  begin
    Index := Abs(Index);
    if (DOW < 7) and not Odd(Index) then    // Adjust to last sunday
    begin
      Dec(Result, 6);
      Dec(Index);
    end;
    if Index > 1 then
    begin
      Dec(Index);
      Result := Result - (7 * (Index div 2)) - (Index mod 2);
    end;
  end;
  if (Result < 0) or (Result > DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1))) then
    Result := 0;
end;

function FirstDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;
var
  DOW: Integer;
begin
  DOW := ISODayOfWeek(JclDateTime.EncodeDate(Year, Month, 1));
  if DOW > DayOfWeek then
    Result := 8 + DayOfWeek - DOW
  else
  if DOW < DayOfWeek then
    Result := 1 + DayOfWeek - DOW
  else
    Result := 1;
end;

function LastDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;
var
  DOW: Integer;
begin
  DOW := ISODayOfWeek(JclDateTime.EncodeDate(Year, Month, DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1))));
  if DOW > DayOfWeek then
    Result := DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1)) - (DOW - DayOfWeek)
  else
  if DOW < DayOfWeek then
    Result := DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1)) - (7 + DayOfWeek - DOW)
  else
    Result := DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1));
end;

function IndexedDayOfWeek(const Year, Month, DayOfWeek, Index: Integer): Integer;
begin
  if Index > 0 then
    Result := FirstDayOfWeek(Year, Month, DayOfWeek) + 7 * (Index - 1)
  else
  if Index < 0 then
    Result := LastDayOfWeek(Year, Month, DayOfWeek) - 7 * (Abs(Index) - 1)
  else
    Result := 0;
  if (Result < 0) or (Result > DaysInMonth(JclDateTime.EncodeDate(Year, Month, 1))) then
    Result := 0;
end;

//=== { TScheduleAggregate } =================================================

type
  TScheduleAggregate = class(TAggregatedObject)
  protected
    procedure CheckInterfaceAllowed;
    function InterfaceAllowed: Boolean;
    function Schedule: IJclSchedule;
    class function RecurringType: TScheduleRecurringKind; virtual;

    function ValidStamp(const Stamp: TTimeStamp): Boolean; virtual; abstract;
    procedure MakeValidStamp(var Stamp: TTimeStamp); virtual; abstract;
    function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; virtual; abstract;
  end;

procedure TScheduleAggregate.CheckInterfaceAllowed;
begin
  if not InterfaceAllowed then
    RunError(23); // reIntfCastError
end;

function TScheduleAggregate.InterfaceAllowed: Boolean;
begin
  Result := Schedule.RecurringType = RecurringType;
end;

function TScheduleAggregate.Schedule: IJclSchedule;
begin
  Result := Controller as IJclSchedule;
end;

class function TScheduleAggregate.RecurringType: TScheduleRecurringKind;
begin
  Result := srkOneShot;
end;

//=== { TDailyFreq } =========================================================

type
  TDailyFreq = class(TAggregatedObject)
  private
    FStartTime: Cardinal;
    FEndTime: Cardinal;
    FInterval: Cardinal;
  protected
    function ValidStamp(const Stamp: TTimeStamp): Boolean;
    function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;
  public
    constructor Create(const Controller: IUnknown);
    // IJclScheduleDayFrequency
    function GetStartTime: Cardinal;
    function GetEndTime: Cardinal;
    function GetInterval: Cardinal;
    procedure SetStartTime(Value: Cardinal);
    procedure SetEndTime(Value: Cardinal);
    procedure SetInterval(Value: Cardinal);

    property StartTime: Cardinal read GetStartTime write SetStartTime;
    property EndTime: Cardinal read GetEndTime write SetEndTime;
    property Interval: Cardinal read GetInterval write SetInterval;
  end;

constructor TDailyFreq.Create(const Controller: IUnknown);
begin
  inherited Create(Controller);
  FStartTime := 0;
  FEndTime := HoursToMSecs(24) - 1;
  FInterval := 500;
end;

function TDailyFreq.ValidStamp(const Stamp: TTimeStamp): Boolean;
begin
  Result := (Cardinal(Stamp.Time) >= FStartTime) and (Cardinal(Stamp.Time) <= FEndTime) and
    ((Cardinal(Stamp.Time) - FStartTime) mod FInterval = 0);
end;

function TDailyFreq.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;
begin
  Result := Stamp;
  if Stamp.Time < Integer(FStartTime) then
    Result.Time := FStartTime
  else
  if ((Cardinal(Stamp.Time) - FStartTime) mod FInterval) <> 0 then
    Result.Time := Stamp.Time + Integer(FInterval-(Cardinal(Stamp.Time) - FStartTime) mod FInterval)
  else
    Result.Time := Stamp.Time + Integer(FInterval);
  if (Result.Time < 0) or (Cardinal(Result.Time) > FEndTime) then
    Result := NullStamp;
end;

function TDailyFreq.GetStartTime: Cardinal;
begin
  Result := FStartTime;
end;

function TDailyFreq.GetEndTime: Cardinal;
begin
  Result := FEndTime;
end;

function TDailyFreq.GetInterval: Cardinal;
begin
  Result := FInterval;
end;

procedure TDailyFreq.SetStartTime(Value: Cardinal);
begin
  if Value <> FStartTime then
  begin
    if Value >= Cardinal(HoursToMSecs(24)) then
      raise ESchedule.CreateRes(@RsScheduleInvalidTime);
    FStartTime := Value;
    if EndTime < StartTime then
      FEndTime := Value;
  end;
end;

procedure TDailyFreq.SetEndTime(Value: Cardinal);
begin
  if Value <> FEndTime then
  begin
    if Value < FStartTime then
      raise ESchedule.CreateRes(@RsScheduleEndBeforeStart);
    if Value >= Cardinal(HoursToMSecs(24)) then
      raise ESchedule.CreateRes(@RsScheduleInvalidTime);
    FEndTime := Value;
  end;
end;

procedure TDailyFreq.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    if Value >= Cardinal(HoursToMSecs(24)) then
      raise ESchedule.CreateRes(@RsScheduleInvalidTime);
    if Value = 0 then
    begin
      FEndTime := FStartTime;
      FInterval := 1;
    end
    else
      FInterval := Value;
  end;
end;

//=== { TDailySchedule } =====================================================

type
  TDailySchedule = class(TScheduleAggregate)
  private
    FEveryWeekDay: Boolean;
    FInterval: Cardinal;
  protected
    class function RecurringType: TScheduleRecurringKind; override;

    function ValidStamp(const Stamp: TTimeStamp): Boolean; override;
    procedure MakeValidStamp(var Stamp: TTimeStamp); override;
    function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;
  public
    constructor Create(const Controller: IUnknown);
    // IJclDailySchedule
    function GetEveryWeekDay: Boolean;
    function GetInterval: Cardinal;
    procedure SetEveryWeekDay(Value: Boolean);
    procedure SetInterval(Value: Cardinal);

    property EveryWeekDay: Boolean read GetEveryWeekDay write SetEveryWeekDay;
    property Interval: Cardinal read GetInterval write SetInterval;
  end;

constructor TDailySchedule.Create(const Controller: IUnknown);
begin
  inherited Create(Controller);
  FEveryWeekDay := True;
  FInterval := 1;
end;

class function TDailySchedule.RecurringType: TScheduleRecurringKind;
begin
  Result := srkDaily;
end;

function TDailySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;
begin
  Result := (FEveryWeekDay and (TimeStampDOW(Stamp) < 6)) or
    (not FEveryWeekDay and (Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval = 0));
end;

procedure TDailySchedule.MakeValidStamp(var Stamp: TTimeStamp);
begin
  if FEveryWeekDay and (TimeStampDOW(Stamp) >= 6) then
    Inc(Stamp.Date, 2 - (TimeStampDOW(Stamp) - 6))
  else
  if not FEveryWeekDay and (Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval <> 0) then
    Inc(Stamp.Date, Interval - Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval);
end;

function TDailySchedule.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;
begin
  Result := Stamp;
  MakeValidStamp(Result);
  if EqualTimeStamps(Stamp, Result) then
  begin
    // Time stamp has not been adjusted (it was valid). Determine the next time stamp
    if FEveryWeekDay then
    begin
      Inc(Result.Date);
      MakeValidStamp(Result);     // Skip over the weekend.
    end
    else
      Inc(Result.Date, Interval); // always valid as we started with a valid stamp
  end;
end;

function TDailySchedule.GetEveryWeekDay: Boolean;
begin
  CheckInterfaceAllowed;
  Result := FEveryWeekDay;
end;

function TDailySchedule.GetInterval: Cardinal;
begin
  CheckInterfaceAllowed;
  if EveryWeekDay then
    Result := 0
  else
    Result := FInterval;
end;

procedure TDailySchedule.SetEveryWeekDay(Value: Boolean);
begin
  CheckInterfaceAllowed;
  FEveryWeekDay := Value;
end;

procedure TDailySchedule.SetInterval(Value: Cardinal);
begin
  CheckInterfaceAllowed;
  if Value = 0 then
    raise ESchedule.CreateRes(@RsScheduleIntervalZero);
  if FEveryWeekDay then
    FEveryWeekDay := False;
  if Value <> FInterval then
    FInterval := Value;
end;

//=== { TWeeklySchedule } ====================================================

type
  TWeeklySchedule = class(TScheduleAggregate)
  private
    FDaysOfWeek: TScheduleWeekDays;
    FInterval: Cardinal;
  protected
    class function RecurringType: TScheduleRecurringKind; override;

    function ValidStamp(const Stamp: TTimeStamp): Boolean; override;
    procedure MakeValidStamp(var Stamp: TTimeStamp); override;
    function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;
  public
    constructor Create(const Controller: IUnknown);
    // IJclWeeklySchedule
    function GetDaysOfWeek: TScheduleWeekDays;
    function GetInterval: Cardinal;
    procedure SetDaysOfWeek(Value: TScheduleWeekDays);
    procedure SetInterval(Value: Cardinal);

    property DaysOfWeek: TScheduleWeekDays read GetDaysOfWeek write SetDaysOfWeek;
    property Interval: Cardinal read GetInterval write SetInterval;
  end;

constructor TWeeklySchedule.Create(const Controller: IUnknown);
begin
  inherited Create(Controller);
  FDaysOfWeek := [swdMonday];
  FInterval := 1;
end;

class function TWeeklySchedule.RecurringType: TScheduleRecurringKind;
begin
  Result := srkWeekly;
end;

function TWeeklySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;
begin
  Result := (TScheduleWeekDay(TimeStampDOW(Stamp)) in DaysOfWeek) and
    (Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval = 0);
end;

procedure TWeeklySchedule.MakeValidStamp(var Stamp: TTimeStamp);
begin
  while not (TScheduleWeekDay(TimeStampDOW(Stamp) - 1) in DaysOfWeek) do
    Inc(Stamp.Date);
  if (Stamp.Date - Schedule.StartDate.Date) <> 0 then
  begin
    if Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval <> 0 then
      Inc(Stamp.Date, 7 * (Interval -
        (Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval)));