jvcalendar.pas

East make Tray Icon in delphi

      FTextColor := Value;
    2:
      FTitleBackColor := Value;
    3:
      FTitleTextColor := Value;
    4:
      FMonthBackColor := Value;
    5:
      FTrailingTextColor := Value;
  end;
end;

function TJvMonthCalColors.GetColor(Index: Integer): TColor;
begin
  case Index of
    0:
      Result := FBackColor;
    1:
      Result := FTextColor;
    2:
      Result := FTitleBackColor;
    3:
      Result := FTitleTextColor;
    4:
      Result := FMonthBackColor;
    5:
      Result := FTrailingTextColor;
  else
    Result := 0;
  end;
end;

procedure TJvMonthCalColors.SetAllColors;
begin
  SetColor(0, FBackColor);
  SetColor(1, FTextColor);
  SetColor(2, FTitleBackColor);
  SetColor(3, FTitleTextColor);
  SetColor(4, FMonthBackColor);
  SetColor(5, FTrailingTextColor);
end;

//=== { TMonthCalStrings } ===================================================

type
  TMonthCalStrings = class(TStringList)
  private
    Calendar: TJvCustomMonthCalendar;
  protected
    function GetDateIndex(Year, Month: Word): Integer; virtual;
    function GetBoldDays(Y, M: Word): string; virtual;
  public
    constructor Create;
    { (RB) This is the same as the TStrings.AddString implementation ??? }
    procedure AddStrings(Strings: TStrings); override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    { (RB) no need to override Add, TStringList.Add just calls AddObject }
    //function Add(const S: string): Integer; override;
    function IsBold(Year, Month, Day: Word): Boolean;
    procedure SetBold(Year, Month, Day: Word; Value: Boolean);
    function AddDays(Year, Month: Word; const Days: string): Integer; virtual;
  end;

constructor TMonthCalStrings.Create;
begin
  inherited Create;
  Sorted := True;
  Duplicates := dupIgnore;
end;

{ Days is a comma separated list of days to set as bold. If Days is empty, the
  line is removed (if found) }

function TMonthCalStrings.AddDays(Year, Month: Word; const Days: string): Integer;
begin
  if Days = '' then
  begin
    Result := GetDateIndex(Year, Month);
    if Result > -1 then
      Delete(Result);
  end
  else
    Result := Add(Format('%.4d%.2d=%s', [Year, Month, Days]));
end;

{ Note!
  This must be fully qualified, i.e. '199801=1,2,3,4,5' or '000012=25,31' etc
}

(*function TMonthCalStrings.Add(const S: string): Integer;
begin
  if AnsiPos('=', S) <> 7 then
    raise EMonthCalError.CreateResFmt(@RsEInvalidDateStr, [S]);

  Result := IndexOfName(Copy(S, 1, 6));
  if Result > -1 then
  begin
    Sorted := False;
    Strings[Result] := S;
    Sorted := True;
  end
  else
    Result := inherited Add(S);
  if (Calendar <> nil) and Calendar.HandleAllocated then
    Calendar.DoBoldDays;
end;*)

function TMonthCalStrings.IsBold(Year, Month, Day: Word): Boolean;
var
  DayState: TMonthDayState;
begin
  DayState := StringToDayStates(GetBoldDays(Year, Month) + ',' + GetBoldDays(0, Month));
  Result := (DayState and (1 shl (Day - 1))) <> 0;
end;

procedure TMonthCalStrings.SetBold(Year, Month, Day: Word; Value: Boolean);
var
  S: string;
  DayState: TMonthDayState;
begin
  if IsBold(Year, Month, Day) <> Value then
  begin
    S := GetBoldDays(Year, Month) + ',' + GetBoldDays(0, Month);
    if Value then
    begin
      if S = '' then
        S := IntToStr(Day)
      else
        S := S + Format('%d,', [Day]);
      AddDays(Year, Month, S);
      Exit;
    end;
    DayState := StringToDayStates(S);
    DayState := DayState and not (1 shl (Day - 1));
    AddDays(Year, Month, DayStatesToString(DayState));
  end;
end;

procedure TMonthCalStrings.AddStrings(Strings: TStrings);
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to Strings.Count - 1 do
      Add(Strings[I]);
  finally
    EndUpdate;
  end;
end;

function TMonthCalStrings.AddObject(const S: string; AObject: TObject): Integer;
begin
  if AnsiPos('=', S) <> 7 then
    raise EMonthCalError.CreateResFmt(@RsEInvalidDateStr, [S]);

  Result := IndexOfName(Copy(S, 1, 6));
  if Result > -1 then
  begin
    Sorted := False;
    Strings[Result] := S;
    Sorted := True;
  end
  else
    Result := inherited AddObject(S, AObject);
  if (Calendar <> nil) and Calendar.HandleAllocated then
    Calendar.DoBoldDays;
end;

function TMonthCalStrings.GetDateIndex(Year, Month: Word): Integer;
var
  S: string;
begin
  if Year = 0 then
    S := Format('0000%.2d', [Month])
  else
    S := Format('%.4d%.2d', [Year, Month]);

  for Result := 0 to Count - 1 do
    if AnsiSameText(Names[Result], S) then
      Exit;
  Result := -1;
end;

function TMonthCalStrings.GetBoldDays(Y, M: Word): string;
var
  S: string;
begin
  if Y = 0 then
    S := Format('0000%.2d', [M])
  else
    S := Format('%.4d%.2d', [Y, M]);
  Result := Values[S];
end;

//=== { TJvCustomMonthCalendar } =============================================

constructor TJvCustomMonthCalendar.Create(AOwner: TComponent);
begin
  CreateWithAppearance(AOwner, TJvMonthCalAppearance.Create, True);
end;

constructor TJvCustomMonthCalendar.CreateWithAppearance(AOwner: TComponent;
  const AAppearance: TJvMonthCalAppearance; const AOwnsAppearance: Boolean);
begin
  if not Assigned(AAppearance) then
    raise EMonthCalError.CreateRes(@RsEInvalidAppearance);
  CheckCommonControl(ICC_DATE_CLASSES);
  inherited Create(AOwner);
  FAppearance := AAppearance;
  FOwnsAppearance := AOwnsAppearance;

  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks, csReflector];

  FAppearance.Calendar := Self;

  FMultiSelect := False;
  FMaxSelCount := 7;
  FMinDate := 0.0;
  FMaxDate := 0.0;
  FFirstSelDate := Date;
  FLastSelDate := 0.0;
  FMonthDelta := 1;
  FToday := Now;
  FBorderStyle := bsNone;
  FEntering := False;
  FLeaving := False;
  inherited Color := clWindow;
  ParentColor := False;
  TabStop := True;
  Width := MinSize.Right;
  Height := MinSize.Bottom;
end;

destructor TJvCustomMonthCalendar.Destroy;
begin
  if (FOwnsAppearance) then
    FreeAndNil(FAppearance);
  inherited Destroy;
end;

procedure TJvCustomMonthCalendar.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);
  MultiSelects: array [Boolean] of DWORD = (0, MCS_MULTISELECT);
  NoTodays: array [Boolean] of DWORD = (MCS_NOTODAY, 0);
  NoCircles: array [Boolean] of DWORD = (MCS_NOTODAYCIRCLE, 0);
  Weeks: array [Boolean] of DWORD = (0, MCS_WEEKNUMBERS);
begin
  InitCommonControl(ICC_DATE_CLASSES);
  inherited CreateParams(Params);
  CreateSubClass(Params, MONTHCAL_CLASS);
  with Params do
  begin
    if GetComCtlVersion >= ComCtlVersionIE4 then
      Style := Style or BorderStyles[FBorderStyle] or MultiSelects[FMultiSelect] or
        NoTodays[FAppearance.ShowToday] or NoCircles[FAppearance.CircleToday] or
        Weeks[FAppearance.WeekNumbers] or MCS_DAYSTATE
    else
      // IE3 doesn't implement the NoTodayCircle style, instead it uses
      // the same constant for MCS_NOTODAY as IE4 does for MCS_NOTODAYCIRCLE ...
      Style := Style or BorderStyles[FBorderStyle] or MultiSelects[FMultiSelect] or
        NoCircles[FAppearance.ShowToday] or Weeks[FAppearance.WeekNumbers] or MCS_DAYSTATE;
    if NewStyleControls and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
    end;
    WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;
  end;
end;

procedure TJvCustomMonthCalendar.SetColors(Value: TJvMonthCalColors);
begin
  FAppearance.Colors := Value;
end;

procedure TJvCustomMonthCalendar.SetBoldDays(Value: TStrings);
begin
  FAppearance.BoldDays := Value;
end;

function TJvCustomMonthCalendar.IsBold(Year, Month, Day: Word): Boolean;
begin
  Result := TMonthCalStrings(FAppearance.BoldDays).IsBold(Year, Month, Day);
end;

function TJvCustomMonthCalendar.GetDays(Year, Month: Word): string;
begin
  Result := TMonthCalStrings(FAppearance.BoldDays).GetBoldDays(Year, Month);
end;

procedure TJvCustomMonthCalendar.SetDays(Year, Month: Word; Value: string);
begin
  TMonthCalStrings(FAppearance.BoldDays).AddDays(Year, Month, Value);
end;

procedure TJvCustomMonthCalendar.SetBold(Year, Month, Day: Word; Value: Boolean);
begin
  TMonthCalStrings(FAppearance.BoldDays).SetBold(Year, Month, Day, Value);
end;

{ gets the first visible calendar month }

function TJvCustomMonthCalendar.FirstVisibleDate(Partial: Boolean): TDateTime;
var
  rgst: array [0..1] of TSystemTime;
  Flag: Integer;
begin
  Result := 0;
  if Partial then
    Flag := GMR_DAYSTATE
  else
    Flag := GMR_VISIBLE;
  if SendMessage(Handle, MCM_GETMONTHRANGE, Flag, Longint(@rgst)) <> 0 then
    with rgst[0] do
      Result := Trunc(EncodeDate(wYear, wMonth, wDay));
end;

{ gets the last visible calendar month }

function TJvCustomMonthCalendar.LastVisibleDate(Partial: Boolean): TDateTime;
const
  IsPartial: array [Boolean] of Integer = (GMR_VISIBLE, GMR_DAYSTATE);
var
  rgst: array[0..1] of TSystemTime;
  Flag: Integer;
begin
  Result := 0;
  Flag := IsPartial[Partial];
  if SendMessage(Handle, MCM_GETMONTHRANGE, Flag, Longint(@rgst)) <> 0 then
    with rgst[1] do
      Result := Trunc(EncodeDate(wYear, wMonth, wDay));
end;

{ protected }

procedure TJvCustomMonthCalendar.Change;
var
  rgst: array [0..1] of TSystemTime;
  Y, M, D: Word;
begin
  if not HandleAllocated then
    Exit;
  MonthCal_SetFirstDayOfWeek(Handle, Ord(FAppearance.FirstDayOfWeek) - 1);
  MonthCal_SetMaxSelCount(Handle, FMaxSelCount);

  MonthCal_SetMonthDelta(Handle, FMonthDelta);
  SetSelectedDays(FFirstSelDate, FLastSelDate);
  if (FMinDate <> 0) and (FMaxDate <> 0) then
  begin
    DecodeDate(FMinDate, Y, M, D);
    with rgst[0] do
    begin
      wYear := Y;
      wMonth := M;
      wDay := D;
    end;
    DecodeDate(FMaxDate, Y, M, D);
    with rgst[1] do
    begin
      wYear := Y;
      wMonth := M;
      wDay := D;
    end;
    MonthCal_SetRange(Handle, GDTR_MIN or GDTR_MAX, @rgst[0]);
  end
  else
    MonthCal_SetRange(Handle, 0, nil);
  DecodeDate(FToday, Y, M, D);
  with rgst[0] do
  begin
    wYear := Y;
    wMonth := M;
    wDay := D;
  end;
  MonthCal_SetToday(Handle, rgst[0]);
end;

procedure TJvCustomMonthCalendar.DoBoldDays;
var
  Y, M, D: Word;
  DayArray: TMonthDayStateArray;
  NMDayState: TNMDayState;
begin
  if not HandleAllocated then
    Exit;
  DecodeDate(FirstVisibleDate(True), Y, M, D);
  FillChar(DayArray, SizeOf(TMonthDayStateArray), 0);
  with NMDayState do
  begin
    stStart.wYear := Y;
    stStart.wMonth := M;
    stStart.wDay := D;
    cDayState := VisibleMonths;
    prgDayState := PMonthDayState(@DayArray);
  end;
  for D := 0 to VisibleMonths - 1 do
  begin
    CheckDayState(Y, M, DayArray[D]);
    Inc(M);
    if M > 12 then
    begin
      M := 1;
      Inc(Y);
    end;
  end;
  SendMessage(Handle, MCM_SETDAYSTATE, VisibleMonths, Longint(@DayArray));
  //  MonthCal_SetDayState(Handle,VisibleMonths,aNMDayState);
end;

procedure TJvCustomMonthCalendar.DoDateSelect(StartDate, EndDate: TDateTime);
begin
  if Assigned(FOnSelect) then
    FOnSelect(Self, StartDate, EndDate);
end;

procedure TJvCustomMonthCalendar.DoDateSelChange(StartDate, EndDate: TDateTime);
begin
  if Assigned(FOnSelChange) then
    FOnSelChange(Self, StartDate, EndDate);
end;

procedure TJvCustomMonthCalendar.CheckDayState(Year, Month: Word; var DayState: TMonthDayState);
begin
  DayState := StringToDayStates(TMonthCalStrings(FAppearance.BoldDays).GetBoldDays(Year, Month));
end;

procedure TJvCustomMonthCalendar.DoGetDayState(var DayState: TNMDayState; var StateArray: TMonthDayStateArray);
var
  aDate: TDateTime;
  I: Integer;
  Y, M: Word;
begin
  FillChar(StateArray, SizeOf(TMonthDayStateArray), #0);
  with DayState.stStart do
  begin
    Y := wYear;
    M := wMonth;
  end;
  with DayState do
    for I := 0 to cDayState - 1 do
    begin
      CheckDayState(Y, M, StateArray[I]);
      Inc(M);
      if M > 12 then
      begin
        M := 1;
        Inc(Y);
      end;
    end;

  with DayState.stStart do
    aDate := Trunc(EncodeDate(wYear, wMonth, 1));

  if Assigned(FOnGetState) then
    with DayState do
      FOnGetState(Self, aDate, cDayState, StateArray);
  DayState.prgDayState := PMonthDayState(@StateArray);
end;

procedure TJvCustomMonthCalendar.CreateWnd;
begin
  inherited CreateWnd;
  FAppearance.Colors.SetAllColors;
  Change;
end;

procedure TJvCustomMonthCalendar.ColorChanged;