lazarus-ccr/components/tvplanit/source/vpbase.pas

{*********************************************************}
{*                   VPBASE.PAS 1.03                     *}
{*********************************************************}

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is TurboPower Visual PlanIt                              *}
{*                                                                            *}
{* The Initial Developer of the Original Code is TurboPower Software          *}
{*                                                                            *}
{* Portions created by TurboPower Software Inc. are Copyright (C) 2002        *}
{* TurboPower Software Inc. All Rights Reserved.                              *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

{$I vp.inc}

unit VpBase;

interface

uses
  {$IFDEF LCL}
  LMessages, LCLProc, LCLType, LResources,
  {$ELSE}
  Windows, Messages.
  {$ENDIF}
  Classes, Graphics,
  Controls, Dialogs, Forms, ExtCtrls, SysUtils, ImgList, Menus,
  VpConst, VpSR;

const
  {Message base}
  Vp_First              = WM_USER;  // $7DF0;   {Sets base for all Vp messages}

const
  {Custom message types}
  Vp_PrintFormatChanged = Vp_First + 1;   {Print formats have changed}
  Vp_DataStoreChanged   = Vp_First + 2;   {Data Store has changed}
  Vp_DayViewInit        = Vp_First + 3;   {Initialize the DayView}

type
 {$IF FPC_FullVersion < 30000}
  TStringArray = array of string;
 {$ENDIF}
  TVpRotationAngle = (ra0, ra90, ra180, ra270);
  TVpItemMeasurement = (imAbsolutePixel, imPercent, imInches, imCentimeters);
  TVpItemType = (itDayView, itWeekView, itMonthView, itCalendar,
                 itShape, itCaption, itTasks, itContacts);

  TVpHours = (h_00, h_01, h_02, h_03, h_04, h_05, h_06, h_07, h_08,
              h_09, h_10, h_11, h_12, h_13, h_14, h_15, h_16, h_17,
              h_18, h_19, h_20, h_21, h_22, h_23);

  TVpGranularity = (gr05Min, gr06Min, gr10Min, gr15Min, gr20Min, gr30Min, gr60Min);

  TVpEditorReturnCode = (rtCommit, rtAbandon);

  TVpCheckStyle = (csX, csCheck);

  TVpTimeFormat = (tf24Hour, tf12Hour);

  TVpPlaySoundMode = (psmSync, psmAsync, psmStop);

  TVpHintMode = (hmPlannerHint, hmComponentHint);

  TVpMenuItemKind = (mikSeparator,
    mikAddEvent, mikEditEvent, mikDeleteEvent,
    mikAddTask, mikEditTask, mikDeleteTask,
    mikAddContact, mikEditContact, mikDeleteContact,
    mikImportEventFromICal, mikExportEventToICal,
    mikImportTaskFromICal,
    mikImportContactFromVCards, mikExportContactToVCard,
    mikResourceGroups, mikNoOverlaidEvents,
    mikChangeDate, mikCustomDate, mikToday, mikYesterday, mikTomorrow,
    mikPrevDay, mikNextDay, mikPrevWeek, mikNextWeek,
    mikPrevMonth, mikNextMonth, mikPrevYear, mikNextYear
  );

 const
   VpMenuCaptions: array[TVpMenuItemKind] of String = ('-',
     RSPopupAddEvent, RSPopupEditEvent, RSPopupDeleteEvent,
     RSTaskPopupAdd, RSTaskPopupEdit, RSTaskPopupDelete,
     RSContactPopupAdd, RSContactPopupEdit, RSContactPopupDelete,
     RSPopupImportEventFromICal, RSPopupExportEventToICal,
     RSPopupAddTaskFromICal,
     RSContactPopupImportVCards, RSContactPopupExportVCard,
     RSPopupResourceGroups, RSNoOverlayedEvents,
     RSPopupChangeDate, RSCustomDate, RSToday, RSYesterday, RSTomorrow,
     RSPrevDay, RSNextDay, RSPrevWeek, RSNextWeek,
     RSPrevMonth, RSNextMonth, RSPrevYear, RSNextYear
   );

 type

  { XML definitions }
  DOMString = WideString;

  { miscellaneous stuff }
  TVpDrawingStyle = (dsFlat, ds3d, dsNoBorder);    // wp: rename dsNone --> dsNoBorder

  { event method types }
  TVpMouseWheelEvent = procedure(Sender: TObject; Shift: TShiftState;
    Delta, XPos, YPos: Word) of object;

  TVpOwnerDrawEvent = procedure(Sender: TObject; const Canvas: TCanvas;
    R: TRect; var Drawn: Boolean) of object;

  TVpOwnerDrawRowEvent = procedure(Sender: TObject; const Canvas: TCanvas;
    R: TRect; RowHeight: Integer; var Drawn: Boolean) of object;

  TVpOwnerDrawDayEvent = procedure(Sender: TObject; const Canvas: TCanvas;
    R: TRect; Day: Integer; var Drawn: Boolean) of object;

  TVpItemSelectedEvent = procedure(Sender: TObject;
    Index: Integer) of object;

  TVpGetEditorCaption = procedure(var Caption: string) of object;

  TVpPlaySoundEvent = procedure(Sender: TObject; const AWavFile: String;
    AMode: TVpPlaySoundMode) of object;

  TVpHolidayEvent = procedure(Sender: TObject; ADate: TDateTime;
    var AHolidayName: String) of object;

  { Visual planit Exceptions }
  EVpException = class(Exception);

  { XML exceptions }
  EXML = class(EVpException);

  EVpStreamError = class(EXML)
  private
    seFilePos : Longint;
  public
    constructor CreateError(const FilePos: Longint; const Reason: DOMString); overload;
   {$IFDEF FPC}
    constructor CreateError(const FilePos: Longint; const Reason: String); overload;
    {$ENDIF}
    property FilePos: Longint read seFilePos;
  end;

  EVpFilterError = class(EVpStreamError)
  private
    feReason: DOMString;
    feLine: Longint;
    feLinePos: Longint;
  public
    constructor CreateError(const FilePos, Line, LinePos: Longint; const Reason: DOMstring); overload;
    {$IFDEF FPC}
    constructor CreateError(const FilePos, Line, LinePos: Longint; const Reason: string); overload;
    {$ENDIF}
    property Reason : DOMString read feReason;
    property Line: Longint read feLine;
    property LinePos: Longint read feLinePos;
  end;

  EVpParserError = class(EVpFilterError)
  public
    constructor CreateError(Line, LinePos: Longint; const Reason: DOMString); overload;
   {$IFDEF FPC}
    constructor CreateError(Line, LinePos: Longint; const Reason: String); overload;
   {$ENDIF}
  end;

  { implements the Version property with its associated design time About box }
  TVpComponent = class(TComponent)
  protected { private }
    function GetVersion: string;
    procedure SetVersion(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
  published
    { properties }
    property Version: string read GetVersion write SetVersion stored False;
  end;

  { Ancestor for all Visual PlanIt visual controls }
  TVpCustomControl = class(TCustomControl)
  protected { private }
    FAfterEnter: TNotifyEvent;
    FAfterExit: TNotifyEvent;
    FOnMouseWheel: TVpMouseWheelEvent;
    FAutoScroll: Boolean;
    function GetVersion : string;
    procedure SetVersion(const Value: string);
    procedure CMVisibleChanged(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF}); message CM_VISIBLECHANGED;
    {$IFDEF DELPHI}
    procedure WMMouseWheel(var Msg : TMessage); message WM_MOUSEWHEEL;
    procedure DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); dynamic;
    {$ENDIF}
    procedure CreateWnd; override;
    property AfterEnter: TNotifyEvent read FAfterEnter write FAfterEnter;
    property AfterExit: TNotifyEvent read FAfterExit write FAfterExit;
    property OnMouseWheel: TVpMouseWheelEvent read FOnMouseWheel write FOnMouseWheel;

  public
    constructor Create (AOwner : TComponent); override;                  

  published
    property Version: string read GetVersion write SetVersion stored False;
    {$IFNDEF LCL}
    {$IFDEF VERSION6}
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind;
    property BevelWidth;
    {$ENDIF}
    {$ENDIF}

    { The Hint property is published in TControl, but the ShowHint }
    { property is left public. odd.                                }
    { surfacing here will make it published in all our descendants }
    property ShowHint;
  end;

  TVpPersistent = class(TPersistent)
  public
    procedure Invalidate; virtual; abstract;
  end;

  {TVpCategoryColorMap}
  TVpCategoryColorMap = class;

  TVpCategoryInfo= class(TPersistent)
  private
    FOwner: TComponent;  // This is the DataStore.
    FCategoryIndex: Integer;
  protected
    FBackgroundColor: TColor;
    FColor: TColor;
    FDescription: string;
    FImageIndex: TImageIndex;
    FIndex: Integer;
    FBitmap: TBitmap;
    FAllDayEvents: Boolean;
    procedure SetBackgroundColor(const v: TColor);
    procedure SetBitmap(v: TBitmap);
    procedure SetColor(Value: TColor);
    procedure SetDescription(Value: string);
    procedure SetImageIndex(Value: TImageIndex);
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    property Owner: TComponent read FOwner;
  published
    property BackgroundColor: TColor
      read FBackgroundColor write SetBackgroundColor default clWindow;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Color: TColor read FColor write SetColor;
    property Description: string read FDescription write SetDescription;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
    property CategoryIndex: Integer read FCategoryIndex;
    property UseForAllDayEvents: Boolean read FAllDayEvents write FAllDayEvents default false;
  end;

  TVpCategoryColorMap = class(TPersistent)
  protected
    FOwner: TComponent;
    FCat: array[0..9] of TVpCategoryInfo;
    procedure SetCat(AIndex: Integer; AValue: TVpCategoryInfo);
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    function GetColor(AIndex: Integer): TColor;
    function GetName(AIndex: Integer):string;
    function GetCategory(AIndex: Integer): TVpCategoryInfo;
    function GetCategoryName(AIndex: Integer): String;
    function IndexOfCategory(AName: String): Integer;
    function IndexOfFirstUnusedCategory: Integer;
    procedure SetCategoryName(AIndex: Integer; AName: String);
  published
    property Category0: TVpCategoryInfo index 0 read GetCategory write SetCat;
    property Category1: TVpCategoryInfo index 1 read GetCategory write SetCat;
    property Category2: TVpCategoryInfo index 2 read GetCategory write SetCat;
    property Category3: TVpCategoryInfo index 3 read GetCategory write SetCat;
    property Category4: TVpCategoryInfo index 4 read GetCategory write SetCat;
    property Category5: TVpCategoryInfo index 5 read GetCategory write SetCat;
    property Category6: TVpCategoryInfo index 6 read GetCategory write SetCat;
    property Category7: TVpCategoryInfo index 7 read GetCategory write SetCat;
    property Category8: TVpCategoryInfo index 8 read GetCategory write SetCat;
    property Category9: TVpCategoryInfo index 9 read GetCategory write SetCat;
  end;

  { TVpFont }
  TVpFont = class(TFont)
  protected
    FOwner: TObject;
    procedure Changed; override;
  public
    constructor Create(AOwner: TObject); virtual; reintroduce;
    property Owner: TObject read FOwner write FOwner; 
  end;

  { Collections }
  TVpCollectionItem = class(TCollectionItem)
  protected { private }
    FName: String;
    FDisplayText: String;
    function GetVersion: String;
    procedure SetVersion(const Value: String);
    procedure SetName(Value: String); virtual;
  public
    property DisplayText: string read FDisplayText write FDisplayText;
    property Name: String read FName write SetName;
  published
    property Version: String read GetVersion write SetVersion;
  end;

  TVpCollection = class(TCollection)
  protected { private }
    { property variables }
    FItemEditor: TForm;
    FReadOnly: Boolean;
    FOwner: TPersistent;
    { event variables }
    FOnChanged: TNotifyEvent;
    FOnItemSelected: TVpItemSelectedEvent;
    FOnGetEditorCaption: TVpGetEditorCaption;
    { Internal variables }
    InLoaded: Boolean;
    IsLoaded: Boolean;
    InChanged: Boolean;
  protected
    function GetCount: Integer;
    procedure Loaded;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass); virtual;
    destructor Destroy; override;
    property ItemEditor: TForm read FItemEditor write FItemEditor;
    function Add: TVpCollectionItem; dynamic;
    {$IFNDEF VERSION4}
    function Insert(Index: Integer): TVpCollectionItem; dynamic;
    {$ENDIF}
    function GetItem(Index: Integer): TVpCollectionItem;
    function GetOwner: TPersistent; override;
    procedure SetItem(Index: Integer; Value: TVpCollectionItem);
    procedure DoOnItemSelected(Index: Integer);
    function GetEditorCaption: string;
    function ItemByName(const Name: string) : TVpCollectionItem;
    function ParentForm: TForm;
    property Count: Integer read GetCount;
    property Item[Index: Integer]: TVpCollectionItem read GetItem write SetItem; default;
    property OnGetEditorCaption: TVpGetEditorCaption read FOnGetEditorCaption write FOnGetEditorCaption;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    property OnItemSelected: TVpItemSelectedEvent read FOnItemSelected write FOnItemSelected;
  end;

  TVpContainerList = class(TList)
  protected{ private }
    FOwner: TComponent;
  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
  end;
  { End - Collections }

  TVpTimeRange = class(TPersistent)
  protected{private}
    FOwner: TObject;
    FStartTime: TDateTime;
    FEndTime: TDateTime;
    FRangeBegin: TVpHours;
    FRangeEnd: TVpHours;
    procedure SetRangeBegin(const Value: TVpHours);
    procedure SetRangeEnd(const Value: TVpHours);
    procedure SetEndTime(const Value: TDateTime);
    procedure SetStartTime(const Value: TDateTime);
  public
    constructor Create(aOwner: TObject);
    destructor Destroy; override;
    property StartTime: TDateTime read FStartTime write SetStartTime;
    property EndTime: TDateTime read FEndTime write SetEndTime;
  published
    property RangeBegin: TVpHours read FRangeBegin write SetRangeBegin;
    property RangeEnd: TVpHours read FRangeEnd write SetRangeEnd;
  end;

  TVpTimeSlotColor = class(TPersistent)
  protected { private }
    FOwner: TVpCustomControl;
    FActiveRange: TVpTimeRange;
    FInactive: TColor;
    FHoliday: TColor;
    FWeekend: TColor;
    FActive: TColor;
    FWeekday: TColor;
    procedure SetActive(const Value: TColor);
    procedure SetHoliday(const Value: TColor);
    procedure SetInactive(const Value: TColor);
    procedure SetWeekday(const Value: TColor);
    procedure SetWeekend(const Value: TColor);
  public
    constructor Create(AOwner: TVpCustomControl);
    destructor Destroy; override;
    procedure Changed;
  published
    property Active: TColor read FActive write SetActive;
    property Inactive: TColor read FInactive write SetInactive default OFF_COLOR;
    property Holiday: TColor read FHoliday write SetHoliday default HOLIDAY_COLOR;
    property Weekday: TColor read FWeekday write SetWeekday default WEEKDAY_COLOR;
    property Weekend: TColor read FWeekend write SetWeekend default WEEKEND_COLOR;
    property ActiveRange: TVpTimeRange read FActiveRange write FActiveRange;
  end;

  TVpHintWindow = class(THintWindow)
  public
    function CalcHintRect({%H-}MaxWidth: Integer; const AHint: String;
      AData: pointer): TRect; override;
  end;

  TVpMenuItem = class(TMenuItem)
  private
    FKind: TVpMenuItemKind;
    procedure SetKind(AValue: TVpMenuItemKind);
  public
    procedure Translate;
    property Kind: TVpMenuItemKind read FKind write SetKind;
  end;


implementation

{$IFDEF NEW_ICONS}
  {$R vpbasepng.res}
{$ELSE}
  {$R vpbase.res}
{$ENDIF}

uses
{$IFNDEF LCL}
  CommCtrl,
{$ENDIF}
  VpMisc;


{ EAdStreamError }

constructor EVpStreamError.CreateError(const FilePos: Integer;
  const Reason: DOMString);
begin
  {$IFDEF FPC}
  inherited Create(UTF8Encode(Reason));
  {$ELSE}
  inherited Create(Reason);
  {$ENDIF}
  seFilePos := FilePos;
end;

{$IFDEF FPC}
constructor EVpStreamError.CreateError(const FilePos: Integer;
  const Reason: String);
begin
  inherited Create(Reason);
  seFilePos := FilePos;
end;
{$ENDIF}


{ EAdFilterError }

constructor EVpFilterError.CreateError(const FilePos, Line, LinePos: Integer;
  const Reason: DOMString);
begin
  inherited CreateError(FilePos, Reason);
  feLine := Line;
  feLinePos := LinePos;
  feReason := Reason;
end;

{$IFDEF FPC}
constructor EVpFilterError.CreateError(const FilePos, Line, LinePos: Integer;
  const Reason: String);
begin
  feReason := UTF8DEcode(Reason);
  inherited CreateError(FilePos, feReason);
  feLine := Line;
  feLinePos := LinePos;
end;
{$ENDIF}


{ EAdParserError }

constructor EVpParserError.CreateError(Line, LinePos: Integer;
  const Reason: DOMString);
begin
  inherited CreateError(FilePos, Line, LinePos, Reason);
end;

{$IFDEF FPC}
constructor EVpParserError.CreateError(Line, LinePos: Integer;
  const Reason: String);
begin
  inherited CreateError(FilePos, Line, LinePos, Reason);
end;
{$ENDIF}


(*****************************************************************************)
{ TVpCustomControl }

constructor TVpCustomControl.Create(AOwner: TComponent);
begin
  inherited Create (AOwner);
  TabStop := True;
end;

procedure TVpCustomControl.CMVisibleChanged(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF});
begin
  inherited;
  if csLoading in ComponentState then
    Exit;
end;

procedure TVpCustomControl.CreateWnd;
begin
  inherited CreateWnd;
end;

function TVpCustomControl.GetVersion: string;
begin
  Result := VpVersionStr;
end;

procedure TVpCustomControl.SetVersion(const Value: string);
begin
  // This method left intentionally blank.
  Unused(Value);
end;

{$IFDEF DELPHI}
procedure TVpCustomControl.WMMouseWheel(var Msg: TMessage);
begin
  with Msg do
    DoOnMouseWheel(
      KeysToShiftState(LOWORD(wParam)) {fwKeys},
      HIWORD(wParam) {zDelta},
      LOWORD(lParam) {xPos},
      HIWORD(lParam) {yPos}
    );
end;

procedure TVpCustomControl.DoOnMouseWheel(Shift: TShiftState;
  Delta, XPos, YPos: SmallInt);
begin
  if Assigned(FOnMouseWheel) then
    FOnMouseWheel(Self, Shift, Delta, XPos, YPos);
end;
{$ENDIF}


(*****************************************************************************)
{ TVpCollection }

constructor TVpCollection.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
begin
  FOwner := AOwner;
  Inherited Create(ItemClass);
end;

destructor TVpCollection.Destroy;
begin
  ItemEditor.Free;
  Clear;
  inherited Destroy;
end;

procedure TVpCollection.DoOnItemSelected(Index: Integer);
begin
  if Assigned(FOnItemSelected) then
    FOnItemSelected(Self, Index);
end;

function TVpCollection.GetCount: Integer;
begin
  Result := inherited Count;
end;

function TVpCollection.GetEditorCaption: string;
begin
  Result := 'Editing ' + ClassName;
  if Assigned(FOnGetEditorCaption) then
    FOnGetEditorCaption(Result);
end;

function TVpCollection.Add: TVpCollectionItem;
begin
  Result := TVpCollectionItem(inherited Add);
  if ItemEditor <> nil then
//TODO:    SendMessage(ItemEditor.Handle, Vp_PROPCHANGE, 0, 0);
end;

{$IFNDEF VERSION4}
function TVpCollection.Insert(Index: Integer): TVpCollectionItem;
var
  I: Integer;
begin
  result := Add;
  for I := Index to Count - 2 do
    Items[I].Index := I + 1;
  Items[Count - 1].Index := Index;
end;
{$ENDIF}

function TVpCollection.GetItem(Index: Integer): TVpCollectionItem;
begin
  Result := TVpCollectionItem(inherited GetItem(Index));
end;

function TVpCollection.GetOwner: TPersistent;
begin
  result := FOwner;
end;

procedure TVpCollection.SetItem(Index: Integer; Value: TVpCollectionItem);
begin
  inherited SetItem(Index, Value);
end;

function TVpCollection.ItemByName(const Name: string): TVpCollectionItem;
var
  i : Integer;
begin
  for i := 0 to pred(Count) do
    if Item[i].Name = Name then begin
      Result := Item[i];
      exit;
    end;
  Result := nil;
end;

procedure TVpCollection.Loaded;
begin
  InLoaded := True;
  try
    Changed;
  finally
    InLoaded := False;
  end;
  IsLoaded := True;
end;

function TVpCollection.ParentForm : TForm;
var
  Temp : TObject;
begin
  Temp := GetOwner;
  while (Temp <> nil) and not (Temp is TForm) do
    Temp := TComponent(Temp).Owner;
  Result := TForm(Temp);
end;


(*****************************************************************************)
{ TVpCollectionItem }

function TVpCollectionItem.GetVersion: String;
begin
  Result := VpVersionStr;
end;

procedure TVpCollectionItem.SetVersion(const Value: String);
begin
  Unused(Value);
end;

procedure TVpCollectionItem.SetName(Value: String);
begin
  FName := Value;
end;


(*****************************************************************************)
{ TO32ContainerList }

constructor TVpContainerList.Create(AOwner: TComponent);
begin
  inherited Create;
  FOwner := TComponent(AOwner);
end;

destructor TVpContainerList.Destroy;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    TPanel(Items[I]).Free;
  inherited;
end;


(*****************************************************************************)
{ TVpComponent }

constructor TVpComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

function TVpComponent.GetVersion: string;
begin
  Result := VpVersionStr;
end;

procedure TVpComponent.SetVersion(const Value: string);
begin
// This method left intentionally blank.
  Unused(Value);
end;


(*****************************************************************************)
{ VpFont }

procedure TVpFont.Changed;
begin
  inherited;
  Assert(
    (FOwner is TControl) or (FOwner is TVpPersistent),
    Format('TVpFont.Changed: Unexpected parent class: %s', [FOwner.ClassName])
  );
  if FOwner is TControl then
    TControl(FOwner).Invalidate
  else if FOwner is TVpPersistent then
    TVpPersistent(FOwner).Invalidate;
end;

constructor TVpFont.Create(AOwner: TObject);
begin
  inherited Create;
  FOwner := AOwner;
end;


(*****************************************************************************)
{ TVpCategoryColorMap }

constructor TVpCategoryColorMap.Create(AOwner: TComponent);
const
  CAT_COLORS: Array[0..9] of TColor = (
    clNavy, clRed, clYellow, clLime, clPurple, clTeal, clFuchsia, clOlive, clAqua, clMaroon
  );
var
  i: Integer;
begin
  inherited Create;
  FOwner := AOwner;
  for i:=Low(FCat) to High(FCat) do
  begin
    FCat[i] := TVpCategoryInfo.Create(FOwner);
    FCat[i].FIndex := i;
    FCat[i].Color := CAT_COLORS[i];
    FCat[i].Description := Format(RSCategoryDesc, [i]);
  end;
end;

destructor TVpCategoryColorMap.Destroy;
var
  i: Integer;
begin
  for i:=Low(FCat) to High(FCat) do FCat[i].Free;
  inherited;
end;

function TVpCategoryColorMap.GetCategory(AIndex: Integer): TVpCategoryInfo;
begin
  Result := FCat[AIndex];
end;

function TVpCategoryColorMap.GetCategoryName(AIndex: Integer): string;
begin
  Result := FCat[AIndex].Description;
end;

function TVpCategoryColorMap.IndexOfCategory(AName: String): Integer;
var
  i: Integer;
begin
  for i:=Low(FCat) to High(FCat) do
    if SameText(FCat[i].Description, AName) then begin
      Result := i;
      exit;
    end;
  Result := -1;
end;

function TVpCategoryColorMap.IndexOfFirstUnusedCategory: Integer;
var
  i: Integer;
begin
  for i := Low(FCat) to High(FCat) do
    if FCat[i].Description = Format(RSCategoryDesc, [i]) then begin
      Result := i;
      exit;
    end;
  Result := -1;
end;

function TVpCategoryColorMap.GetColor(AIndex: Integer): TColor;
begin
  if (AIndex >= Low(FCat)) and (AIndex <= High(FCat)) then
    Result := FCat[AIndex].Color
  else
    Result := clBlack;
end;

function TVpCategoryColorMap.GetName(AIndex: Integer): string;
begin
  if (AIndex >= Low(FCat)) and (AIndex <= High(FCat)) then
    Result := FCat[AIndex].Description
  else
    Result := '';
end;

procedure TVpCategoryColorMap.SetCat(AIndex: Integer; AValue: TVpCategoryInfo);
begin
  FCat[AIndex] := AValue;
end;

procedure TVpCategoryColorMap.SetCategoryName(AIndex: Integer; AName: String);
begin
  if (AIndex >= Low(FCat)) and (AIndex <= High(FCat)) then
    FCat[AIndex].Description := AName;
end;

(*****************************************************************************)
{ TVpCategoryInfo }

constructor TVpCategoryInfo.Create(AOwner: TComponent);
begin
  inherited Create;
  FOwner := AOwner;
  FBitmap := TBitmap.Create;
  FBackgroundColor := clWindow;
  FImageIndex := -1;
end;

destructor TVpCategoryInfo.Destroy;
begin
  FBitmap.Free;
  inherited Destroy;
end;

procedure TVpCategoryInfo.SetBackgroundColor(const v: TColor);
begin
  if v <> FBackgroundColor then
    FBackgroundColor := v;
end;

procedure TVpCategoryInfo.SetBitmap(v: TBitmap);
begin
  FBitmap.Assign(v);
end;

procedure TVpCategoryInfo.SetColor(Value: TColor);
begin
  if Value <> FColor then
    FColor := Value;
end;

procedure TVpCategoryInfo.SetDescription(Value: string);
begin
  if Value <> FDescription then
    FDescription := Value;
end;

procedure TVpCategoryInfo.SetImageIndex(Value: TImageIndex);
begin
  if Value <> FImageIndex then
    FImageIndex := Value;
end;


{ TVpTimeRange }
(*****************************************************************************)
constructor TVpTimeRange.Create(aOwner: TObject);
begin
  inherited Create;
  FOwner := aOwner;
end;

destructor TVpTimeRange.Destroy;
begin
  inherited;
end;

procedure TVpTimeRange.SetRangeBegin(const Value: TVpHours);
begin
  { if the start time is being set to greater than the end, then force the }
  { end to be one hour later than the start }
  if FRangeEnd < Value then
    FRangeEnd := TVpHours(Ord(Value) + 1);

  FRangeBegin := Value;
  SetStartTime((Ord(Value) * 60) / MinutesInDay);
end;

procedure TVpTimeRange.SetRangeEnd(const Value: TVpHours);
begin
  { if the end time is being set to less than the start, then force the }
  { start to be one hour earlier than the end }
  if FRangeBegin > Value then
    FRangeBegin := TVpHours(Ord(Value) - 1);
  FRangeEnd := Value;
  SetEndTime((Ord(Value) * 60) / MinutesInDay);
end;

procedure TVpTimeRange.SetEndTime(const Value: TDateTime);
begin
  if Value < StartTime then
    StartTime := Value - (30 / MinutesInDay);
  FEndTime := Value;
  if FOwner is TVpTimeSlotColor then
    (FOwner as TVpTimeSlotColor).Changed;
end;

procedure TVpTimeRange.SetStartTime(const Value: TDateTime);
begin
  if Value > EndTime then
    EndTime := Value + (30 / MinutesInDay);
  FStartTime := Value;
  if FOwner is TVpTimeSlotColor then
    (FOwner as TVpTimeSlotColor).Changed;
end;


(*****************************************************************************)
{ TVpTimeSlotColor }

constructor TVpTimeSlotColor.Create(AOwner: TVpCustomControl);
begin
  inherited Create;
  FOwner := AOwner;
  FActiveRange := TVpTimeRange.Create(Self);
  FInactive := OFF_COLOR;     // $0080FFFF;
  FHoliday := HOLIDAY_COLOR;  // $00FF80FF;
  FWeekend := WEEKEND_COLOR;  // $00FFFF80;
  FActive := clWhite;
  FWeekday := WEEKDAY_COLOR;  // clWhite;
end;

destructor TVpTimeSlotColor.Destroy;
begin
  FActiveRange.Free;
  inherited;
end;

procedure TVpTimeSlotColor.Changed;
begin
  FOwner.Invalidate;
end;

procedure TVpTimeSlotColor.SetActive(const Value: TColor);
begin
  if FActive <> Value then begin
    FActive := Value;
    Changed;
  end;
end;

procedure TVpTimeSlotColor.SetHoliday(const Value: TColor);
begin
  if FHoliday <> Value then begin
    FHoliday := Value;
    Changed;
  end;
end;

procedure TVpTimeSlotColor.SetInactive(const Value: TColor);
begin
  if FInactive <> Value then begin
    FInactive := Value;
    Changed;
  end;
end;

procedure TVpTimeSlotColor.SetWeekday(const Value: TColor);
begin
  if FWeekday <> Value then begin
    FWeekday := Value;
    Changed;
  end;
end;

procedure TVpTimeSlotColor.SetWeekend(const Value: TColor);
begin
  if FWeekend <> Value then begin
    FWeekend := Value;
    Changed;
  end;
end;


{ TVpHintWindow }

function TVpHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: String;
  AData: pointer): TRect;
begin
  Result := inherited CalcHintRect(MAX_HINT_WIDTH, AHint, AData);
end;


{ TVpMenuItem }

procedure TVpMenuItem.SetKind(AValue: TVpMenuItemKind);
begin
  FKind := AValue;
  Caption := VpMenuCaptions[FKind];
end;

procedure TVpMenuItem.Translate;

  procedure _Translate(AItem: TMenuItem);
  var
    i: Integer;
  begin
    if (AItem is TVpMenuItem) then
      AItem.Caption := VpMenuCaptions[TVpMenuItem(AItem).Kind];
    if AItem.Count > 0then
      for i := 0 to AItem.Count-1 do
        _Translate(AItem.Items[i]);
  end;

begin
  _Translate(self);
end;

end.