{----------------------------------------------------------------------------- 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/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: JvTFManager.PAS, released on 2003-08-01. The Initial Developer of the Original Code is Unlimited Intelligence Limited. Portions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited. All Rights Reserved. Contributor(s): Mike Kolter (original code) You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.delphi-jedi.org Known Issues: -----------------------------------------------------------------------------} // $Id$ unit JvTFManager; {$mode objfpc}{$H+} interface uses LCLIntf, LCLType, Classes, SysUtils, Controls, Graphics, ImgList, ExtCtrls, Printers, Forms, //JvComponentBase, JvComponent, JvTypes, JvTFUtils; const CN_REQUESTREFRESH = $BD01; type // Redeclaration of this type. It is used in JvTFMonths.TJvTFDrawDWTitleEvent. // If not redeclared here, Delphi complains of 'unknown type' because it // will not automatically bring in 'JvTFUtils' into the uses clause when // a TJvTFDrawDWTitleEvent prototype is created. TTFDayOfWeek = JvTFUtils.TTFDayOfWeek; EJvTFScheduleManagerError = class(Exception); TJvTFTimeRange = record StartTime: TTime; EndTime: TTime; end; TJvTFServNotifyCode = (sncDestroyAppt, sncDestroySchedule, sncLoadAppt, sncSchedLoadAppt, sncSchedUnloadAppt, sncPostAppt, sncDeleteAppt, sncRequestSchedule, sncReleaseSchedule, sncConnectComponent, sncDisconnectComponent, sncConnectControl, sncDisconnectControl, sncConnectAppt, sncDisconnectAppt, sncRefresh); TJvTFScheduleManager = class; {$M+} TJvTFSched = class; {$M-} TJvTFAppt = class; TJvTFComponent = class; TJvTFControl = class; TJvTFPrinter = class; TJvTFHint = class; // TJvTFNavigator = class; TJvTFSchedClass = class of TJvTFSched; TJvTFApptClass = class of TJvTFAppt; TJvTFHintClass = class of TJvTFHint; TCNRequestRefresh = record Msg: Cardinal; Schedule: TJvTFSched; Unused: Longint; Result: Longint; end; TJvTFDateList = class private FOnChange: TNotifyEvent; protected FList: TStringList; function GetDate(Index: Integer): TDate; procedure Change; virtual; public constructor Create; destructor Destroy; override; function Add(ADate: TDate): Integer; procedure Delete(Index: Integer); procedure Clear; function Count: Integer; function IndexOf(ADate: TDate): Integer; property Dates[Index: Integer]: TDate read GetDate; default; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TJvTFNavEvent = procedure(Sender: TObject; aControl: TJvTFControl; SchedNames: TStringList; Dates: TJvTFDateList) of object; TJvTFControlEvent = procedure(Sender: TObject; aControl: TJvTFControl) of object; TJvTFSchedEvent = procedure(Sender: TObject; Schedule: TJvTFSched) of object; TJvTFApptEvent = procedure(Sender: TObject; Appt: TJvTFAppt) of object; TJvTFVarApptEvent = procedure(Sender: TObject; var Appt: TJvTFAppt) of object; TJvTFFlushEvent = procedure(Sender, FlushObj: TObject; var FlushIt: Boolean) of object; // implicit post fix TJvTFPostApptQueryEvent = procedure(Sender: TObject; Appt: TJvTFAppt; var CanPost: Boolean) of object; TJvTFCustomImageMap = class(TPersistent) private FMap: TStringList; function GetImage(MapIndex: Integer): Integer; procedure SetImage(MapIndex: Integer; Value: Integer); function GetImageName(MapIndex: Integer): string; protected FAppt: TJvTFAppt; procedure Change; public constructor Create(anAppt: TJvTFAppt); destructor Destroy; override; property Images[MapIndex: Integer]: Integer read GetImage write SetImage; default; property ImageNames[MapIndex: Integer]: string read GetImageName; function Count: Integer; procedure Add(const ImageName: string; ImageIndex: Integer); procedure Delete(MapIndex: Integer); procedure Move(SrcMapIndex, DestMapIndex: Integer); function FindMapIndex(const ImageName: string): Integer; function FindImageIndex(const ImageName: string): Integer; procedure Clear; procedure Assign(Source: TPersistent); override; end; TJvTFStatePic = (spAlarmEnabled, spAlarmDisabled, spShared, spRecurring, spModified); TJvTFStateImageMap = class(TPersistent) private FPics: array[Low(TJvTFStatePic)..High(TJvTFStatePic)] of Integer; procedure SetImage(StatePicID: TJvTFStatePic; Value: Integer); function GetImage(StatePicID: TJvTFStatePic): Integer; function GetAlarmDisabled: Integer; function GetAlarmEnabled: Integer; function GetModified: Integer; function GetRecurring: Integer; function GetShared: Integer; procedure SetAlarmDisabled(const Value: Integer); procedure SetAlarmEnabled(const Value: Integer); procedure SetModified(const Value: Integer); procedure SetRecurring(const Value: Integer); procedure SetShared(const Value: Integer); protected FScheduleManager: TJvTFScheduleManager; FUpdating: Boolean; procedure Change; public constructor Create(Serv: TJvTFScheduleManager); procedure BeginUpdate; procedure EndUpdate; procedure Clear; procedure Assign(Source: TPersistent); override; property Pics[Index: TJvTFStatePic]: Integer read GetImage write SetImage; published property AlarmEnabled: Integer {index spAlarmEnabled} read GetAlarmEnabled write SetAlarmEnabled; property AlarmDisabled: Integer {index spAlarmDisabled} read GetAlarmDisabled write SetAlarmDisabled; property Shared: Integer {index spShared} read GetShared write SetShared; property Recurring: Integer {index spRecurring} read GetRecurring write SetRecurring; //read GetImage write SetImage; property Modified: Integer {index spModified} read GetModified write SetModified; end; TDynTimeRangeArray = array of TJvTFTimeRange; TDynApptArray = array of TJvTFAppt; TDynSchedArray = array of TJvTFSched; TJvTFAppt = class(TPersistent) private FStartDate: TDate; FEndDate: TDate; FStartTime: TTime; FEndTime: TTime; FDescription: string; FAlarmEnabled: Boolean; FAlarmAdvance: Integer; FImageMap: TJvTFCustomImageMap; FData: Integer; FPersistent: Boolean; FColor: TColor; FBarColor: TColor; FRefreshed: Boolean; FGlyph: TPicture; FDestroying: Boolean; function GetDescription: string; procedure SetDescription(Value: string); procedure SetAlarmEnabled(Value: Boolean); procedure SetAlarmAdvance(Value: Integer); procedure SetColor(Value: TColor); procedure SetBarColor(Value: TColor); function GetStartDateTime: TDateTime; function GetEndDateTime: TDateTime; function GetStartDate: TDate; function GetEndDate: TDate; function GetStartTime: TTime; function GetEndTime: TTime; procedure SetRefreshed(Value: Boolean); procedure SetGlyph(const Value: TPicture); protected FID: string; FModified: Boolean; FScheduleManager: TJvTFScheduleManager; FConnections: TStringList; FSchedules: TStringList; FDeleting: Boolean; // implicit post fix FUpdating: Boolean; procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifySchedule(Sched: TJvTFSched; Sender: TObject; Code: TJvTFServNotifyCode); function GetConnection(Index: Integer): TJvTFSched; function GetSchedule(Index: Integer): string; procedure CheckConnections; procedure Connect(Schedule: TJvTFSched); procedure Disconnect(Schedule: TJvTFSched); procedure Change; procedure InternalClearSchedules; procedure DeleteApptNotification; // implicit post fix procedure PostApptNotification; procedure RefreshNotification; property Destroying: Boolean read FDestroying; public constructor Create(Serv: TJvTFScheduleManager; const ApptID: string); virtual; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure SetStartEnd(NewStartDate: TDate; NewStartTime: TTime; NewEndDate: TDate; NewEndTime: TTime); procedure SetModified; function Modified: Boolean; dynamic; property ScheduleManager: TJvTFScheduleManager read FScheduleManager; function ConnectionCount: Integer; property Connections[Index: Integer]: TJvTFSched read GetConnection; function ScheduleCount: Integer; property Schedules[Index: Integer]: string read GetSchedule; procedure AddSchedule(const SchedName: string); procedure RemoveSchedule(const SchedName: string); procedure AssignSchedules(List: TStrings); procedure ClearSchedules; function IndexOfSchedule(const SchedName: string): Integer; function Shared: Boolean; procedure Post; procedure Refresh; procedure Delete; // implicit post fix procedure BeginUpdate; procedure EndUpdate; property Updating: Boolean read FUpdating; property ImageMap: TJvTFCustomImageMap read FImageMap write FImageMap; procedure RefreshControls; property Refreshed: Boolean read FRefreshed write SetRefreshed; published property ID: string read FID; property StartDate: TDate read GetStartDate; property EndDate: TDate read GetEndDate; property StartTime: TTime read GetStartTime; property EndTime: TTime read GetEndTime; property StartDateTime: TDateTime read GetStartDateTime; property EndDateTime: TDateTime read GetEndDateTime; property Description: string read GetDescription write SetDescription; property AlarmEnabled: Boolean read FAlarmEnabled write SetAlarmEnabled; property AlarmAdvance: Integer read FAlarmAdvance write SetAlarmAdvance; property Data: Integer read FData write FData; property Persistent: Boolean read FPersistent write FPersistent; property Color: TColor read FColor write SetColor default clDefault; property BarColor: TColor read FBarColor write SetBarColor default clDefault; property Glyph: TPicture read FGlyph write SetGlyph; end; {$M+} TJvTFSched = class(TObject) private FAppts: TStringList; FConControls: TStringList; FConComponents: TStringList; FDestroying: Boolean; FData: Integer; FPersistent: Boolean; FSchedDisplayName: string; procedure SetSchedDisplayName(const Value: string); function GetAppt(Index: Integer): TJvTFAppt; protected FSchedName: string; FSchedDate: TDate; FScheduleManager: TJvTFScheduleManager; FCached: Boolean; FCachedTime: Int64; //DWORD; procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifyAppt(Appt: TJvTFAppt; Sender: TObject; Code: TJvTFServNotifyCode); function GetConControl(Index: Integer): TJvTFControl; function GetConComponent(Index: Integer): TJvTFComponent; procedure ConnectAppt(Appt: TJvTFAppt); procedure DisconnectAppt(Appt: TJvTFAppt); procedure ConnectionsOnChange(Sender: TObject); procedure CheckConnections; function GetFreeUsedTime(FreeTime: Boolean): TDynTimeRangeArray; dynamic; public constructor Create(Serv: TJvTFScheduleManager; const AName: string; ADate: TDate); virtual; destructor Destroy; override; function ApptCount: Integer; function ApptByID(const ID: string): TJvTFAppt; property Appts[Index: Integer]: TJvTFAppt read GetAppt; function ConControlCount: Integer; property ConControls[Index: Integer]: TJvTFControl read GetConControl; function ConComponentCount: Integer; property ConComponents[Index: Integer]: TJvTFComponent read GetConComponent; procedure AddAppt(Appt: TJvTFAppt); procedure RemoveAppt(Appt: TJvTFAppt); //procedure RefreshAppts; procedure Refresh; procedure PostAppts; // Conflict and free time methods function GetFreeTime: TDynTimeRangeArray; dynamic; function GetUsedTime: TDynTimeRangeArray; dynamic; function TimeIsFree(TimeRange: TJvTFTimeRange): Boolean; overload; dynamic; function TimeIsFree(RangeStart, RangeEnd: TTime): Boolean; overload; dynamic; // The ApptHasConflicts(anAppt: TJvTFAppt) method declared here checks // ONLY THIS SCHEDULE!! function ApptHasConflicts(anAppt: TJvTFAppt): Boolean; dynamic; function EnumConflicts(TimeRange: TJvTFTimeRange): TDynApptArray; overload; dynamic; function EnumConflicts(RangeStart, RangeEnd: TTime): TDynApptArray; overload; dynamic; // The following EnumConflicts(anAppt: TJvTFAppt) checks // ONLY THIS SCHEDULE!! function EnumConflicts(anAppt: TJvTFAppt): TDynApptArray; overload; dynamic; property Cached: Boolean read FCached; property CachedTime: Int64 {DWORD} read FCachedTime; property Destroying: Boolean read FDestroying; function GetFirstAppt: TJvTFAppt; function GetLastAppt: TJvTFAppt; published property SchedDisplayName: string read FSchedDisplayName write SetSchedDisplayName; property SchedName: string read FSchedName; property SchedDate: TDate read FSchedDate; property ScheduleManager: TJvTFScheduleManager read FScheduleManager; property Data: Integer read FData write FData; property Persistent: Boolean read FPersistent write FPersistent; end; {$M-} TJvTFScheduleManagerCacheType = (ctNone, ctTimed, ctBuffer); TJvTFScheduleManagerCache = class(TPersistent) private FCacheType: TJvTFScheduleManagerCacheType; FTimedDelay: Integer; FBufferCount: Integer; FTimer: TTimer; procedure SetCacheType(Value: TJvTFScheduleManagerCacheType); procedure SetTimedDelay(Value: Integer); procedure SetBufferCount(Value: Integer); protected FScheduleManager: TJvTFScheduleManager; procedure FlushManager; virtual; procedure TimerOnTimer(Sender: TObject); virtual; public constructor Create(SchedManager: TJvTFScheduleManager); destructor Destroy; override; procedure Assign(Source: TPersistent); override; published property CacheType: TJvTFScheduleManagerCacheType read FCacheType write SetCacheType default ctTimed; property TimedDelay: Integer read FTimedDelay write SetTimedDelay default 30000; property BufferCount: Integer read FBufferCount write SetBufferCount default 7; end; TJvTFSchedLoadMode = (slmOnDemand, slmBatch); TJvTFLoadBatchEvent = procedure(Sender: TObject; BatchName: string; BatchStartDate, BatchEndDate: TDate) of object; TJvTFGetApptDisplayTextEvent = procedure(Sender: TObject; Source: TComponent; Appt: TJvTFAppt; var DisplayText: string) of object; TJvTFApptDescEvent = procedure(Sender: TObject; Appt: TJvTFAppt; var Description: string) of object; TJvTFScheduleManager = class(TComponent) private FAlwaysPost: Boolean; FAppts: TStringList; FSchedules: TStringList; FConControls: TStringList; FConComponents: TStringList; FOnNeedAppts: TJvTFSchedEvent; FOnRefreshAppt: TJvTFApptEvent; FOnRefreshSched: TJvTFSchedEvent; FOnRefreshAll: TNotifyEvent; FOnDeleteAppt: TJvTFApptEvent; FOnPostAppt: TJvTFApptEvent; FOnFlush: TJvTFFlushEvent; FOnCreateAppt: TJvTFApptEvent; FOnCreateSchedule: TJvTFSchedEvent; FOnDestroyAppt: TJvTFApptEvent; FOnDestroySchedule: TJvTFSchedEvent; FOnGetApptDisplayText: TJvTFGetApptDisplayTextEvent; FOnGetApptDescription: TJvTFApptDescEvent; FOnSetApptDescription: TJvTFApptDescEvent; FSchedLoadMode: TJvTFSchedLoadMode; FOnLoadBatch: TJvTFLoadBatchEvent; FOnBatchesProcessed: TNotifyEvent; FRefreshAutoReconcile: Boolean; FStateImages: TCustomImageList; FCustomImages: TCustomImageList; FStateImageMap: TJvTFStateImageMap; FCache: TJvTFScheduleManagerCache; // implicit post fix FOnPostApptQuery: TJvTFPostApptQueryEvent; function GetAppt(Index: Integer): TJvTFAppt; function GetSchedule(Index: Integer): TJvTFSched; function GetConControl(Index: Integer): TJvTFControl; function GetConComponent(Index: Integer): TJvTFComponent; procedure SetStateImages(Value: TCustomImageList); procedure SetCustomImages(Value: TCustomImageList); procedure SetCache(Value: TJvTFScheduleManagerCache); procedure SetTFSchedLoadMode(Value: TJvTFSchedLoadMode); procedure SetRefreshAutoReconcile(Value: Boolean); protected FLoadingAppts: Boolean; FRefreshing: Boolean; FImageChangeLink: TChangeLink; FFlushing: Boolean; FDestroying: Boolean; FSchedBatch: TStringList; FApptBeingDestroyed: TJvTFAppt; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure ConnectControl(ApptCtrl: TJvTFControl); procedure DisconnectControl(ApptCtrl: TJvTFControl); procedure ConnectComponent(Comp: TJvTFComponent); procedure DisconnectComponent(Comp: TJvTFComponent); procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual; procedure NotifyAppt(Appt: TJvTFAppt; Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifySchedule(Sched: TJvTFSched; Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifyApptCtrl(ApptCtrl: TJvTFControl; Sender: TObject; Code: TJvTFServNotifyCode); procedure NotifyComp(Comp: TJvTFComponent; Sender: TObject; Code: TJvTFServNotifyCode); procedure RetrieveSchedule(const SchedName: string; SchedDate: TDate; out Schedule: TJvTFSched; out LoadedNow: Boolean); procedure NeedAppts(Schedule: TJvTFSched); virtual; procedure AddAppt(Appt: TJvTFAppt); procedure RemoveAppt(Appt: TJvTFAppt); procedure RemoveSchedule(Sched: TJvTFSched); //procedure RefreshAppt(Appt: TJvTFAppt); procedure DeleteAppt(Appt: TJvTFAppt); procedure PostAppt(Appt: TJvTFAppt); // implicit post fix function QueryPostAppt(Appt: TJvTFAppt): Boolean; procedure AddToBatch(ASched: TJvTFSched); procedure LoadBatch(const BatchName: string; BatchStartDate, BatchEndDate: TDate); virtual; procedure RequestRefresh(ApptCtrl: TJvTFControl; Schedule: TJvTFSched); overload; dynamic; procedure RequestRefresh(Comp: TJvTFComponent; Schedule: TJvTFSched); overload; dynamic; procedure ImageListChange(Sender: TObject); procedure FlushAppts; function FlushObject(FlushObj: TObject): Boolean; procedure DoCreateApptEvent(anAppt: TJvTFAppt); dynamic; procedure DoCreateScheduleEvent(aSchedule: TJvTFSched); dynamic; procedure DoDestroyApptEvent(anAppt: TJvTFAppt); dynamic; procedure DoDestroyScheduleEvent(aSchedule: TJvTFSched); dynamic; procedure SetApptDescription(Appt: TJvTFAppt; var Value: string); virtual; procedure GetApptDescription(Appt: TJvTFAppt; var Value: string); virtual; public class function GetScheduleID(const SchedName: string; SchedDate: TDate): string; class function GenerateApptID: string; virtual; function GetSchedClass: TJvTFSchedClass; dynamic; function GetApptClass: TJvTFApptClass; dynamic; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ApptCount: Integer; property Appts[Index: Integer]: TJvTFAppt read GetAppt; function FindAppt(const ID: string): TJvTFAppt; function ScheduleCount: Integer; property Schedules[Index: Integer]: TJvTFSched read GetSchedule; function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; function ConControlCount: Integer; property ConControls[Index: Integer]: TJvTFControl read GetConControl; function ConComponentCount: Integer; property ConComponents[Index: Integer]: TJvTFComponent read GetConComponent; function RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate): TJvTFSched; overload; function RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; overload; function RequestSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate): TJvTFSched; overload; function RequestSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; overload; procedure ReleaseSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate); overload; procedure ReleaseSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate); overload; procedure ProcessBatches; procedure RequestAppt(const ID: string; var Appt: TJvTFAppt; var New: Boolean); property LoadingAppts: Boolean read FLoadingAppts; property Refreshing: Boolean read FRefreshing; procedure dbPostAppt(Appt: TJvTFAppt); procedure dbDeleteAppt(Appt: TJvTFAppt); procedure dbDeleteAllAppt; procedure dbRefreshAppt(Appt: TJvTFAppt); procedure dbRefreshSched(Sched: TJvTFSched); procedure dbRefreshAll; procedure dbRefreshOrphans; function dbNewAppt(const ID: string): TJvTFAppt; procedure PostAppts; procedure RefreshAppts; procedure ReconcileRefresh(Scope: TObject); procedure RefreshConnections(Trigger: TObject); virtual; property Flushing: Boolean read FFlushing; procedure Flush(All: Boolean = False); virtual; function GetApptDisplayText(AComponent: TComponent; Appt: TJvTFAppt): string; virtual; published property AlwaysPost: Boolean read FAlwaysPost write FAlwaysPost default False; property OnNeedAppts: TJvTFSchedEvent read FOnNeedAppts write FOnNeedAppts; property OnRefreshAppt: TJvTFApptEvent read FOnRefreshAppt write FOnRefreshAppt; property OnRefreshSched: TJvTFSchedEvent read FOnRefreshSched write FOnRefreshSched; property OnRefreshAll: TNotifyEvent read FOnRefreshAll write FOnRefreshAll; property OnPostAppt: TJvTFApptEvent read FOnPostAppt write FOnPostAppt; property OnDeleteAppt: TJvTFApptEvent read FOnDeleteAppt write FOnDeleteAppt; property StateImages: TCustomImageList read FStateImages write SetStateImages; property CustomImages: TCustomImageList read FCustomImages write SetCustomImages; property StateImageMap: TJvTFStateImageMap read FStateImageMap write FStateImageMap; property Cache: TJvTFScheduleManagerCache read FCache write SetCache; // implicit post fix property OnPostApptQuery: TJvTFPostApptQueryEvent read FOnPostApptQuery write FOnPostApptQuery; property OnFlush: TJvTFFlushEvent read FOnFlush write FOnFlush; property OnCreateAppt: TJvTFApptEvent read FOnCreateAppt write FOnCreateAppt; property OnDestroyAppt: TJvTFApptEvent read FOnDestroyAppt write FOnDestroyAppt; property OnCreateSchedule: TJvTFSchedEvent read FOnCreateSchedule write FOnCreateSchedule; property OnDestroySchedule: TJvTFSchedEvent read FOnDestroySchedule write FOnDestroySchedule; property OnLoadBatch: TJvTFLoadBatchEvent read FOnLoadBatch write FOnLoadBatch; property OnBatchesProcessed: TNotifyEvent read FOnBatchesProcessed write FOnBatchesProcessed; property OnGetApptDisplayText: TJvTFGetApptDisplayTextEvent read FOnGetApptDisplayText write FOnGetApptDisplayText; property OnGetApptDescription: TJvTFApptDescEvent read FOnGetApptDescription write FOnGetApptDescription; property OnSetApptDescription: TJvTFApptDescEvent read FOnSetApptDescription write FOnSetApptDescription; property SchedLoadMode: TJvTFSchedLoadMode read FSchedLoadMode write SetTFSchedLoadMode default slmOnDemand; property RefreshAutoReconcile: Boolean read FRefreshAutoReconcile write SetRefreshAutoReconcile default False; end; TJvTFHintProps = class(TPersistent) private FHintColor: TColor; FHintHidePause: Integer; FHintPause: Integer; procedure SetHintColor(Value: TColor); procedure SetHintHidePause(Value: Integer); procedure SetHintPause(Value: Integer); protected FControl: TJvTFControl; procedure Change; virtual; public constructor Create(AOwner: TJvTFControl); procedure Assign(Source: TPersistent); override; published property HintColor: TColor read FHintColor write SetHintColor default clDefault; property HintHidePause: Integer read FHintHidePause write SetHintHidePause default -1; property HintPause: Integer read FHintPause write SetHintPause default -1; end; TJvTFHintType = (shtAppt, shtStartEnd, shtCell, shtObj); TJvTFShowHintEvent = procedure(Sender: TObject; HintType: TJvTFHintType; Ref: TObject; var HintRect: TRect; var HintText: string) of object; // NOTE: // The Pause property has the same meaning as the Application.HintPause // property. The ShortPause property has the same meaning as the // Application.HintHidePause property. TJvTFHint = class(THintWindow) private FTimer: TTimer; FPause: Integer; FShortPause: Integer; FOnShowHint: TJvTFShowHintEvent; FRefProps: TJvTFHintProps; procedure SetPause(Value: Integer); procedure SetShortPause(Value: Integer); protected FApptCtrl: TJvTFControl; FOldAppt: TJvTFAppt; FOldObj: TObject; FShortTimer: Boolean; FHintRect: TRect; FHintText: string; FHintCell: TPoint; FHintType: TJvTFHintType; procedure TimerOnTimer(Sender: TObject); virtual; procedure PrepTimer(Short: Boolean); procedure SetHintText(StartDate, EndDate: TDate; StartTime, EndTime: TTime; const Desc: string; ShowDatesTimes, ShowDesc: Boolean); procedure DoHint(Sustained: Boolean); procedure CreateParams(var Params: TCreateParams); override; procedure PropertyCheck; dynamic; public constructor Create(anApptCtrl: TJvTFControl); reintroduce; destructor Destroy; override; procedure ActivateHint(Rect: TRect; const AHint: THintString); override; procedure ApptHint(Appt: TJvTFAppt; X, Y: Integer; ShowDatesTimes, ShowDesc, FormattedDesc: Boolean; const ExtraDesc: string = ''); virtual; procedure StartEndHint(StartDate, EndDate: TDate; StartTime, EndTime: TTime; X, Y: Integer; ShowDates: Boolean); procedure CellHint(Row, Col: Integer; const HintText: string; CellRect: TRect); procedure MultiLineObjHint(Obj: TObject; X, Y: Integer; Hints: TStrings); procedure ReleaseHandle; virtual; // See above note on Pause and ShortPause properties property Pause: Integer read FPause write SetPause default 3000; property ShortPause: Integer read FShortPause write SetShortPause default 1500; property OnShowHint: TJvTFShowHintEvent read FOnShowHint write FOnShowHint; property HintType: TJvTFHintType read FHintType; property RefProps: TJvTFHintProps read FRefProps write FRefProps; end; TJvTFDragInfo = class(TObject) private FApptCtrl: TJvTFControl; FSchedule: TJvTFSched; FAppt: TJvTFAppt; FShift: TShiftState; public property ApptCtrl: TJvTFControl read FApptCtrl write FApptCtrl; property Schedule: TJvTFSched read FSchedule write FSchedule; property Appt: TJvTFAppt read FAppt write FAppt; property Shift: TShiftState read FShift write FShift; end; TJvTFComponent = class(TComponent) //TJvComponent) private FScheduleManager: TJvTFScheduleManager; FSchedules: TStringList; procedure SetManager(Value: TJvTFScheduleManager); function GetSchedule(Index: Integer): TJvTFSched; protected FDateFormat: string; FTimeFormat: string; procedure UpdateDesigner; procedure SetDateFormat(const Value: string); virtual; procedure SetTimeFormat(const Value: string); virtual; procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual; procedure ReqSchedNotification(Schedule: TJvTFSched); virtual; procedure RelSchedNotification(Schedule: TJvTFSched); virtual; procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); procedure RefreshComponent; dynamic; property DateFormat: string read FDateFormat write SetDateFormat; property TimeFormat: string read FTimeFormat write SetTimeFormat; procedure DestroyApptNotification(anAppt: TJvTFAppt); virtual; procedure DestroySchedNotification(ASched: TJvTFSched); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ScheduleCount: Integer; property Schedules[Index: Integer]: TJvTFSched read GetSchedule; function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; function RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); virtual; procedure ReleaseSchedules; procedure ProcessBatches; published property ScheduleManager: TJvTFScheduleManager read FScheduleManager write SetManager; end; TJvTFControl = class(TJvCustomControl) private FScheduleManager: TJvTFScheduleManager; FSchedules: TStringList; // FNavigator: TJvTFNavigator; // FOnNavigate: TJvTFNavEvent; procedure SetManager(Value: TJvTFScheduleManager); function GetSchedule(Index: Integer): TJvTFSched; // procedure SetNavigator(Value: TJvTFNavigator); protected FDateFormat: string; FTimeFormat: string; FDragInfo: TJvTFDragInfo; FShift: TShiftState; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure SetDateFormat(const Value: string); virtual; procedure SetTimeFormat(const Value: string); virtual; procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual; procedure ReqSchedNotification(Schedule: TJvTFSched); virtual; procedure RelSchedNotification(Schedule: TJvTFSched); virtual; procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); procedure CNRequestRefresh(var Msg: TCNRequestRefresh); message CN_REQUESTREFRESH; procedure RefreshControl; dynamic; property DateFormat: string read FDateFormat write SetDateFormat; property TimeFormat: string read FTimeFormat write SetTimeFormat; procedure DestroyApptNotification(anAppt: TJvTFAppt); virtual; procedure DestroySchedNotification(ASched: TJvTFSched); virtual; procedure DoStartDrag(var DragObject: TDragObject); override; procedure DoEndDrag(Target: TObject; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure Navigate(aControl: TJvTFControl; SchedNames: TStringList; Dates: TJvTFDateList); virtual; // property Navigator: TJvTFNavigator read FNavigator write SetNavigator; // property OnNavigate: TJvTFNavEvent read FOnNavigate write FOnNavigate; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ScheduleCount: Integer; property Schedules[Index: Integer]: TJvTFSched read GetSchedule; function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; function RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); virtual; procedure ReleaseSchedules; property DragInfo: TJvTFDragInfo read FDragInfo; procedure ProcessBatches; published property ScheduleManager: TJvTFScheduleManager read FScheduleManager write SetManager; end; EJvTFPrinterError = class(Exception); TJvTFMargins = TRect; TJvTFPrinterMeasure = (pmPixels, pmInches, pmMM); TJvTFPrinterState = (spsNoDoc, spsCreating, spsAssembling, spsFinished); TJvTFPrinterDrawEvent = procedure(Sender: TObject; aCanvas: TCanvas; ARect: TRect; PageNum: Integer) of object; TJvTFProgressEvent = procedure(Sender: TObject; Current, Total: Integer) of object; TJvTFPrinterPageLayout = class(TPersistent) private FFooterHeight: Integer; FHeaderHeight: Integer; FMargins: TJvTFMargins; FPrinter: TJvTFPrinter; procedure SetFooterHeight(Value: Integer); procedure SetHeaderHeight(Value: Integer); function GetMargin(Index: Integer): Integer; procedure SetMargin(Index: Integer; Value: Integer); protected procedure Change; virtual; property Printer: TJvTFPrinter read FPrinter; procedure SetPropertyCheck; public constructor Create(aPrinter: TJvTFPrinter); virtual; procedure Assign(Source: TPersistent); override; published property FooterHeight: Integer read FFooterHeight write SetFooterHeight; property HeaderHeight: Integer read FHeaderHeight write SetHeaderHeight; property MarginLeft: Integer index 1 read GetMargin write SetMargin; property MarginTop: Integer index 2 read GetMargin write SetMargin; property MarginRight: Integer index 3 read GetMargin write SetMargin; property MarginBottom: Integer index 4 read GetMargin write SetMargin; end; TJvTFPrinter = class(TJvTFComponent) private FPages: TStringList; FBodies: TStringList; FMarginOffsets: TJvTFMargins; // always in pixels FMeasure: TJvTFPrinterMeasure; FOnDrawBody: TJvTFPrinterDrawEvent; FOnDrawHeader: TJvTFPrinterDrawEvent; FOnDrawFooter: TJvTFPrinterDrawEvent; FOnPrintProgress: TJvTFProgressEvent; FOnAssembleProgress: TJvTFProgressEvent; FOnMarginError: TNotifyEvent; FTitle: string; FDirectPrint: Boolean; function GetPage(Index: Integer): TBitmap; //was: TMetafile; function GetBodyHeight: Integer; // always in pixels function GetBodyWidth: Integer; // always in pixels function GetBodyLeft: Integer; // always in pixels function GetBodyTop: Integer; // always in pixels function GetDocDateTime: TDateTime; procedure SetPageLayout(Value: TJvTFPrinterPageLayout); procedure SetDirectPrint(Value: Boolean); protected FPageLayout: TJvTFPrinterPageLayout; FState: TJvTFPrinterState; FDocDateTime: TDateTime; FPageCount: Integer; // NOTE: SEE GetPageCount !! FConvertingProps: Boolean; FAborted: Boolean; procedure SetMarginOffset(Index: Integer; Value: Integer); // always in pixels function GetMarginOffset(Index: Integer): Integer; // always in pixels function GetUnprintable: TJvTFMargins; // always in pixels procedure MarginError; dynamic; procedure InitializeMargins; property BodyHeight: Integer read GetBodyHeight; // always in pixels property BodyWidth: Integer read GetBodyWidth; // always in pixels property BodyLeft: Integer read GetBodyLeft; // always in pixels property BodyTop: Integer read GetBodyTop; // always in pixels procedure DrawBody(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual; procedure DrawHeader(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual; procedure DrawFooter(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual; procedure SetTitle(const Value: string); virtual; function GetPageCount: Integer; procedure SetMeasure(Value: TJvTFPrinterMeasure); virtual; procedure CreateLayout; virtual; procedure SetPropertyCheck; dynamic; procedure GetHeaderFooterRects(out HeaderRect, FooterRect: TRect); // document management methods procedure CreateDoc; dynamic; procedure NewPage; dynamic; procedure FinishDoc; dynamic; procedure NewDoc; dynamic; property DirectPrint: Boolean read FDirectPrint write SetDirectPrint default False; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property PageCount: Integer read GetPageCount; property Pages[Index: Integer]: TBitmap read GetPage; // was: TMetaFile function ConvertMeasure(Value: Integer; FromMeasure, ToMeasure: TJvTFPrinterMeasure; Horizontal: Boolean): Integer; function ScreenToPrinter(Value: Integer; Horizontal: Boolean): Integer; function PrinterToScreen(Value: Integer; Horizontal: Boolean): Integer; property State: TJvTFPrinterState read FState; procedure FreeDoc; dynamic; procedure Print; dynamic; procedure AbortPrint; property DocDateTime: TDateTime read GetDocDateTime; property ConvertingProps: Boolean read FConvertingProps; procedure SaveDocToFiles(BaseFileName: TFileName); property Aborted: Boolean read FAborted; published property PageLayout: TJvTFPrinterPageLayout read FPageLayout write SetPageLayout; property Measure: TJvTFPrinterMeasure read FMeasure write SetMeasure default pmInches; property OnDrawBody: TJvTFPrinterDrawEvent read FOnDrawBody write FOnDrawBody; property OnDrawHeader: TJvTFPrinterDrawEvent read FOnDrawHeader write FOnDrawHeader; property OnDrawFooter: TJvTFPrinterDrawEvent read FOnDrawFooter write FOnDrawFooter; property OnPrintProgress: TJvTFProgressEvent read FOnPrintProgress write FOnPrintProgress; property OnAssembleProgress: TJvTFProgressEvent read FOnAssembleProgress write FOnAssembleProgress; property OnMarginError: TNotifyEvent read FOnMarginError write FOnMarginError; property Title: string read FTitle write SetTitle; end; TJvTFUniversalPrinter = class(TJvTFPrinter) public procedure NewDoc; override; procedure CreateDoc; override; procedure NewPage; override; procedure FinishDoc; override; published property DirectPrint; end; TJvTFDWNameSource = (dwnsSysLong, dwnsSysShort, dwnsCustom); TJvTFDrawDWTitleEvent = procedure(Sender: TObject; aCanvas: TCanvas; ARect: TRect; DOW: TTFDayOfWeek; DWName: string) of object; TJvTFDWNames = class(TPersistent) private FSource: TJvTFDWNameSource; FDWN_Sunday: string; FDWN_Monday: string; FDWN_Tuesday: string; FDWN_Wednesday: string; FDWN_Thursday: string; FDWN_Friday: string; FDWN_Saturday: string; FOnChange: TNotifyEvent; procedure SetDWN(Index: Integer; const Value: string); function GetDWN(Index: Integer): string; procedure SetSource(Value: TJvTFDWNameSource); protected procedure Change; virtual; public constructor Create; procedure Assign(Source: TPersistent); override; function GetDWName(DWIndex: Integer): string; published property Source: TJvTFDWNameSource read FSource write SetSource default dwnsSysShort; property DWN_Sunday: string index 1 read GetDWN write SetDWN; property DWN_Monday: string index 2 read GetDWN write SetDWN; property DWN_Tuesday: string index 3 read GetDWN write SetDWN; property DWN_Wednesday: string index 4 read GetDWN write SetDWN; property DWN_Thursday: string index 5 read GetDWN write SetDWN; property DWN_Friday: string index 6 read GetDWN write SetDWN; property DWN_Saturday: string index 7 read GetDWN write SetDWN; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; // TJvTFNavigator = class(TComponent) // private // FBeforeNavigate: TJvTFNavEvent; // FAfterNavigate: TJvTFNavEvent; // FControls: TStringList; // function GetControl(Index: Integer): TJvTFControl; // protected // FNavigating: Boolean; // procedure RegisterControl(aControl: TJvTFControl); // procedure UnregisterControl(aControl: TJvTFControl); // public // constructor Create(AOwner: TComponent); override; // destructor Destroy; override; // // function ControlCount: Integer; // property Controls[Index: Integer]: TJvTFControl read GetControl; // // procedure Navigate(aControl: TJvTFControl; SchedNames: TStringList; // Dates: TJvTFDateList); virtual; // property Navigating: Boolean read FNavigating; // published // property BeforeNavigate: TJvTFNavEvent read FBeforeNavigate // write FBeforeNavigate; // property AfterNavigate: TJvTFNavEvent read FAfterNavigate // write FAfterNavigate; // end; implementation uses Dialogs, JvResources, JvJVCLUtils; //, JclSysUtils; function AdjustEndTime(ATime: TTime): TTime; begin Result := Frac(Frac(ATime) - Frac(EncodeTime(0, 0, 1, 0))); end; function CenterRect(Rect1, Rect2: TRect): TRect; var Rect1Width, Rect1Height, Rect2Width, Rect2Height: Integer; begin Rect1Width := Rect1.Right - Rect1.Left - 1; Rect1Height := Rect1.Bottom - Rect1.Top - 1; Rect2Width := Rect2.Right - Rect2.Left - 1; Rect2Height := Rect2.Bottom - Rect2.Top - 1; Result.Left := Rect1.Left + ((Rect1Width - Rect2Width) div 2) - 1; Result.Top := Rect1.Top + ((Rect1Height - Rect2Height) div 2) - 1; Result.Right := Result.Left + Rect2Width; Result.Bottom := Result.Top + Rect2Height; end; function MoveRect(ARect: TRect; NewLeft, NewTop: Integer): TRect; begin Result := ARect; OffsetRect(Result, NewLeft - ARect.Left, NewTop - ARect.Top); end; function StripCRLF(const S: string): string; var I: Integer; begin Result := ''; for I := 1 to Length(S) do if (S[I] <> #13) and (S[I] <> #10) then Result := Result + S[I]; end; //=== { TJvTFCustomImageMap } ================================================ constructor TJvTFCustomImageMap.Create(anAppt: TJvTFAppt); begin if not Assigned(anAppt) then raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateCustomImageMap); inherited Create; FAppt := anAppt; FMap := TStringList.Create; end; destructor TJvTFCustomImageMap.Destroy; begin FMap.Free; inherited Destroy; end; function TJvTFCustomImageMap.GetImage(MapIndex: Integer): Integer; begin Result := PtrInt(FMap.Objects[MapIndex]); end; procedure TJvTFCustomImageMap.SetImage(MapIndex, Value: Integer); begin FMap.Objects[MapIndex] := TObject(PtrInt(Value)); end; function TJvTFCustomImageMap.GetImageName(MapIndex: Integer): string; begin Result := FMap[MapIndex]; end; procedure TJvTFCustomImageMap.Change; begin if Assigned(FAppt.ScheduleManager) then begin FAppt.ScheduleManager.RefreshConnections(FAppt); // implicit post fix FAppt.Change; end; end; function TJvTFCustomImageMap.Count: Integer; begin Result := FMap.Count; end; procedure TJvTFCustomImageMap.Add(const ImageName: string; ImageIndex: Integer); begin if FMap.IndexOf(ImageName) = -1 then begin FMap.AddObject(ImageName, TObject(PtrInt(ImageIndex))); Change; end; end; procedure TJvTFCustomImageMap.Delete(MapIndex: Integer); begin FMap.Delete(MapIndex); Change; end; procedure TJvTFCustomImageMap.Move(SrcMapIndex, DestMapIndex: Integer); begin FMap.Move(SrcMapIndex, DestMapIndex); end; function TJvTFCustomImageMap.FindMapIndex(const ImageName: string): Integer; begin Result := FMap.IndexOf(ImageName); end; function TJvTFCustomImageMap.FindImageIndex(const ImageName: string): Integer; begin Result := FindMapIndex(ImageName); if Result > -1 then Result := GetImage(Result); end; procedure TJvTFCustomImageMap.Clear; begin while FMap.Count > 0 do FMap.Delete(0); Change; end; procedure TJvTFCustomImageMap.Assign(Source: TPersistent); var I: Integer; begin if Source is TJvTFCustomImageMap then begin while FMap.Count > 0 do FMap.Delete(0); for I := 0 to TJvTFCustomImageMap(Source).Count - 1 do Add(TJvTFCustomImageMap(Source).ImageNames[I], TJvTFCustomImageMap(Source).Images[I]); Change; end else inherited Assign(Source); end; //=== { TJvTFStateImageMap } ================================================= constructor TJvTFStateImageMap.Create(Serv: TJvTFScheduleManager); var I: TJvTFStatePic; begin inherited Create; for I := Low(TJvTFStatePic) to High(TJvTFStatePic) do FPics[I] := -1; FUpdating := False; end; procedure TJvTFStateImageMap.SetImage(StatePicID: TJvTFStatePic; Value: Integer); begin if Value < -1 then Value := -1; if FPics[StatePicID] <> Value then begin FPics[StatePicID] := Value; Change; end; end; function TJvTFStateImageMap.GetImage(StatePicID: TJvTFStatePic): Integer; begin Result := FPics[StatePicID]; end; function TJvTFStateImageMap.GetAlarmDisabled: Integer; begin Result := GetImage(spAlarmDisabled); end; function TJvTFStateImageMap.GetAlarmEnabled: Integer; begin Result := GetImage(spAlarmEnabled); end; function TJvTFStateImageMap.GetModified: Integer; begin Result := GetImage(spModified); end; function TJvTFStateImageMap.GetRecurring: Integer; begin Result := GetImage(spRecurring); end; function TJvTFStateImageMap.GetShared: Integer; begin Result := GetImage(spShared); end; procedure TJvTFStateImageMap.SetAlarmDisabled(const Value: Integer); begin SetImage(spAlarmDisabled, Value); end; procedure TJvTFStateImageMap.SetAlarmEnabled(const Value: Integer); begin SetImage(spAlarmEnabled, Value); end; procedure TJvTFStateImageMap.SetModified(const Value: Integer); begin SetImage(spModified, Value); end; procedure TJvTFStateImageMap.SetRecurring(const Value: Integer); begin SetImage(spRecurring, Value); end; procedure TJvTFStateImageMap.SetShared(const Value: Integer); begin SetImage(spShared, Value); end; procedure TJvTFStateImageMap.Change; begin if Assigned(FScheduleManager) and not (csLoading in FScheduleManager.ComponentState) and not (csDesigning in FScheduleManager.ComponentState) and not FUpdating then FScheduleManager.RefreshConnections(nil); end; procedure TJvTFStateImageMap.BeginUpdate; begin FUpdating := True; end; procedure TJvTFStateImageMap.EndUpdate; begin if FUpdating then begin FUpdating := False; Change; end; end; procedure TJvTFStateImageMap.Clear; var I: TJvTFStatePic; begin for I := Low(TJvTFStatePic) to High(TJvTFStatePic) do FPics[I] := -1; Change; end; procedure TJvTFStateImageMap.Assign(Source: TPersistent); var Pic: TJvTFStatePic; begin if Source is TJvTFStateImageMap then begin for Pic := Low(TJvTFStatePic) to High(TJvTFStatePic) do FPics[Pic] := TJvTFStateImageMap(Source).Pics[Pic]; Change; end else inherited Assign(Source); end; //=== { TJvTFAppt } ========================================================== constructor TJvTFAppt.Create(Serv: TJvTFScheduleManager; const ApptID: string); begin if not Assigned(Serv) then raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateAppointmentObject); inherited Create; FGlyph := TPicture.Create; FSchedules := TStringList.Create; FConnections := TStringList.Create; FStartDate := Date; FStartTime := Time; FEndDate := Date; FEndTime := FStartTime + EncodeTime(0, 1, 0, 0); FScheduleManager := Serv; FDestroying := False; if ApptID <> '' then FID := ApptID else FID := FScheduleManager.GenerateApptID; FModified := False; FColor := clDefault; FBarColor := clDefault; FImageMap := TJvTFCustomImageMap.Create(Self); ScheduleManager.Notify(Self, sncLoadAppt); Serv.DoCreateApptEvent(Self); end; destructor TJvTFAppt.Destroy; begin FDestroying := True; if Assigned(ScheduleManager) then ScheduleManager.DoDestroyApptEvent(Self); ScheduleManager.Notify(Self, sncDestroyAppt); FSchedules.Free; FConnections.Free; FImageMap.Free; FGlyph.Free; inherited Destroy; end; function TJvTFAppt.GetDescription: string; begin Result := FDescription; ScheduleManager.GetApptDescription(Self, Result); end; procedure TJvTFAppt.SetDescription(Value: string); begin ScheduleManager.SetApptDescription(Self, Value); if Value <> FDescription then begin FDescription := Value; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end; end; end; procedure TJvTFAppt.SetAlarmEnabled(Value: Boolean); begin if Value <> FAlarmEnabled then begin FAlarmEnabled := Value; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end; end; end; procedure TJvTFAppt.SetAlarmAdvance(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FAlarmAdvance then begin FAlarmAdvance := Value; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end; end; end; procedure TJvTFAppt.SetColor(Value: TColor); begin if Value <> FColor then begin FColor := Value; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end; end; end; procedure TJvTFAppt.SetBarColor(Value: TColor); begin if Value <> FBarColor then begin FBarColor := Value; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end; end; end; procedure TJvTFAppt.Notify(Sender: TObject; Code: TJvTFServNotifyCode); begin case Code of sncConnectAppt: Connect(TJvTFSched(Sender)); sncDisconnectAppt: Disconnect(TJvTFSched(Sender)); // implicit post fix //sncPostAppt: FModified := False; sncPostAppt: PostApptNotification; sncDeleteAppt: InternalClearSchedules; sncRefresh: FModified := False; end; end; procedure TJvTFAppt.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Serv) then Serv.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc); end; procedure TJvTFAppt.NotifySchedule(Sched: TJvTFSched; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Sched) then Sched.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleNotificationFailed); end; function TJvTFAppt.GetConnection(Index: Integer): TJvTFSched; begin Result := TJvTFSched(FConnections.Objects[Index]); end; function TJvTFAppt.GetSchedule(Index: Integer): string; begin Result := FSchedules[Index]; end; procedure TJvTFAppt.CheckConnections; var Schedule: TJvTFSched; I: Integer; ADate: TDate; Temp: TStringList; begin // Schedules --> Connections for I := 0 to ScheduleCount - 1 do begin ADate := StartDate; while Trunc(ADate) <= Trunc(EndDate) do begin Schedule := ScheduleManager.FindSchedule(Schedules[I], ADate); if Assigned(Schedule) and (FConnections.IndexOfObject(Schedule) = -1) then Connect(Schedule); ADate := ADate + 1; end; end; // Connections --> Schedules Temp := TStringList.Create; try Temp.Assign(FConnections); for I := 0 to Temp.Count - 1 do begin Schedule := TJvTFSched(Temp.Objects[I]); if (FSchedules.IndexOf(Schedule.SchedName) = -1) or ((Trunc(Schedule.SchedDate) < Trunc(StartDate)) or (Trunc(Schedule.SchedDate) > Trunc(EndDate))) then Disconnect(Schedule); end; finally Temp.Free; end; { implicit post fix If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then // To avoid display anomolies we need to post the appt here. Post; } end; procedure TJvTFAppt.Connect(Schedule: TJvTFSched); var SchedID: string; I: Integer; begin if Assigned(Schedule) then begin Schedule.Notify(Self, sncConnectAppt); SchedID := ScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate); I := FConnections.IndexOf(SchedID); if I = -1 then begin FConnections.AddObject(SchedID, Schedule); ScheduleManager.RefreshConnections(Schedule); end; end; end; procedure TJvTFAppt.Disconnect(Schedule: TJvTFSched); var I: Integer; begin if Assigned(Schedule) then begin Schedule.Notify(Self, sncDisconnectAppt); I := FConnections.IndexOfObject(Schedule); if I > -1 then begin FConnections.Delete(I); ScheduleManager.RefreshConnections(Schedule); end; end; end; procedure TJvTFAppt.Change; begin // implicit post fix if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing and not Updating then Post; ScheduleManager.RefreshConnections(Self); end; procedure TJvTFAppt.InternalClearSchedules; begin FSchedules.Clear; CheckConnections; end; procedure TJvTFAppt.Assign(Source: TPersistent); var I: Integer; begin if Source is TJvTFAppt then begin for I := 0 to TJvTFAppt(Source).ScheduleCount - 1 do AddSchedule(TJvTFAppt(Source).Schedules[I]); ImageMap.Assign(TJvTFAppt(Source).ImageMap); SetStartEnd(TJvTFAppt(Source).StartDate, TJvTFAppt(Source).StartTime, TJvTFAppt(Source).EndDate, TJvTFAppt(Source).EndTime); Description := TJvTFAppt(Source).Description; AlarmEnabled := TJvTFAppt(Source).AlarmEnabled; AlarmAdvance := TJvTFAppt(Source).AlarmAdvance; Data := TJvTFAppt(Source).Data; end else inherited Assign(Source); end; procedure TJvTFAppt.SetStartEnd(NewStartDate: TDate; NewStartTime: TTime; NewEndDate: TDate; NewEndTime: TTime); begin // The following avoids time overflow into next day when it is not // intended. (Add appt to last row of days would cause invalid // start/end exception.) if Frac(NewEndTime) <= EncodeTime(0, 0, 0, 999) then NewEndTime := EncodeTime(23, 59, 59, 0); if Trunc(NewStartDate) <= Trunc(NewEndDate) then begin if Trunc(NewStartDate) = Trunc(NewEndDate) then if Frac(NewStartTime) >= Frac(NewEndTime) then raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidStartAndEndTimes); FStartDate := NewStartDate; FEndDate := NewEndDate; FStartTime := NewStartTime; FEndTime := NewEndTime; CheckConnections; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; Change; end end else raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidStartAndEndDates); end; procedure TJvTFAppt.SetModified; begin FModified := True; // implicit post fix Change; end; function TJvTFAppt.Modified: Boolean; begin Result := FModified; end; function TJvTFAppt.ConnectionCount: Integer; begin Result := FConnections.Count; end; function TJvTFAppt.ScheduleCount: Integer; begin Result := FSchedules.Count; end; procedure TJvTFAppt.AddSchedule(const SchedName: string); var ADate: TDate; Schedule: TJvTFSched; begin if SchedName = '' then Exit; // Add it to the schedules list if FSchedules.IndexOf(SchedName) = -1 then begin FSchedules.Add(SchedName); if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; // implicit post fix Change; end; end; // Check for needed connections // (Only connects to currently loaded schedules. Will not load a schedule.) ADate := StartDate; while Trunc(ADate) <= Trunc(EndDate) do begin Schedule := ScheduleManager.FindSchedule(SchedName, ADate); if Assigned(Schedule) then Connect(Schedule); ADate := ADate + 1; end; { implicit post fix // To avoid display anomolies we need to post the appt here. If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then Post; } end; procedure TJvTFAppt.RemoveSchedule(const SchedName: string); var I: Integer; ADate: TDate; Schedule: TJvTFSched; begin if SchedName = '' then Exit; // Remove it from the schedule list I := FSchedules.IndexOf(SchedName); if I > -1 then begin FSchedules.Delete(I); if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; // implicit post fix Change; end; end; // Check for invalid connections and disconnect ADate := StartDate; while Trunc(ADate) <= Trunc(EndDate) do begin Schedule := ScheduleManager.FindSchedule(SchedName, ADate); if Assigned(Schedule) then Disconnect(Schedule); ADate := ADate + 1; end; { implicit post fix // To avoid display anomolies we need to post the appt here. If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then Post; } end; procedure TJvTFAppt.AssignSchedules(List: TStrings); begin FSchedules.Assign(List); if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; // implicit post fix Change; end; CheckConnections; end; procedure TJvTFAppt.ClearSchedules; begin FSchedules.Clear; if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then begin FModified := True; // implicit post fix Change; end; CheckConnections; end; function TJvTFAppt.IndexOfSchedule(const SchedName: string): Integer; begin Result := FSchedules.IndexOf(SchedName); end; function TJvTFAppt.Shared: Boolean; begin Result := ScheduleCount > 1; end; procedure TJvTFAppt.Post; begin ScheduleManager.dbPostAppt(Self); end; procedure TJvTFAppt.Refresh; begin ScheduleManager.dbRefreshAppt(Self); end; procedure TJvTFAppt.Delete; begin ScheduleManager.dbDeleteAppt(Self); end; procedure TJvTFAppt.RefreshControls; begin ScheduleManager.RefreshConnections(Self); end; function TJvTFAppt.GetEndDateTime: TDateTime; begin Result := Trunc(EndDate) + Frac(EndTime); end; function TJvTFAppt.GetStartDateTime: TDateTime; begin Result := Trunc(StartDate) + Frac(StartTime); end; function TJvTFAppt.GetEndDate: TDate; begin Result := Int(FEndDate); end; function TJvTFAppt.GetEndTime: TTime; begin Result := Frac(FEndTime); end; function TJvTFAppt.GetStartDate: TDate; begin Result := Int(FStartDate); end; function TJvTFAppt.GetStartTime: TTime; begin Result := Frac(FStartTime); end; procedure TJvTFAppt.DeleteApptNotification; begin FDeleting := True; try InternalClearSchedules; finally FDeleting := False; end; end; procedure TJvTFAppt.PostApptNotification; begin FModified := False; FUpdating := False; end; procedure TJvTFAppt.BeginUpdate; begin FUpdating := True; end; procedure TJvTFAppt.EndUpdate; begin if FUpdating then begin FUpdating := False; Change; end; end; procedure TJvTFAppt.SetRefreshed(Value: Boolean); begin FRefreshed := Value; end; procedure TJvTFAppt.SetGlyph(const Value: TPicture); begin FGlyph.Assign(Value); end; procedure TJvTFAppt.RefreshNotification; begin FModified := False; Refreshed := False; end; //=== { TJvTFSched } ========================================================= constructor TJvTFSched.Create(Serv: TJvTFScheduleManager; const AName: string; ADate: TDate); begin inherited Create; FScheduleManager := Serv; FSchedName := AName; FSchedDate := ADate; FAppts := TStringList.Create; FConControls := TStringList.Create; FConControls.OnChange := @ConnectionsOnChange; FConComponents := TStringList.Create; FConComponents.OnChange := @ConnectionsOnChange; if Assigned(Serv) then Serv.DoCreateScheduleEvent(Self); end; destructor TJvTFSched.Destroy; var Ctrl: TJvTFControl; Comp: TJvTFComponent; Appt: TJvTFAppt; begin FDestroying := True; if Assigned(ScheduleManager) then ScheduleManager.DoDestroyScheduleEvent(Self); while ConControlCount > 0 do begin Ctrl := TJvTFControl(FConControls.Objects[0]); ScheduleManager.ReleaseSchedule(Ctrl, SchedName, SchedDate); end; while ConComponentCount > 0 do begin Comp := TJvTFComponent(FConComponents.Objects[0]); ScheduleManager.ReleaseSchedule(Comp, SchedName, SchedDate); end; while ApptCount > 0 do begin Appt := Appts[0]; Appt.Notify(Self, sncDisconnectAppt); end; ScheduleManager.Notify(Self, sncDestroySchedule); FAppts.Free; FConControls.Free; FConComponents.Free; inherited Destroy; end; function TJvTFSched.GetAppt(Index: Integer): TJvTFAppt; begin Result := TJvTFAppt(FAppts.Objects[Index]); end; procedure TJvTFSched.Notify(Sender: TObject; Code: TJvTFServNotifyCode); var I: Integer; ConList: TStringList; begin if Sender is TJvTFControl then ConList := FConControls else if Sender is TJvTFComponent then ConList := FConComponents else ConList := nil; case Code of sncRequestSchedule: if ConList.IndexOfObject(Sender) = -1 then ConList.AddObject('', Sender); sncReleaseSchedule: begin I := ConList.IndexOfObject(Sender); if I > -1 then ConList.Delete(I); end; sncConnectAppt: ConnectAppt(TJvTFAppt(Sender)); sncDisconnectAppt: DisconnectAppt(TJvTFAppt(Sender)); end; end; procedure TJvTFSched.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Serv) then Serv.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc); end; procedure TJvTFSched.NotifyAppt(Appt: TJvTFAppt; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Appt) then Appt.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEAppointmentNotificationFailed); end; function TJvTFSched.GetConControl(Index: Integer): TJvTFControl; begin Result := TJvTFControl(FConControls.Objects[Index]); end; function TJvTFSched.GetConComponent(Index: Integer): TJvTFComponent; begin Result := TJvTFComponent(FConComponents.Objects[Index]); end; procedure TJvTFSched.ConnectAppt(Appt: TJvTFAppt); begin if FAppts.IndexOf(Appt.ID) = -1 then FAppts.AddObject(Appt.ID, Appt); end; procedure TJvTFSched.DisconnectAppt(Appt: TJvTFAppt); var I: Integer; begin I := FAppts.IndexOf(Appt.ID); if I > -1 then FAppts.Delete(I); end; procedure TJvTFSched.ConnectionsOnChange(Sender: TObject); begin if (FConControls.Count = 0) and (FConComponents.Count = 0) then begin FCached := True; FCachedTime := GetTickCount64; //Windows.GetTickCount; end else FCached := False; end; procedure TJvTFSched.CheckConnections; var I: Integer; Appt: TJvTFAppt; DateHit, NameMatch, NotConnected: Boolean; begin // Check each appt in the ScheduleManager to see if that appt should be connected // to this schedule. If so, then connect it. for I := 0 to ScheduleManager.ApptCount - 1 do begin Appt := ScheduleManager.Appts[I]; DateHit := (Trunc(SchedDate) >= Trunc(Appt.StartDate)) and (Trunc(SchedDate) <= Trunc(Appt.EndDate)); NameMatch := Appt.IndexOfSchedule(SchedName) > -1; NotConnected := ApptByID(Appt.ID) = nil; if DateHit and NameMatch and NotConnected then Appt.Notify(Self, sncConnectAppt); end; end; function TJvTFSched.GetFreeUsedTime(FreeTime: Boolean): TDynTimeRangeArray; var // 60 mins X 24 hrs = 1440 ==> minutes in a day DayArray: array [0..1439] of Boolean; // I'm a poet and don't know it. I, J, MinStart, MinEnd: Integer; anAppt: TJvTFAppt; StartTime, EndTime: TTime; Switch, MinIsFree, InRange: Boolean; function TimeToMinNum(ATime: TTime): Integer; var H, M, S, MS: Word; begin DecodeTime(ATime, H, M, S, MS); Result := H * 60 + M; end; function MinNumToTime(MinNum: Integer): TTime; begin Result := EncodeTime(MinNum div 60, MinNum mod 60, 0, 0); end; procedure StartRange; begin StartTime := MinNumToTime(I); InRange := True; end; procedure EndRange; begin EndTime := MinNumToTime(I); // add range to resultant array SetLength(Result, Length(Result) + 1); Result[High(Result)].StartTime := StartTime; Result[High(Result)].EndTime := EndTime; InRange := False; end; begin // Initialize resultant array SetLength(Result, 1); Result[0].StartTime := 0.0; Result[0].EndTime := EncodeTime(23, 59, 59, 0); // EXIT if nothing to do if ApptCount = 0 then begin if not FreeTime then SetLength(Result, 0); Exit; end; // Initialize working array // True ==> free minute // False ==> used minute for I := 0 to 1439 do DayArray[I] := True; // Go through the appts and mark used minutes in the working array for I := 0 to ApptCount - 1 do begin anAppt := Appts[I]; MinStart := TimeToMinNum(anAppt.StartTime); MinEnd := TimeToMinNum(AdjustEndTime(anAppt.EndTime)); for J := MinStart to MinEnd do DayArray[J] := False; end; // Now convert working array to resultant array SetLength(Result, 0); MinIsFree := not FreeTime; for I := 0 to 1439 do begin Switch := DayArray[I] xor MinIsFree; MinIsFree := DayArray[I]; if Switch then if MinIsFree then if FreeTime then StartRange else EndRange else if FreeTime then EndRange else StartRange end; // close and add the last range if needed if InRange then begin I := 1439; // set I to last min of day EndRange; end; end; function TJvTFSched.ApptCount: Integer; begin Result := FAppts.Count; end; function TJvTFSched.ApptByID(const ID: string): TJvTFAppt; var I: Integer; begin Result := nil; I := FAppts.IndexOf(ID); if I > -1 then Result := TJvTFAppt(FAppts.Objects[I]); end; function TJvTFSched.ConControlCount: Integer; begin Result := FConControls.Count; end; function TJvTFSched.ConComponentCount: Integer; begin Result := FConComponents.Count; end; procedure TJvTFSched.AddAppt(Appt: TJvTFAppt); begin if Assigned(Appt) then Appt.AddSchedule(SchedName); end; procedure TJvTFSched.RemoveAppt(Appt: TJvTFAppt); begin if Assigned(Appt) then Appt.RemoveSchedule(SchedName); end; { procedure TJvTFSched.RefreshAppts; Var I, J, K: Integer; ApptIDList, RefList: TStringList; Appt: TJvTFAppt; Sched: TJvTFSched; RefID: string; begin // In a multi-user environment, appt objects may be deleted as a result // of calling dbRefreshAppt. (Component user may call Appt.Free.) // To account for this we need to build a list of appt ID's instead of // working directly from the ScheduleManager's appointment list. // We also need to build a list of connections (Components and // TJvTFControls) that need to be refreshed. ApptIDList := TStringList.Create; RefList := TStringList.Create; RefList.Duplicates := dupIgnore; Try For I := 0 to ApptCount - 1 do Begin Appt := Appts[I]; ApptIDList.Add(Appt.ID); For J := 0 to Appt.ConnectionCount - 1 do Begin Sched := Appt.Connections[J]; For K := 0 to Sched.ConComponentCount - 1 do Begin RefID := IntToStr(Integer(Sched.ConComponents[K])); RefList.AddObject(RefID, Sched.ConComponents[K]); End; For K := 0 to Sched.ConControlCount - 1 do Begin RefID := IntToStr(Integer(Sched.ConControls[K])); RefList.AddObject(RefID, Sched.ConControls[K]); End; End; End; For I := 0 to ApptIDList.Count - 1 do Begin Appt := ScheduleManager.FindAppt(ApptIDList[I]); If Assigned(Appt) Then ScheduleManager.dbRefreshAppt(Appt); End; For I := 0 to RefList.Count - 1 do ScheduleManager.RefreshConnections(RefList.Objects[I]); Finally ApptIDList.Free; RefList.Free; End; end; } procedure TJvTFSched.PostAppts; var I: Integer; begin for I := 0 to ApptCount - 1 do ScheduleManager.dbPostAppt(Appts[I]); end; function TJvTFSched.GetFreeTime: TDynTimeRangeArray; begin Result := GetFreeUsedTime(True); end; function TJvTFSched.GetUsedTime: TDynTimeRangeArray; begin Result := GetFreeUsedTime(False); end; function TJvTFSched.TimeIsFree(TimeRange: TJvTFTimeRange): Boolean; var Appt: TJvTFAppt; I: Integer; begin Result := True; I := 0; while (I < ApptCount) and Result do begin Appt := Appts[I]; if (Frac(Appt.StartTime) <= Frac(AdjustEndTime(TimeRange.EndTime))) and (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(TimeRange.StartTime)) then Result := False else Inc(I); end; end; function TJvTFSched.TimeIsFree(RangeStart, RangeEnd: TTime): Boolean; var TimeRange: TJvTFTimeRange; begin TimeRange.StartTime := RangeStart; TimeRange.EndTime := RangeEnd; Result := TimeIsFree(TimeRange); end; function TJvTFSched.ApptHasConflicts(anAppt: TJvTFAppt): Boolean; var Appt: TJvTFAppt; I: Integer; begin Result := False; I := 0; while (I < ApptCount) and not Result do begin Appt := Appts[I]; if (Appt <> anAppt) and // Don't flag for the given appt (Frac(Appt.StartTime) <= Frac(AdjustEndTime(anAppt.EndTime))) and (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(anAppt.StartTime)) then Result := True else Inc(I); end; end; function TJvTFSched.EnumConflicts(TimeRange: TJvTFTimeRange): TDynApptArray; var Appt: TJvTFAppt; I: Integer; begin SetLength(Result, 0); for I := 0 to ApptCount - 1 do begin Appt := Appts[I]; if (Frac(Appt.StartTime) <= Frac(AdjustEndTime(TimeRange.EndTime))) and (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(TimeRange.StartTime)) then begin SetLength(Result, Length(Result) + 1); Result[High(Result)] := Appt; end; end; end; function TJvTFSched.EnumConflicts(RangeStart, RangeEnd: TTime): TDynApptArray; var TimeRange: TJvTFTimeRange; begin TimeRange.StartTime := RangeStart; TimeRange.EndTime := RangeEnd; Result := EnumConflicts(TimeRange); end; function TJvTFSched.EnumConflicts(anAppt: TJvTFAppt): TDynApptArray; var Appt: TJvTFAppt; I: Integer; begin SetLength(Result, 0); for I := 0 to ApptCount - 1 do begin Appt := Appts[I]; if (Appt <> anAppt) and // don't add the given appt (Frac(Appt.StartTime) <= Frac(AdjustEndTime(anAppt.EndTime))) and (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(anAppt.StartTime)) then begin SetLength(Result, Length(Result) + 1); Result[High(Result)] := Appt; end; end; end; function TJvTFSched.GetFirstAppt: TJvTFAppt; var I: Integer; anAppt: TJvTFAppt; begin Result := nil; I := 0; while (I < ApptCount) do begin anAppt := Appts[I]; if Trunc(anAppt.StartDate) < Trunc(SchedDate) then begin Result := anAppt; Break; // APPOINTMENT STARTS AT 0:00 (12:00am) SO LEAVE LOOP end else if not Assigned(Result) then Result := anAppt else if Frac(anAppt.StartTime) < Frac(Result.StartTime) then Result := anAppt; Inc(I); end; end; function TJvTFSched.GetLastAppt: TJvTFAppt; var I: Integer; anAppt: TJvTFAppt; begin Result := nil; I := 0; while (I < ApptCount) do begin anAppt := Appts[I]; if Trunc(anAppt.EndDate) > Trunc(SchedDate) then begin Result := anAppt; Break; // APPOINTMENT ENDS AT 23:59 (11:59pm) SO LEAVE LOOP end else if not Assigned(Result) then Result := anAppt else if Frac(anAppt.EndTime) > Frac(Result.EndTime) then Result := anAppt; Inc(I); end; end; procedure TJvTFSched.Refresh; begin ScheduleManager.dbRefreshSched(Self); end; procedure TJvTFSched.SetSchedDisplayName(const Value: string); begin if FSchedDisplayName <> Value then begin FSchedDisplayName := Value; ScheduleManager.RefreshConnections(Self); end; end; //=== { TJvTFScheduleManagerCache } ========================================== constructor TJvTFScheduleManagerCache.Create(SchedManager: TJvTFScheduleManager); begin inherited Create; FScheduleManager := SchedManager; FCacheType := ctTimed; FTimedDelay := 30000; FBufferCount := 7; FTimer := TTimer.Create(nil); FTimer.OnTimer := @TimerOnTimer; FTimer.Interval := FTimedDelay; FTimer.Enabled := FCacheType = ctTimed; end; destructor TJvTFScheduleManagerCache.Destroy; begin FTimer.Free; inherited Destroy; end; procedure TJvTFScheduleManagerCache.SetCacheType(Value: TJvTFScheduleManagerCacheType); begin if Value <> FCacheType then begin FCacheType := Value; FTimer.Enabled := Value = ctTimed; FlushManager; end; end; procedure TJvTFScheduleManagerCache.SetTimedDelay(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FTimedDelay then begin FTimedDelay := Value; FTimer.Enabled := False; FTimer.Interval := Value; if CacheType = ctTimed then begin FTimer.Enabled := True; FlushManager; end; end; end; procedure TJvTFScheduleManagerCache.SetBufferCount(Value: Integer); begin if Value < 0 then Value := 0; if Value <> FBufferCount then begin FBufferCount := Value; if CacheType = ctBuffer then FlushManager; end; end; procedure TJvTFScheduleManagerCache.FlushManager; begin if Assigned(FScheduleManager) then FScheduleManager.Flush(False); end; procedure TJvTFScheduleManagerCache.TimerOnTimer(Sender: TObject); begin FlushManager; end; procedure TJvTFScheduleManagerCache.Assign(Source: TPersistent); begin if Source is TJvTFScheduleManagerCache then begin FCacheType := TJvTFScheduleManagerCache(Source).CacheType; FTimedDelay := TJvTFScheduleManagerCache(Source).TimedDelay; FBufferCount := TJvTFScheduleManagerCache(Source).BufferCount; if FTimer.Enabled then begin FTimer.Enabled := False; FTimer.Interval := FTimedDelay; FTimer.Enabled := FCacheType = ctTimed; end; FlushManager; end else inherited Assign(Source); end; //=== { TJvTFScheduleManager } =============================================== constructor TJvTFScheduleManager.Create(AOwner: TComponent); begin inherited Create(AOwner); FSchedLoadMode := slmOnDemand; FAppts := TStringList.Create; FSchedules := TStringList.Create; FSchedBatch := TStringList.Create; FSchedBatch.Sorted := True; FSchedBatch.Duplicates := dupIgnore; FConControls := TStringList.Create; FConComponents := TStringList.Create; FStateImageMap := TJvTFStateImageMap.Create(Self); FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := @ImageListChange; FCache := TJvTFScheduleManagerCache.Create(Self); FApptBeingDestroyed := nil; end; destructor TJvTFScheduleManager.Destroy; begin FDestroying := True; while ConControlCount > 0 do ConControls[0].ScheduleManager := nil; while ConComponentCount > 0 do ConComponents[0].ScheduleManager := nil; while ScheduleCount > 0 do Schedules[0].Free; while ApptCount > 0 do Appts[0].Free; FAppts.Free; FSchedBatch.Free; FSchedules.Free; FConControls.Free; FConComponents.Free; FStateImageMap.Free; StateImages := nil; CustomImages := nil; FImageChangeLink.Free; FCache.Free; inherited Destroy; end; class function TJvTFScheduleManager.GetScheduleID(const SchedName: string; SchedDate: TDate): string; begin Result := SchedName + IntToStr(Trunc(SchedDate)); end; class function TJvTFScheduleManager.GenerateApptID: string; var I: Integer; begin Result := FloatToStr(Now); Randomize; for I := 1 to 5 do Result := Result + Chr(Random(25) + 65); end; function TJvTFScheduleManager.GetAppt(Index: Integer): TJvTFAppt; begin Result := TJvTFAppt(FAppts.Objects[Index]); end; function TJvTFScheduleManager.GetSchedule(Index: Integer): TJvTFSched; begin Result := TJvTFSched(FSchedules.Objects[Index]); end; function TJvTFScheduleManager.GetConControl(Index: Integer): TJvTFControl; begin Result := TJvTFControl(FConControls.Objects[Index]); end; function TJvTFScheduleManager.GetConComponent(Index: Integer): TJvTFComponent; begin Result := TJvTFComponent(FConComponents.Objects[Index]); end; procedure TJvTFScheduleManager.SetStateImages(Value: TCustomImageList); begin ReplaceImageListReference(Self, Value, FStateImages, FImageChangeLink); end; procedure TJvTFScheduleManager.SetCustomImages(Value: TCustomImageList); begin ReplaceImageListReference(Self, Value, FCustomImages, FImageChangeLink); end; procedure TJvTFScheduleManager.SetCache(Value: TJvTFScheduleManagerCache); begin FCache.Assign(Value); end; procedure TJvTFScheduleManager.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then if AComponent = StateImages then begin StateImages := nil; RefreshConnections(nil); end else if AComponent = CustomImages then begin CustomImages := nil; RefreshConnections(nil); end; end; procedure TJvTFScheduleManager.ConnectControl(ApptCtrl: TJvTFControl); var I: Integer; begin if not Assigned(ApptCtrl) then Exit; I := FConControls.IndexOfObject(ApptCtrl); if I = -1 then FConControls.AddObject('', ApptCtrl); end; procedure TJvTFScheduleManager.DisconnectControl(ApptCtrl: TJvTFControl); var I: Integer; begin if not Assigned(ApptCtrl) then Exit; I := FConControls.IndexOfObject(ApptCtrl); if I > -1 then begin ApptCtrl.ReleaseSchedules; FConControls.Delete(I); end; end; procedure TJvTFScheduleManager.ConnectComponent(Comp: TJvTFComponent); var I: Integer; begin if not Assigned(Comp) then Exit; I := FConComponents.IndexOfObject(Comp); if I = -1 then FConComponents.AddObject('', Comp); end; procedure TJvTFScheduleManager.DisconnectComponent(Comp: TJvTFComponent); var I: Integer; begin if not Assigned(Comp) then Exit; I := FConComponents.IndexOfObject(Comp); if I > -1 then begin Comp.ReleaseSchedules; FConComponents.Delete(I); end; end; procedure TJvTFScheduleManager.Notify(Sender: TObject; Code: TJvTFServNotifyCode); begin case Code of sncConnectComponent: ConnectComponent(TJvTFComponent(Sender)); sncDisconnectComponent: DisconnectComponent(TJvTFComponent(Sender)); sncConnectControl: ConnectControl(TJvTFControl(Sender)); sncDisconnectControl: DisconnectControl(TJvTFControl(Sender)); sncLoadAppt: AddAppt(TJvTFAppt(Sender)); sncDestroyAppt: RemoveAppt(TJvTFAppt(Sender)); sncDestroySchedule: RemoveSchedule(TJvTFSched(Sender)); end; end; procedure TJvTFScheduleManager.NotifyAppt(Appt: TJvTFAppt; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Appt) then Appt.Notify(Sender, Code); end; procedure TJvTFScheduleManager.NotifySchedule(Sched: TJvTFSched; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Sched) then Sched.Notify(Sender, Code); end; procedure TJvTFScheduleManager.NotifyApptCtrl(ApptCtrl: TJvTFControl; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(ApptCtrl) then ApptCtrl.Notify(Sender, Code); end; procedure TJvTFScheduleManager.NotifyComp(Comp: TJvTFComponent; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Comp) then Comp.Notify(Sender, Code); end; procedure TJvTFScheduleManager.RetrieveSchedule(const SchedName: string; SchedDate: TDate; out Schedule: TJvTFSched; out LoadedNow: Boolean); var SchedID: string; I: Integer; begin SchedID := GetScheduleID(SchedName, SchedDate); I := FSchedules.IndexOf(SchedID); if I > -1 then begin Schedule := TJvTFSched(FSchedules.Objects[I]); LoadedNow := False; end else begin //Schedule := TJvTFSched.Create(Self, SchedName, SchedDate); Schedule := GetSchedClass.Create(Self, SchedName, SchedDate); FSchedules.AddObject(SchedID, Schedule); LoadedNow := True; if Cache.CacheType = ctBuffer then Flush(False); Schedule.CheckConnections; end; end; procedure TJvTFScheduleManager.NeedAppts(Schedule: TJvTFSched); begin FLoadingAppts := True; try if Assigned(FOnNeedAppts) then FOnNeedAppts(Self, Schedule); finally FLoadingAppts := False; RefreshConnections(Schedule); end; end; procedure TJvTFScheduleManager.AddAppt(Appt: TJvTFAppt); begin if FAppts.IndexOfObject(Appt) = -1 then FAppts.AddObject(Appt.ID, Appt); end; procedure TJvTFScheduleManager.RemoveAppt(Appt: TJvTFAppt); var I: Integer; IndexOfAppt: Integer; begin if Appt = FApptBeingDestroyed then Exit; // Do Nothing if this is already the Appt we are // destroying ourselves IndexOfAppt := FAppts.IndexOfObject(Appt); if IndexOfAppt = -1 then Exit; // Nothing to do if the appt is not in our list for I := 0 to ConControlCount - 1 do NotifyApptCtrl(ConControls[I], Appt, sncDestroyAppt); for I := 0 to ConComponentCount - 1 do NotifyComp(ConComponents[I], Appt, sncDestroyAppt); while Appt.ConnectionCount > 0 do Appt.Notify(Appt.Connections[0], sncDisconnectAppt); FAppts.Delete(IndexOfAppt); // Do not free if the appt is being destroyed by someone else if not Appt.Destroying then begin FApptBeingDestroyed := Appt; try Appt.Free; finally FApptBeingDestroyed := nil; end; end; end; procedure TJvTFScheduleManager.RemoveSchedule(Sched: TJvTFSched); var I: Integer; begin for I := 0 to ConControlCount - 1 do NotifyApptCtrl(ConControls[I], Sched, sncDestroySchedule); for I := 0 to ConComponentCount - 1 do NotifyComp(ConComponents[I], Sched, sncDestroySchedule); FSchedules.Delete(FSchedules.IndexOfObject(Sched)); Flush(False); end; { procedure TJvTFScheduleManager.RefreshAppt(Appt: TJvTFAppt); begin FLoadingAppts := True; Try NotifyAppt(Appt, Self, sncRefresh); If Assigned(FOnRefreshAppt) Then FOnRefreshAppt(Self, Appt); Finally FLoadingAppts := False; End; end; } procedure TJvTFScheduleManager.DeleteAppt(Appt: TJvTFAppt); begin if Assigned(FOnDeleteAppt) then FOnDeleteAppt(Self, Appt); end; procedure TJvTFScheduleManager.PostAppt(Appt: TJvTFAppt); begin if Assigned(FOnPostAppt) then FOnPostAppt(Self, Appt); end; procedure TJvTFScheduleManager.RequestRefresh(ApptCtrl: TJvTFControl; Schedule: TJvTFSched); begin NotifyApptCtrl(ApptCtrl, Self, sncRefresh); { If Assigned(ApptCtrl) Then Windows.PostMessage(ApptCtrl.Handle, CN_REQUESTREFRESH, WPARAM(Schedule), 0) Else Raise EJvTFScheduleManagerError.Create('Could not send refresh request. ' + 'ApptCtrl not assigned'); } end; procedure TJvTFScheduleManager.RequestRefresh(Comp: TJvTFComponent; Schedule: TJvTFSched); begin NotifyComp(Comp, Self, sncRefresh); end; procedure TJvTFScheduleManager.ImageListChange(Sender: TObject); begin if not (csDestroying in ComponentState) then RefreshConnections(nil); end; procedure TJvTFScheduleManager.FlushAppts; var I: Integer; begin I := 0; while I < ApptCount do if (Appts[I].ConnectionCount = 0) and not Appts[I].Persistent then begin if not FlushObject(Appts[I]) then Inc(I); end else Inc(I); end; function TJvTFScheduleManager.FlushObject(FlushObj: TObject): Boolean; var FlushIt: Boolean; begin Result := False; if Assigned(FlushObj) then begin FlushIt := True; if Assigned(FOnFlush) then FOnFlush(Self, FlushObj, FlushIt); if FlushIt then FlushObj.Free; Result := FlushIt; end; end; procedure TJvTFScheduleManager.DoCreateApptEvent(anAppt: TJvTFAppt); begin if Assigned(FOnCreateAppt) then FOnCreateAppt(Self, anAppt); end; procedure TJvTFScheduleManager.DoCreateScheduleEvent(aSchedule: TJvTFSched); begin if Assigned(FOnCreateSchedule) then FOnCreateSchedule(Self, aSchedule); end; procedure TJvTFScheduleManager.DoDestroyApptEvent(anAppt: TJvTFAppt); begin if Assigned(FOnDestroyAppt) then FOnDestroyAppt(Self, anAppt); end; procedure TJvTFScheduleManager.DoDestroyScheduleEvent(aSchedule: TJvTFSched); begin if Assigned(FOnDestroySchedule) then FOnDestroySchedule(Self, aSchedule); end; function TJvTFScheduleManager.ApptCount: Integer; begin Result := FAppts.Count; end; function TJvTFScheduleManager.FindAppt(const ID: string): TJvTFAppt; var I: Integer; begin Result := nil; I := FAppts.IndexOf(ID); if I > -1 then Result := TJvTFAppt(FAppts.Objects[I]); end; function TJvTFScheduleManager.ScheduleCount: Integer; begin Result := FSchedules.Count; end; function TJvTFScheduleManager.FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; var I: Integer; begin Result := nil; I := FSchedules.IndexOf(GetScheduleID(SchedName, SchedDate)); if I > -1 then Result := TJvTFSched(FSchedules.Objects[I]); end; function TJvTFScheduleManager.ConControlCount: Integer; begin Result := FConControls.Count; end; function TJvTFScheduleManager.ConComponentCount: Integer; begin Result := FConComponents.Count; end; function TJvTFScheduleManager.RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate): TJvTFSched; var ApptsNeeded: Boolean; begin RetrieveSchedule(SchedName, SchedDate, Result, ApptsNeeded); if Assigned(ApptCtrl) then begin Result.Notify(ApptCtrl, sncRequestSchedule); ApptCtrl.Notify(Result, sncRequestSchedule); end; if ApptsNeeded then if SchedLoadMode = slmOnDemand then NeedAppts(Result) else begin AddToBatch(Result); end; end; function TJvTFScheduleManager.RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; begin RetrieveSchedule(SchedName, SchedDate, Result, LoadedNow); if Assigned(ApptCtrl) then begin Result.Notify(ApptCtrl, sncRequestSchedule); ApptCtrl.Notify(Result, sncRequestSchedule); end; if LoadedNow then begin if SchedLoadMode = slmOnDemand then NeedAppts(Result) else AddToBatch(Result); end; end; function TJvTFScheduleManager.RequestSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate): TJvTFSched; var ApptsNeeded: Boolean; begin Result := nil; RetrieveSchedule(SchedName, SchedDate, Result, ApptsNeeded); if Assigned(Comp) then begin Result.Notify(Comp, sncRequestSchedule); Comp.Notify(Result, sncRequestSchedule); end; if ApptsNeeded then begin if SchedLoadMode = slmOnDemand then NeedAppts(Result) else AddToBatch(Result); end; end; function TJvTFScheduleManager.RequestSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; begin Result := nil; RetrieveSchedule(SchedName, SchedDate, Result, LoadedNow); if Assigned(Comp) then begin Result.Notify(Comp, sncRequestSchedule); Comp.Notify(Result, sncRequestSchedule); end; if LoadedNow then begin if SchedLoadMode = slmOnDemand then NeedAppts(Result) else AddToBatch(Result); end; end; procedure TJvTFScheduleManager.ReleaseSchedule(ApptCtrl: TJvTFControl; const SchedName: string; SchedDate: TDate); var SchedID: string; I: Integer; Schedule: TJvTFSched; begin SchedID := GetScheduleID(SchedName, SchedDate); I := FSchedules.IndexOf(SchedID); if I > -1 then begin Schedule := TJvTFSched(FSchedules.Objects[I]); if Assigned(ApptCtrl) then begin Schedule.Notify(ApptCtrl, sncReleaseSchedule); ApptCtrl.Notify(Schedule, sncReleaseSchedule); end; if (Cache.CacheType = ctBuffer) then Flush(False); end; end; procedure TJvTFScheduleManager.ReleaseSchedule(Comp: TJvTFComponent; const SchedName: string; SchedDate: TDate); var SchedID: string; I: Integer; Schedule: TJvTFSched; begin SchedID := GetScheduleID(SchedName, SchedDate); I := FSchedules.IndexOf(SchedID); if I > -1 then begin Schedule := TJvTFSched(FSchedules.Objects[I]); if Assigned(Comp) then begin Schedule.Notify(Comp, sncReleaseSchedule); Comp.Notify(Schedule, sncReleaseSchedule); end; if Cache.CacheType = ctBuffer then Flush(False); end; end; procedure TJvTFScheduleManager.RequestAppt(const ID: string; var Appt: TJvTFAppt; var New: Boolean); var I: Integer; begin I := -1; if ID <> '' then I := FAppts.IndexOf(ID); if I > -1 then begin Appt := TJvTFAppt(FAppts.Objects[I]); New := False; end else begin //Appt := TJvTFAppt.Create(Self, ID); Appt := GetApptClass.Create(Self, ID); New := True; end; end; procedure TJvTFScheduleManager.dbPostAppt(Appt: TJvTFAppt); begin { implicit post fix If Assigned(Appt) Then If (AlwaysPost or Appt.Modified) Then Begin PostAppt(Appt); Appt.Notify(Self, sncPostAppt); End; } // implicit post fix if Assigned(Appt) and (AlwaysPost or Appt.Modified) and QueryPostAppt(Appt) then begin PostAppt(Appt); Appt.Notify(Self, sncPostAppt); end; end; procedure TJvTFScheduleManager.dbDeleteAppt(Appt: TJvTFAppt); begin if Assigned(Appt) then begin DeleteAppt(Appt); Appt.Notify(Self, sncDeleteAppt); end; end; procedure TJvTFScheduleManager.dbDeleteAllAppt; var I: Integer; begin for I := FAppts.Count - 1 downto 0 do RemoveAppt(TJvTFAppt(FAppts.Objects[0])); end; procedure TJvTFScheduleManager.dbRefreshAppt(Appt: TJvTFAppt); begin if Assigned(Appt) then begin FRefreshing := True; try Appt.Notify(Self, sncRefresh); if Assigned(FOnRefreshAppt) then FOnRefreshAppt(Self, Appt); if RefreshAutoReconcile then ReconcileRefresh(Appt); finally FRefreshing := False; // BUG - IT'S A LITTLE LATE TO BE USING THE APPT AS A REFRESH TRIGGER!!! //RefreshConnections(Appt); // Use nil as trigger to refresh everything RefreshConnections(nil); end; end; { If Assigned(Appt) Then RefreshAppt(Appt); } end; function TJvTFScheduleManager.dbNewAppt(const ID: string): TJvTFAppt; var New: Boolean = false; // to silence the compiler begin Result := nil; RequestAppt(ID, Result, New); if not New then raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateNewAppointment); end; procedure TJvTFScheduleManager.PostAppts; var I: Integer; begin for I := 0 to ApptCount - 1 do dbPostAppt(Appts[I]); end; procedure TJvTFScheduleManager.RefreshAppts; var I: Integer; ApptIDList: TStringList; Appt: TJvTFAppt; begin // In a multi-user environment, appt objects may be deleted as a result // of calling dbRefreshAppt. (Component user may call Appt.Free.) // To account for this we need to build a list of appt ID's instead of // working directly from the ScheduleManager's appointment list. ApptIDList := TStringList.Create; try for I := 0 to ApptCount - 1 do begin Appt := Appts[I]; ApptIDList.Add(Appt.ID); end; for I := 0 to ApptIDList.Count - 1 do begin Appt := FindAppt(ApptIDList[I]); if Assigned(Appt) then dbRefreshAppt(Appt); end; RefreshConnections(nil); finally ApptIDList.Free; end; end; procedure TJvTFScheduleManager.RefreshConnections(Trigger: TObject); var Sched: TJvTFSched; Appt: TJvTFAppt; I: Integer; begin // Do not refresh if we're loading or refreshing appts if FLoadingAppts or Refreshing then Exit; if Trigger = nil then begin // refresh all schedules for all controls connected to ScheduleManager for I := 0 to ConControlCount - 1 do RequestRefresh(ConControls[I], nil); // refresh all schedules for all components connected to the ScheduleManager for I := 0 to ConComponentCount - 1 do RequestRefresh(ConComponents[I], nil); end else if Trigger is TJvTFComponent then begin // refresh all schedules for given component RequestRefresh(TJvTFComponent(Trigger), nil); end else if Trigger is TJvTFControl then begin // refresh all schedules for given control RequestRefresh(TJvTFControl(Trigger), nil); end else if Trigger is TJvTFSched then begin // refresh all appt controls connected to schedule Sched := TJvTFSched(Trigger); for I := 0 to Sched.ConControlCount - 1 do RequestRefresh(Sched.ConControls[I], Sched); // refresh all utf components connected to schedule for I := 0 to Sched.ConComponentCount - 1 do RequestRefresh(Sched.ConComponents[I], Sched); end else if Trigger is TJvTFAppt then begin // refresh all appt controls for all schedules connected to this appt Appt := TJvTFAppt(Trigger); for I := 0 to Appt.ConnectionCount - 1 do RefreshConnections(Appt.Connections[I]); end else raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidTriggerForRefreshControls) end; procedure TJvTFScheduleManager.Flush(All: Boolean); //param All defaults to False var I: Integer; Sched: TJvTFSched; MRUList: TStringList; CacheTimeUp: Boolean; begin if FFlushing or FDestroying then Exit; FFlushing := True; try if All then begin I := 0; while I < ScheduleCount do begin Sched := Schedules[I]; if Sched.Cached and not Sched.Persistent then begin if not FlushObject(Sched) then Inc(I); end else Inc(I); end; FlushAppts; end else if Cache.CacheType = ctTimed then begin I := 0; while I < ScheduleCount do begin Sched := Schedules[I]; CacheTimeUp := GetTickCount64 - Sched.CachedTime >= Cache.TimedDelay; // CacheTimeUp := Windows.GetTickCount - Sched.CachedTime >= UINT(Cache.TimedDelay); if Sched.Cached and CacheTimeUp then begin if not FlushObject(Sched) then Inc(I); end else Inc(I); end; FlushAppts; end else if Cache.CacheType = ctBuffer then begin MRUList := TStringList.Create; try MRUList.Sorted := True; MRUList.Duplicates := dupAccept; for I := 0 to ScheduleCount - 1 do begin Sched := Schedules[I]; if Sched.Cached then MRUList.AddObject(IntToHex(Sched.CachedTime, 8), Sched); end; for I := 0 to MRUList.Count - 1 - Cache.BufferCount do FlushObject(MRUList.Objects[I]); FlushAppts; finally MRUList.Free; end; end; finally FFlushing := False; end; end; procedure TJvTFScheduleManager.dbRefreshAll; var I: Integer; begin FRefreshing := True; try for I := 0 to ApptCount - 1 do NotifyAppt(Appts[I], Self, sncRefresh); if Assigned(FOnRefreshAll) then FOnRefreshAll(Self); if RefreshAutoReconcile then ReconcileRefresh(Self); finally FRefreshing := False; RefreshConnections(nil); end; end; procedure TJvTFScheduleManager.dbRefreshOrphans; var I: Integer; begin for I := 0 to ApptCount - 1 do if Appts[I].ConnectionCount = 0 then dbRefreshAppt(Appts[I]); end; procedure TJvTFScheduleManager.dbRefreshSched(Sched: TJvTFSched); var I: Integer; begin if Assigned(Sched) then begin FRefreshing := True; try for I := 0 to Sched.ApptCount - 1 do NotifyAppt(Sched.Appts[I], Self, sncRefresh); if Assigned(FOnRefreshSched) then FOnRefreshSched(Self, Sched); if RefreshAutoReconcile then ReconcileRefresh(Sched); finally FRefreshing := False; RefreshConnections(Sched); end; end; end; procedure TJvTFScheduleManager.SetTFSchedLoadMode(Value: TJvTFSchedLoadMode); begin if (Value <> FSchedLoadMode) and (Value = slmOnDemand) then // make sure we process any queued batches before changing mode ProcessBatches; FSchedLoadMode := Value; end; procedure TJvTFScheduleManager.AddToBatch(ASched: TJvTFSched); var SchedID: string; begin SchedID := TJvTFScheduleManager.GetScheduleID(ASched.SchedName, ASched.SchedDate); FSchedBatch.AddObject(SchedID, ASched); end; procedure TJvTFScheduleManager.ProcessBatches; var I: Integer; ASched: TJvTFSched; CompName: string; CompDate: TDate; BatchName: string; BatchStartDate: TDate; BatchEndDate: TDate; procedure UpdateCompares(ASched: TJvTFSched); begin CompName := ASched.SchedName; CompDate := ASched.SchedDate; end; procedure NewBatch(ASched: TJvTFSched); begin BatchName := ASched.SchedName; BatchStartDate := ASched.SchedDate; BatchEndDate := ASched.SchedDate; end; begin if FSchedBatch.Count = 0 then Exit; // added by Mike 1/14/01 FLoadingAppts := True; try // Prime the process (reminds me of COBOL - yuck!) ASched := TJvTFSched(FSchedBatch.Objects[0]); UpdateCompares(ASched); NewBatch(ASched); for I := 1 to FSchedBatch.Count - 1 do begin ASched := TJvTFSched(FSchedBatch.Objects[I]); if (ASched.SchedName <> CompName) or (Trunc(ASched.SchedDate) - 1 <> Trunc(CompDate)) then begin // Hit new batch. Load the current batch and then // set batch info to new batch. LoadBatch(BatchName, BatchStartDate, BatchEndDate); NewBatch(ASched); end else // Still in current batch. Update the batch end date. BatchEndDate := ASched.SchedDate; UpdateCompares(ASched); end; // Load the last batch LoadBatch(BatchName, BatchStartDate, BatchEndDate); FSchedBatch.Clear; // ADD OnBatchesProcessed EVENT HERE !! if Assigned(FOnBatchesProcessed) then FOnBatchesProcessed(Self); finally // added by Mike 1/14/01 FLoadingAppts := False; // added by Mike 1/14/01 RefreshConnections(nil); end; end; procedure TJvTFScheduleManager.LoadBatch(const BatchName: string; BatchStartDate, BatchEndDate: TDate); begin if Assigned(FOnLoadBatch) then FOnLoadBatch(Self, BatchName, BatchStartDate, BatchEndDate); end; function TJvTFScheduleManager.QueryPostAppt(Appt: TJvTFAppt): Boolean; begin Result := True; if Assigned(FOnPostApptQuery) then FOnPostApptQuery(Self, Appt, Result); end; function TJvTFScheduleManager.GetApptDisplayText(AComponent: TComponent; Appt: TJvTFAppt): string; begin if Assigned(Appt) then Result := Appt.Description else Result := ''; if Assigned(FOnGetApptDisplayText) then FOnGetApptDisplayText(Self, AComponent, Appt, Result); end; procedure TJvTFScheduleManager.SetApptDescription(Appt: TJvTFAppt; var Value: string); begin if Assigned(FOnSetApptDescription) then FOnSetApptDescription(Self, Appt, Value); end; procedure TJvTFScheduleManager.GetApptDescription(Appt: TJvTFAppt; var Value: string); begin if Assigned(FOnGetApptDescription) then FOnGetApptDescription(Self, Appt, Value); end; function TJvTFScheduleManager.GetApptClass: TJvTFApptClass; begin Result := TJvTFAppt; end; function TJvTFScheduleManager.GetSchedClass: TJvTFSchedClass; begin Result := TJvTFSched; end; procedure TJvTFScheduleManager.ReconcileRefresh(Scope: TObject); var Appt: TJvTFAppt; Sched: TJvTFSched; I: Integer; begin if Scope is TJvTFAppt then begin Appt := TJvTFAppt(Scope); if not Appt.Refreshed then Appt.ClearSchedules; end else if Scope is TJvTFSched then begin Sched := TJvTFSched(Scope); I := 0; while I < Sched.ApptCount do begin Appt := Sched.Appts[I]; if not Appt.Refreshed then Appt.ClearSchedules else Inc(I); end; end else if Scope is TJvTFScheduleManager then for I := 0 to ApptCount - 1 do ReconcileRefresh(Appts[I]) else raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidScopeInReconcileRefresh); end; procedure TJvTFScheduleManager.SetRefreshAutoReconcile(Value: Boolean); begin FRefreshAutoReconcile := Value; end; //=== { TJvTFHint } ========================================================== constructor TJvTFHint.Create(anApptCtrl: TJvTFControl); begin inherited Create(anApptCtrl); FApptCtrl := anApptCtrl; FTimer := TTimer.Create(Self); FShortPause := 1000; FPause := 3000; FTimer.OnTimer := @TimerOnTimer; PrepTimer(True); end; destructor TJvTFHint.Destroy; begin FTimer.Free; inherited Destroy; end; procedure TJvTFHint.SetPause(Value: Integer); begin FPause := Value; end; procedure TJvTFHint.SetShortPause(Value: Integer); begin FShortPause := Value; end; procedure TJvTFHint.TimerOnTimer(Sender: TObject); begin FTimer.Enabled := False; if FShortTimer then DoHint(False) else begin ReleaseHandle; PrepTimer(True); end; end; procedure TJvTFHint.PrepTimer(Short: Boolean); begin ReleaseHandle; FShortTimer := Short; if Short then FTimer.Interval := FShortPause else FTimer.Interval := FPause; end; procedure TJvTFHint.SetHintText(StartDate, EndDate: TDate; StartTime, EndTime: TTime; const Desc: string; ShowDatesTimes, ShowDesc: Boolean); var ShowDates: Boolean; HintText, DFormat, TFormat: string; begin HintText := ''; if ShowDatesTimes then begin DFormat := FApptCtrl.DateFormat; TFormat := FApptCtrl.TimeFormat; ShowDates := Trunc(StartDate) <> Trunc(EndDate); if ShowDates then HintText := FormatDateTime(DFormat, StartDate) + ' '; HintText := HintText + FormatDateTime(TFormat, StartTime) + ' - '; if ShowDates then HintText := HintText + FormatDateTime(DFormat, EndDate) + ' '; HintText := HintText + FormatDateTime(TFormat, EndTime); end; if ShowDesc then begin if HintText <> '' then HintText := HintText + #13#10; HintText := HintText + Desc; end; FHintText := HintText; end; procedure TJvTFHint.DoHint(Sustained: Boolean); var Ref: TObject; begin PropertyCheck; { If Assigned(FOnShowHint) Then FOnShowHint(Self, HintType, FHintRect, FHintText); } if Assigned(FOnShowHint) then begin if HintType = shtAppt then Ref := FOldAppt else if HintType = shtObj then Ref := FOldObj else Ref := nil; FOnShowHint(Self, HintType, Ref, FHintRect, FHintText); end; // if not Windows.IsRectEmpty(FHintRect) and (FHintText <> '') then if not IsRectEmpty(FHintRect) and (FHintText <> '') then if Sustained then begin inherited ActivateHint(FHintRect, FHintText); end else ActivateHint(FHintRect, FHintText); end; procedure TJvTFHint.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); { wp --- to do with Params do begin WindowClass.Style := WindowClass.Style and not CS_SAVEBITS; end; } end; procedure TJvTFHint.ActivateHint(Rect: TRect; const AHint: THintString); begin PrepTimer(False); inherited ActivateHint(Rect, AHint); // Reset the timer so we get the full interval FTimer.Enabled := False; FTimer.Enabled := True; end; procedure TJvTFHint.ApptHint(Appt: TJvTFAppt; X, Y: Integer; ShowDatesTimes, ShowDesc, FormattedDesc: Boolean; const ExtraDesc: string = ''); var HintTopLeft: TPoint; Immediate: Boolean; ApptDesc: string; begin if Appt <> FOldAppt then begin FHintType := shtAppt; Immediate := not FShortTimer; FHintCell := Point(-100, -100); FOldAppt := Appt; if Assigned(Appt) then begin ApptDesc := Appt.Description; if not FormattedDesc then ApptDesc := StripCRLF(ApptDesc); ApptDesc := ExtraDesc + ApptDesc; SetHintText(Appt.StartDate, Appt.EndDate, Appt.StartTime, Appt.EndTime, ApptDesc, ShowDatesTimes, ShowDesc); FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil); HintTopLeft := FApptCtrl.ClientToScreen(Point(X, Y)); FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y); if Immediate then DoHint(False) else begin PrepTimer(True); FTimer.Enabled := True; end; end else begin ReleaseHandle; PrepTimer(True); end; end; end; procedure TJvTFHint.StartEndHint(StartDate, EndDate: TDate; StartTime, EndTime: TTime; X, Y: Integer; ShowDates: Boolean); var HintTopLeft: TPoint; begin FHintType := shtStartEnd; SetHintText(StartDate, EndDate, StartTime, EndTime, '', True, False); FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil); HintTopLeft := FApptCtrl.ClientToScreen(Point(X, Y)); FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y); if HandleAllocated and Showing then BoundsRect := FHintRect else DoHint(True); end; procedure TJvTFHint.CellHint(Row, Col: Integer; const HintText: string; CellRect: TRect); var Immediate: Boolean; DiffCell: Boolean; begin DiffCell := (Row <> FHintCell.Y) or (Col <> FHintCell.X); if DiffCell or not FTimer.Enabled then begin FHintType := shtCell; FOldAppt := nil; ReleaseHandle; FHintCell.X := Col; FHintCell.Y := Row; Immediate := not FShortTimer; FHintText := HintText; //If (FHintText <> '') and DiffCell Then if FHintText <> '' then begin CellRect.TopLeft := FApptCtrl.ClientToScreen(CellRect.TopLeft); CellRect.BottomRight := FApptCtrl.ClientToScreen(CellRect.BottomRight); FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil); FHintRect := CenterRect(CellRect, FHintRect); if Immediate then DoHint(False) else begin PrepTimer(True); FTimer.Enabled := True; end; end else begin ReleaseHandle; PrepTimer(True); end; end; end; procedure TJvTFHint.ReleaseHandle; begin FTimer.Enabled := False; DestroyHandle; end; procedure TJvTFHint.PropertyCheck; begin if Assigned(RefProps) then begin if RefProps.HintColor = clDefault then Color := Application.HintColor else Color := RefProps.HintColor; if RefProps.HintHidePause = -1 then Pause := Application.HintHidePause else Pause := RefProps.HintHidePause; if RefProps.HintPause = -1 then ShortPause := Application.HintPause else ShortPause := RefProps.HintPause; end; end; procedure TJvTFHint.MultiLineObjHint(Obj: TObject; X, Y: Integer; Hints: TStrings); var Immediate: Boolean; HintTopLeft: TPoint; begin if Obj <> FOldObj then begin FOldAppt := nil; FHintType := shtObj; Immediate := not FShortTimer; FHintCell := Point(-100, -100); FOldObj := Obj; if Assigned(Obj) and (Hints.Count > 0) then begin FHintText := Hints.Text; FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil); HintTopLeft := FApptCtrl.ClientToScreen(Point(X + 8, Y + 16)); FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y); if Immediate then DoHint(False) else begin PrepTimer(True); FTimer.Enabled := True; end; end else begin ReleaseHandle; PrepTimer(True); end; end; end; //=== { TJvTFControl } ======================================================= constructor TJvTFControl.Create(AOwner: TComponent); begin inherited Create(AOwner); FSchedules := TStringList.Create; FTimeFormat := 't'; // global short time format FDateFormat := 'ddddd'; // global short date format end; destructor TJvTFControl.Destroy; begin ScheduleManager := nil; FSchedules.Free; inherited Destroy; end; procedure TJvTFControl.SetManager(Value: TJvTFScheduleManager); begin if Value <> FScheduleManager then begin if Assigned(FScheduleManager) then FScheduleManager.Notify(Self, sncDisconnectControl); FScheduleManager := nil; if Assigned(Value) then Value.Notify(Self, sncConnectControl); FScheduleManager := Value; end; end; function TJvTFControl.GetSchedule(Index: Integer): TJvTFSched; begin Result := TJvTFSched(FSchedules.Objects[Index]); end; procedure TJvTFControl.SetDateFormat(const Value: string); begin if FDateFormat <> Value then begin FDateFormat := Value; Invalidate; end; end; procedure TJvTFControl.SetTimeFormat(const Value: string); begin if FTimeFormat <> Value then begin FTimeFormat := Value; Invalidate; end; end; procedure TJvTFControl.Notify(Sender: TObject; Code: TJvTFServNotifyCode); begin case Code of sncRequestSchedule: ReqSchedNotification(TJvTFSched(Sender)); sncReleaseSchedule: RelSchedNotification(TJvTFSched(Sender)); sncRefresh: RefreshControl; sncDestroyAppt: DestroyApptNotification(TJvTFAppt(Sender)); sncDestroySchedule: DestroySchedNotification(TJvTFSched(Sender)); end; end; procedure TJvTFControl.ReqSchedNotification(Schedule: TJvTFSched); var SchedID: string; begin SchedID := TJvTFScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate); if FSchedules.IndexOf(SchedID) = -1 then FSchedules.AddObject(SchedID, Schedule); end; procedure TJvTFControl.RelSchedNotification(Schedule: TJvTFSched); var I: Integer; begin I := FSchedules.IndexOfObject(Schedule); if I > -1 then FSchedules.Delete(I); end; procedure TJvTFControl.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Serv) then Serv.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc); end; procedure TJvTFControl.CNRequestRefresh(var Msg: TCNRequestRefresh); begin Invalidate; end; procedure TJvTFControl.RefreshControl; begin Invalidate; end; procedure TJvTFControl.DestroyApptNotification(anAppt: TJvTFAppt); begin // do nothing, leave implementation to successors end; procedure TJvTFControl.DestroySchedNotification(ASched: TJvTFSched); begin // do nothing, leave implementation to successors end; procedure TJvTFControl.DoStartDrag(var DragObject: TDragObject); begin inherited DoStartDrag(DragObject); FDragInfo := TJvTFDragInfo.Create; with FDragInfo do begin ApptCtrl := Self; Shift := Self.FShift; end; { Originally, a specific drag object was created and given to the DragObject param. This worked fine. Because of differences in the VCL DragObject hierarachy between D3 and D4, the decision was made to move away from using a drag object. FDragAppt := TDragAppt.Create(Self); With FDragAppt do Begin ApptCtrl := Self; Schedule := SelSchedule; Appt := SelAppt; Shift := FDragShift; End; DragObject := FDragAppt; } end; procedure TJvTFControl.DoEndDrag(Target: TObject; X, Y: Integer); begin inherited DoEndDrag(Target, X, Y); FDragInfo.Free; FDragInfo := nil; end; procedure TJvTFControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseDown(Button, Shift, X, Y); FShift := Shift; end; function TJvTFControl.ScheduleCount: Integer; begin Result := FSchedules.Count; end; function TJvTFControl.FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; var I: Integer; begin Result := nil; I := FSchedules.IndexOf(TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate)); if I > -1 then Result := TJvTFSched(FSchedules.Objects[I]); end; function TJvTFControl.RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; begin Result := FindSchedule(SchedName, SchedDate); if not Assigned(Result) then if Assigned(ScheduleManager) then Result := ScheduleManager.RequestSchedule(Self, SchedName, SchedDate) else raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotRetrieveSchedule); end; procedure TJvTFControl.ReleaseSchedule(const SchedName: string; SchedDate: TDate); var SchedID: string; begin if Assigned(ScheduleManager) then begin SchedID := TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate); if FSchedules.IndexOf(SchedID) > -1 then ScheduleManager.ReleaseSchedule(Self, SchedName, SchedDate) end; { wp: original code - crashes sometimes at program end in GetScheduleID when ScheduleManager is nil SchedID := TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate); if FSchedules.IndexOf(SchedID) > -1 then if Assigned(ScheduleManager) then ScheduleManager.ReleaseSchedule(Self, SchedName, SchedDate) else raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotReleaseSchedule); } end; procedure TJvTFControl.ReleaseSchedules; begin while ScheduleCount > 0 do ReleaseSchedule(Schedules[0].SchedName, Schedules[0].SchedDate); end; procedure TJvTFControl.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); // If (AComponent = Navigator) and (Operation = opRemove) Then // Navigator := nil; end; //procedure TJvTFControl.SetNavigator(Value: TJvTFNavigator); //begin // If Value <> FNavigator Then // Begin // If Assigned(FNavigator) Then // FNavigator.UnregisterControl(Self); // FNavigator := nil; // // If Assigned(Value) Then // Value.RegisterControl(Self); // FNavigator := Value; // End; //end; procedure TJvTFControl.Navigate(aControl: TJvTFControl; SchedNames: TStringList; Dates: TJvTFDateList); begin // If Assigned(FOnNavigate) Then // FOnNavigate(Self, aControl, SchedNames, Dates); end; procedure TJvTFControl.ProcessBatches; begin if Assigned(ScheduleManager) and (ScheduleManager.SchedLoadMode = slmBatch) then ScheduleManager.ProcessBatches; end; //=== { TJvTFComponent } ===================================================== constructor TJvTFComponent.Create(AOwner: TComponent); begin inherited Create(AOwner); FSchedules := TStringList.Create; FTimeFormat := 't'; // global short time format FDateFormat := 'ddddd'; // global short date format end; destructor TJvTFComponent.Destroy; begin ScheduleManager := nil; FSchedules.Free; inherited Destroy; end; procedure TJvTFComponent.DestroyApptNotification(anAppt: TJvTFAppt); begin // do nothing, leave implementation to descendants end; procedure TJvTFComponent.DestroySchedNotification(ASched: TJvTFSched); begin // do nothing, leave implementation to descendants end; function TJvTFComponent.FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; var I: Integer; begin Result := nil; I := FSchedules.IndexOf(TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate)); if I > -1 then Result := TJvTFSched(FSchedules.Objects[I]); end; function TJvTFComponent.GetSchedule(Index: Integer): TJvTFSched; begin Result := TJvTFSched(FSchedules.Objects[Index]); end; procedure TJvTFComponent.Notify(Sender: TObject; Code: TJvTFServNotifyCode); begin case Code of sncRequestSchedule: ReqSchedNotification(TJvTFSched(Sender)); sncReleaseSchedule: RelSchedNotification(TJvTFSched(Sender)); sncRefresh: RefreshComponent; sncDestroyAppt: DestroyApptNotification(TJvTFAppt(Sender)); sncDestroySchedule: DestroySchedNotification(TJvTFSched(Sender)); end; end; procedure TJvTFComponent.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject; Code: TJvTFServNotifyCode); begin if Assigned(Serv) then Serv.Notify(Sender, Code) else raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc); end; procedure TJvTFComponent.ProcessBatches; begin if Assigned(ScheduleManager) and (ScheduleManager.SchedLoadMode = slmBatch) then ScheduleManager.ProcessBatches; end; procedure TJvTFComponent.RefreshComponent; begin // do nothing, leave implementation to descendants end; procedure TJvTFComponent.ReleaseSchedule(const SchedName: string; SchedDate: TDate); var SchedID: string; begin SchedID := TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate); if FSchedules.IndexOf(SchedID) > -1 then if Assigned(ScheduleManager) then ScheduleManager.ReleaseSchedule(Self, SchedName, SchedDate) else raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotReleaseSchedule); end; procedure TJvTFComponent.ReleaseSchedules; begin while ScheduleCount > 0 do ReleaseSchedule(Schedules[0].SchedName, Schedules[0].SchedDate); end; procedure TJvTFComponent.RelSchedNotification(Schedule: TJvTFSched); var I: Integer; begin I := FSchedules.IndexOfObject(Schedule); if I > -1 then FSchedules.Delete(I); end; procedure TJvTFComponent.ReqSchedNotification(Schedule: TJvTFSched); var SchedID: string; begin SchedID := TJvTFScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate); if FSchedules.IndexOf(SchedID) = -1 then FSchedules.AddObject(SchedID, Schedule); end; function TJvTFComponent.RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched; begin Result := FindSchedule(SchedName, SchedDate); if not Assigned(Result) then if Assigned(ScheduleManager) then Result := ScheduleManager.RequestSchedule(Self, SchedName, SchedDate) else raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotRetrieveSchedule); end; function TJvTFComponent.ScheduleCount: Integer; begin Result := FSchedules.Count; end; procedure TJvTFComponent.SetDateFormat(const Value: string); begin FDateFormat := Value; end; procedure TJvTFComponent.SetManager(Value: TJvTFScheduleManager); begin if Value <> FScheduleManager then begin if Assigned(FScheduleManager) then FScheduleManager.Notify(Self, sncDisconnectComponent); FScheduleManager := nil; if Assigned(Value) then Value.Notify(Self, sncConnectComponent); FScheduleManager := Value; end; end; procedure TJvTFComponent.SetTimeFormat(const Value: string); begin FTimeFormat := Value; end; procedure TJvTFComponent.UpdateDesigner; var ParentForm: TCustomForm; begin if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then begin try ParentForm := TCustomForm(Owner); if Assigned(ParentForm) and Assigned(ParentForm.Designer) then ParentForm.Designer.Modified; except // handle the exception by doing nothing end; end; end; //=== { TJvTFPrinter } ======================================================= constructor TJvTFPrinter.Create(AOwner: TComponent); begin inherited Create(AOwner); CreateLayout; FMeasure := pmInches; FPages := TStringList.Create; FBodies := TStringList.Create; InitializeMargins; end; destructor TJvTFPrinter.Destroy; begin FreeDoc; FBodies.Free; FPages.Free; FPageLayout.Free; inherited Destroy; end; procedure TJvTFPrinter.AbortPrint; begin if Printer.Printing then Printer.Abort else FAborted := True; end; function TJvTFPrinter.ConvertMeasure(Value: Integer; FromMeasure, ToMeasure: TJvTFPrinterMeasure; Horizontal: Boolean): Integer; const MMFactor = 2.54; var PPI: Integer; begin if Horizontal then PPI := Printer.XDPI else PPI := Printer.YDPI; if (FromMeasure = pmPixels) and (ToMeasure = pmInches) then Result := round(Value / PPI * 100) else if (FromMeasure = pmPixels) and (ToMeasure = pmMM) then Result := round(Value / PPI * 100 * MMFactor) else if (FromMeasure = pmInches) and (ToMeasure = pmPixels) then Result := round(Value / 100 * PPI) else if (FromMeasure = pmInches) and (ToMeasure = pmMM) then Result := round(Value * MMFactor) else if (FromMeasure = pmMM) and (ToMeasure = pmPixels) then Result := round(Value / MMFactor / 100 * PPI) else if (FromMeasure = pmMM) and (ToMeasure = pmInches) then Result := round(Value / MMFactor) else Result := Value; end; procedure TJvTFPrinter.CreateDoc; begin if State = spsNoDoc then begin FState := spsCreating; FAborted := False; FDocDateTime := Now; if DirectPrint then Printer.BeginDoc; end else raise EJvTFPrinterError.CreateRes(@RsECouldNotCreateADocumentBecauseA); end; procedure TJvTFPrinter.CreateLayout; begin FPageLayout := TJvTFPrinterPageLayout.Create(Self); end; procedure TJvTFPrinter.DrawBody(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); begin if Assigned(FOnDrawBody) then FOnDrawBody(Self, aCanvas, ARect, PageNum); end; procedure TJvTFPrinter.DrawFooter(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); begin if Assigned(FOnDrawFooter) then FOnDrawFooter(Self, aCanvas, ARect, PageNum); end; procedure TJvTFPrinter.DrawHeader(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); begin if Assigned(FOnDrawHeader) then FOnDrawHeader(Self, aCanvas, ARect, PageNum); end; procedure TJvTFPrinter.FinishDoc; var I: Integer; { wp --- to do aCanvas: TMetafileCanvas; } HeaderRect, FooterRect: TRect; begin if Aborted then Exit; if State <> spsCreating then raise EJvTFPrinterError.CreateRes(@RsECouldNotFinishDocumentBecauseNo); FPageCount := FBodies.Count; FState := spsAssembling; try if Assigned(FOnAssembleProgress) then FOnAssembleProgress(Self, 0, FBodies.Count); if DirectPrint then Printer.EndDoc else begin GetHeaderFooterRects(HeaderRect, FooterRect); I := 0; while (I < FBodies.Count) and not Aborted do begin { wp --- to do ... aCanvas := TMetafileCanvas(FBodies.Objects[I]); try DrawHeader(aCanvas, HeaderRect, I + 1); DrawFooter(aCanvas, FooterRect, I + 1); finally aCanvas.Free; FBodies.Objects[I] := nil; end; } if Assigned(FOnAssembleProgress) then FOnAssembleProgress(Self, I + 1, FBodies.Count); Inc(I); Application.ProcessMessages; end; end; FBodies.Clear; finally FState := spsFinished; end; end; procedure TJvTFPrinter.FreeDoc; begin while FBodies.Count > 0 do begin FBodies.Objects[0].Free; FBodies.Delete(0); end; while FPages.Count > 0 do begin FPages.Objects[0].Free; FPages.Delete(0); end; FState := spsNoDoc; end; function TJvTFPrinter.GetBodyHeight: Integer; // always in pixels var PhysHeight, TopMarginPels, BottomMarginPels, HeaderPels, FooterPels: Integer; begin { wp --- to do **************** DONE *************** PhysHeight := Windows.GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT); } PhysHeight := Printer.PaperSize.Height; TopMarginPels := ConvertMeasure(PageLayout.MarginTop, Measure, pmPixels, False); BottomMarginPels := ConvertMeasure(PageLayout.MarginBottom, Measure, pmPixels, False); HeaderPels := ConvertMeasure(PageLayout.HeaderHeight, Measure, pmPixels, False); FooterPels := ConvertMeasure(PageLayout.FooterHeight, Measure, pmPixels, False); Result := PhysHeight - TopMarginPels - BottomMarginPels - HeaderPels - FooterPels; end; function TJvTFPrinter.GetBodyLeft: Integer; // always in pixels begin Result := GetMarginOffset(1); end; function TJvTFPrinter.GetBodyTop: Integer; // always in pixels begin Result := GetMarginOffset(2) + ConvertMeasure(PageLayout.HeaderHeight, Measure, pmPixels, False) + 1; end; function TJvTFPrinter.GetBodyWidth: Integer; // always in pixels var PhysWidth, LeftMarginPels, RightMarginPels: Integer; begin { wp --- to do **************** DONE ***************** PhysWidth := Windows.GetDeviceCaps(Printer.Handle, PHYSICALWIDTH); } PhysWidth := Printer.PaperSize.Width; LeftMarginPels := ConvertMeasure(PageLayout.MarginLeft, Measure, pmPixels, True); RightMarginPels := ConvertMeasure(PageLayout.MarginRight, Measure, pmPixels, True); Result := PhysWidth - LeftMarginPels - RightMarginPels; end; function TJvTFPrinter.GetDocDateTime: TDateTime; begin if State = spsNoDoc then raise EJvTFPrinterError.CreateRes(@RsEDocumentDoesNotExist); Result := FDocDateTime; end; procedure TJvTFPrinter.GetHeaderFooterRects(out HeaderRect, FooterRect: TRect); begin HeaderRect.Left := FMarginOffsets.Left; HeaderRect.Top := FMarginOffsets.Top; HeaderRect.Right := HeaderRect.Left + BodyWidth; HeaderRect.Bottom := HeaderRect.Top + ConvertMeasure(PageLayout.HeaderHeight, Measure, pmPixels, False); FooterRect.Left := HeaderRect.Left; FooterRect.Right := HeaderRect.Right; FooterRect.Top := BodyTop + BodyHeight; FooterRect.Bottom := FooterRect.Top + ConvertMeasure(PageLayout.FooterHeight, Measure, pmPixels, False); end; function TJvTFPrinter.GetMarginOffset(Index: Integer): Integer; begin case Index of 1: Result := FMarginOffsets.Left; 2: Result := FMarginOffsets.Top; 3: Result := FMarginOffsets.Right; else Result := FMarginOffsets.Bottom; end; end; function TJvTFPrinter.GetPage(Index: Integer): TBitmap; // was: TMetafile; begin if DirectPrint then raise EJvTFPrinterError.CreateRes(@RsEDocumentPagesCannotBeAccessedIf); if State <> spsFinished then raise EJvTFPrinterError.CreateRes(@RsEDocumentPagesAreInaccessibleUntil); // Result := TMetafile(FPages.Objects[Index]); Result := TBitmap(FPages.Objects[Index]); end; function TJvTFPrinter.GetPageCount: Integer; begin case State of spsNoDoc: raise EJvTFPrinterError.CreateRes(@RsECouldNotRetrievePageCount); spsCreating: Result := FBodies.Count; spsAssembling: Result := FPageCount; spsFinished: Result := FPages.Count; else Result := -1; end; end; function TJvTFPrinter.GetUnprintable: TJvTFMargins; var LeftMarg, TopMarg, WidthPaper, HeightPaper, WidthPrintable, HeightPrintable: Integer; begin { wp --- to do ----------- DONE ---------------- LeftMarg := Windows.GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); TopMarg := Windows.GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); WidthPaper := Windows.GetDeviceCaps(Printer.Handle, PHYSICALWIDTH); HeightPaper := Windows.GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT); } LeftMarg := Printer.PaperSize.PaperRect.WorkRect.Left; TopMarg := Printer.PaperSize.PaperRect.WorkRect.Top; WidthPaper := Printer.PaperSize.Width; HeightPaper := Printer.PaperSize.Height; WidthPrintable := Printer.PageWidth; HeightPrintable := Printer.PageHeight; with Result do begin Left := LeftMarg; Top := TopMarg; Right := WidthPaper - WidthPrintable - LeftMarg; Bottom := HeightPaper - HeightPrintable - TopMarg; end; end; procedure TJvTFPrinter.InitializeMargins; var I, Unprintable, NewMargin: Integer; Horz: Boolean; begin for I := 1 to 4 do begin SetMarginOffset(I, 0); case I of 1: Unprintable := GetUnprintable.Left; 2: Unprintable := GetUnprintable.Top; 3: Unprintable := GetUnprintable.Right; else Unprintable := GetUnprintable.Bottom; end; Horz := (I = 1) or (I = 3); NewMargin := ConvertMeasure(Unprintable, pmPixels, Measure, Horz); case I of 1: PageLayout.FMargins.Left := NewMargin; 2: PageLayout.FMargins.Top := NewMargin; 3: PageLayout.FMargins.Right := NewMargin; else PageLayout.FMargins.Bottom := NewMargin; end; end; end; procedure TJvTFPrinter.MarginError; begin if Assigned(FOnMarginError) then FOnMarginError(Self); end; procedure TJvTFPrinter.NewDoc; begin FreeDoc; CreateDoc; end; procedure TJvTFPrinter.NewPage; var aBitmap: TBitmap; // wp: was Metafile, but this is not supported by Lazarus aCanvas: TCanvas; HeaderRect, FooterRect: TRect; begin if Aborted then Exit; if DirectPrint then begin if PageCount > 0 then Printer.NewPage; aCanvas := Printer.Canvas; FPages.Add(''); end else begin // Create a TBitmap for the page aBitmap := TBitmap.Create; aBitmap.SetSize(Printer.PaperSize.Width, Printer.PaperSize.Height); aBitmap.Canvas.Brush.Color := clWhite; aBitmap.Canvas.FillRect(0, 0, aBitmap.Width, aBitmap.Height); FPages.AddObject('', aBitmap); // Store the canvas in FBodies so we can retrieve it later to draw // the header and footer. aCanvas := aBitmap.Canvas; { // Create a TMetafile for the page aMetafile := TMetafile.Create; FPages.AddObject('', aMetafile); // Create a TMetafileCanvas as a canvas for the page. // Store the canvas in FBodies so we can retrieve it later to draw // the header and footer. aCanvas := TMetafileCanvas.Create(aMetafile, Printer.Handle); } end; FBodies.AddObject('', aCanvas); aCanvas.Font.PixelsPerInch := Printer.XDPI; FixFont(aCanvas.Font); { aCanvas.Font.PixelsPerInch := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX); } LCLIntf.SetViewportOrgEx(aCanvas.Handle, BodyLeft, BodyTop, nil); DrawBody(aCanvas, Rect(BodyLeft, BodyTop, BodyWidth - BodyLeft, BodyHeight - BodyTop), FPages.Count); LCLIntf.SetViewPortOrgEx(aCanvas.Handle, 0, 0, nil); if DirectPrint then begin GetHeaderFooterRects(HeaderRect, FooterRect); DrawHeader(aCanvas, HeaderRect, PageCount); DrawFooter(aCanvas, FooterRect, PageCount); end; end; procedure TJvTFPrinter.Print; var I: Integer; begin if Aborted or DirectPrint then Exit; if State <> spsFinished then raise EJvTFPrinterError.CreateRes(@RsEOnlyAFinishedDocumentCanBePrinted); if PageCount = 0 then raise EJvTFPrinterError.CreateRes(@RsEThereAreNoPagesToPrint); if Assigned(FOnPrintProgress) then FOnPrintProgress(Self, 0, PageCount); Application.ProcessMessages; Printer.Title := Title; Printer.BeginDoc; if not Printer.Aborted then Printer.Canvas.Draw(0, 0, Pages[0]); if Assigned(FOnPrintProgress) then FOnPrintProgress(Self, 1, PageCount); Application.ProcessMessages; I := 1; while (I < PageCount) and not Printer.Aborted do begin if not Printer.Aborted then Printer.NewPage; if not Printer.Aborted then Printer.Canvas.Draw(0, 0, Pages[I]); Inc(I); if Assigned(FOnPrintProgress) then FOnPrintProgress(Self, I, PageCount); Application.ProcessMessages; end; if not Printer.Aborted then Printer.EndDoc; end; function TJvTFPrinter.PrinterToScreen(Value: Integer; Horizontal: Boolean): Integer; var ScreenPPI, PrinterPPI: Integer; begin { wp --- to do ************* DONE ************ ScreenPPI := Screen.PixelsPerInch; if Horizontal then PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX) else PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSY); } ScreenPPI := Screen.PixelsPerInch; if Horizontal then PrinterPPI := Printer.XDPI else PrinterPPI := Printer.YDPI; Result := Trunc(ScreenPPI / PrinterPPI * Value); end; procedure TJvTFPrinter.SaveDocToFiles(BaseFileName: TFileName); {var I: Integer; } begin if State <> spsFinished then raise EJvTFPrinterError.CreateRes(@RsEDocumentMustBeFinishedToSaveToFile); { wp --- to do for I := 0 to PageCount - 1 do Pages[I].SaveToFile(BaseFileName + '_' + IntToStr(I + 1) + '.emf'); } end; function TJvTFPrinter.ScreenToPrinter(Value: Integer; Horizontal: Boolean): Integer; var ScreenPPI, PrinterPPI: Integer; begin ScreenPPI := Screen.PixelsPerInch; if Horizontal then PrinterPPI := Printer.XDPI else PrinterPPI := Printer.YDPI; { wp --- to do *********** DONE *********** if Horizontal then PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX) else PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSY); } Result := Trunc(PrinterPPI / ScreenPPI * Value); end; procedure TJvTFPrinter.SetDirectPrint(Value: Boolean); begin SetPropertyCheck; FDirectPrint := Value; end; procedure TJvTFPrinter.SetMarginOffset(Index, Value: Integer); begin // Allow negative value... // SetMargin will catch that case and throw exception case Index of 1: FMarginOffsets.Left := Value; 2: FMarginOffsets.Top := Value; 3: FMarginOffsets.Right := Value; else FMarginOffsets.Bottom := Value; end; end; procedure TJvTFPrinter.SetMeasure(Value: TJvTFPrinterMeasure); begin try FConvertingProps := True; if Value <> FMeasure then begin PageLayout.FHeaderHeight := ConvertMeasure(PageLayout.FHeaderHeight, FMeasure, Value, False); PageLayout.FFooterHeight := ConvertMeasure(PageLayout.FFooterHeight, FMeasure, Value, False); PageLayout.FMargins.Left := ConvertMeasure(PageLayout.FMargins.Left, FMeasure, Value, True); PageLayout.FMargins.Right := ConvertMeasure(PageLayout.FMargins.Right, FMeasure, Value, True); PageLayout.FMargins.Top := ConvertMeasure(PageLayout.FMargins.Top, FMeasure, Value, False); PageLayout.FMargins.Bottom := ConvertMeasure(PageLayout.FMargins.Bottom, FMeasure, Value, False); FMeasure := Value; end; finally FConvertingProps := False; end; end; procedure TJvTFPrinter.SetPageLayout(Value: TJvTFPrinterPageLayout); begin FPageLayout.Assign(Value); end; procedure TJvTFPrinter.SetPropertyCheck; begin if (State <> spsNoDoc) and not ConvertingProps then raise EJvTFPrinterError.CreateRes(@RsEThisPropertyCannotBeChangedIfA); end; procedure TJvTFPrinter.SetTitle(const Value: string); begin FTitle := Value; end; //=== { TJvTFPrinterPageLayout } ============================================= constructor TJvTFPrinterPageLayout.Create(aPrinter: TJvTFPrinter); begin inherited Create; if not Assigned(aPrinter) then raise EJvTFPrinterError.CreateRes(@RsECouldNotCreateTJvTFPrinterPageLayou); FPrinter := aPrinter; FMargins.Left := 25; FMargins.Right := 25; FMargins.Top := 17; FMargins.Bottom := 63; end; procedure TJvTFPrinterPageLayout.Assign(Source: TPersistent); var SourceMeas, DestMeas: TJvTFPrinterMeasure; WorkVal: Integer; SourceLayout: TJvTFPrinterPageLayout; begin if (Source is TJvTFPrinterPageLayout) then begin if not Assigned(Printer) or not Assigned(TJvTFPrinterPageLayout(Source).Printer) then Exit; // raise? SourceLayout := TJvTFPrinterPageLayout(Source); SourceMeas := SourceLayout.Printer.Measure; DestMeas := Printer.Measure; WorkVal := SourceLayout.MarginLeft; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, True); SetMargin(1, WorkVal); WorkVal := SourceLayout.MarginTop; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False); SetMargin(2, WorkVal); WorkVal := SourceLayout.MarginRight; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, True); SetMargin(3, WorkVal); WorkVal := SourceLayout.MarginBottom; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False); SetMargin(4, WorkVal); WorkVal := SourceLayout.HeaderHeight; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False); SetHeaderHeight(WorkVal); WorkVal := SourceLayout.FooterHeight; WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False); SetFooterHeight(WorkVal); end else inherited Assign(Source); end; procedure TJvTFPrinterPageLayout.Change; begin // do nothing, leave to descendants end; function TJvTFPrinterPageLayout.GetMargin(Index: Integer): Integer; begin case Index of 1: Result := FMargins.Left; 2: Result := FMargins.Top; 3: Result := FMargins.Right; else Result := FMargins.Bottom; end; end; procedure TJvTFPrinterPageLayout.SetFooterHeight(Value: Integer); var Check: Integer; begin SetPropertyCheck; if Value < 0 then Value := 0; if Value <> FFooterHeight then begin Check := FFooterHeight; FFooterHeight := Value; if Printer.BodyHeight < 1 then begin FFooterHeight := Check; raise EJvTFPrinterError.CreateResFmt(@RsEInvalidFooterHeightd, [Value]); end else Change; end; end; procedure TJvTFPrinterPageLayout.SetHeaderHeight(Value: Integer); var Check: Integer; begin SetPropertyCheck; if Value < 0 then Value := 0; if Value <> FHeaderHeight then begin Check := FHeaderHeight; FHeaderHeight := Value; if Printer.BodyHeight < 1 then begin FHeaderHeight := Check; raise EJvTFPrinterError.CreateResFmt(@RsEInvalidHeaderHeightd, [Value]); end else Change; end; end; procedure TJvTFPrinterPageLayout.SetMargin(Index, Value: Integer); var Unprintable, UserMarginPels, CurrMargin, NewMargin: Integer; Horz, Err: Boolean; begin SetPropertyCheck; CurrMargin := GetMargin(Index); if Value <> CurrMargin then begin Horz := (Index = 1) or (Index = 3); case Index of 1: Unprintable := Printer.GetUnprintable.Left; 2: Unprintable := Printer.GetUnprintable.Top; 3: Unprintable := Printer.GetUnprintable.Right; else Unprintable := Printer.GetUnprintable.Bottom; end; UserMarginPels := Printer.ConvertMeasure(Value, Printer.Measure, pmPixels, Horz); Printer.SetMarginOffset(Index, UserMarginPels - Unprintable); if Printer.GetMarginOffset(Index) >= 0 then begin Err := False; NewMargin := Value; end else begin Err := True; Printer.SetMarginOffset(Index, 0); NewMargin := Printer.ConvertMeasure(Unprintable, pmPixels, Printer.Measure, Horz); end; if not Err then case Index of 1: FMargins.Left := NewMargin; 2: FMargins.Top := NewMargin; 3: FMargins.Right := NewMargin; else FMargins.Bottom := NewMargin; end else //SetMargin(Index, NewMargin); case Index of 1: MarginLeft := NewMargin; 2: MarginTop := NewMargin; 3: MarginRight := NewMargin; else MarginBottom := NewMargin; end; if Err and Assigned(Printer) then begin Printer.UpdateDesigner; Printer.MarginError; end; Change; end; end; procedure TJvTFPrinterPageLayout.SetPropertyCheck; begin Printer.SetPropertyCheck; end; //=== { TJvTFUniversalPrinter } ============================================== procedure TJvTFUniversalPrinter.CreateDoc; begin inherited CreateDoc; end; procedure TJvTFUniversalPrinter.FinishDoc; begin inherited FinishDoc; end; procedure TJvTFUniversalPrinter.NewDoc; begin inherited NewDoc; end; procedure TJvTFUniversalPrinter.NewPage; begin inherited NewPage; end; //=== { TJvTFHintProps } ===================================================== constructor TJvTFHintProps.Create(AOwner: TJvTFControl); begin inherited Create; FControl := AOwner; FHintColor := clDefault; FHintHidePause := -1; FHintPause := -1; end; procedure TJvTFHintProps.Assign(Source: TPersistent); begin if Source is TJvTFHint then begin FHintColor := TJvTFHintProps(Source).HintColor; FHintHidePause := TJvTFHintProps(Source).HintHidePause; FHintPause := TJvTFHintProps(Source).HintPause; Change; end else inherited Assign(Source); end; procedure TJvTFHintProps.Change; begin // do nothing end; procedure TJvTFHintProps.SetHintColor(Value: TColor); begin if Value <> FHintColor then begin FHintColor := Value; Change; end; end; procedure TJvTFHintProps.SetHintHidePause(Value: Integer); begin if Value < -1 then Value := -1; if Value <> FHintHidePause then begin FHintHidePause := Value; Change; end; end; procedure TJvTFHintProps.SetHintPause(Value: Integer); begin if Value < -1 then Value := -1; if Value <> HintPause then begin FHintPause := Value; Change; end; end; //=== { TJvTFDWNames } ======================================================= constructor TJvTFDWNames.Create; begin inherited Create; FSource := dwnsSysShort; FDWN_Sunday := 'S'; FDWN_Monday := 'M'; FDWN_Tuesday := 'T'; FDWN_Wednesday := 'W'; FDWN_Thursday := 'T'; FDWN_Friday := 'F'; FDWN_Saturday := 'S'; end; procedure TJvTFDWNames.Assign(Source: TPersistent); begin if Source is TJvTFDWNames then begin FDWN_Sunday := TJvTFDWNames(Source).DWN_Sunday; FDWN_Monday := TJvTFDWNames(Source).DWN_Monday; FDWN_Tuesday := TJvTFDWNames(Source).DWN_Tuesday; FDWN_Wednesday := TJvTFDWNames(Source).DWN_Wednesday; FDWN_Thursday := TJvTFDWNames(Source).DWN_Thursday; FDWN_Friday := TJvTFDWNames(Source).DWN_Friday; FDWN_Saturday := TJvTFDWNames(Source).DWN_Saturday; FSource := TJvTFDWNames(Source).Source; Change; end else inherited Assign(Source); end; procedure TJvTFDWNames.Change; begin if Assigned(FOnChange) then FOnChange(Self); end; function TJvTFDWNames.GetDWN(Index: Integer): string; begin case Index of 1: Result := FDWN_Sunday; 2: Result := FDWN_Monday; 3: Result := FDWN_Tuesday; 4: Result := FDWN_Wednesday; 5: Result := FDWN_Thursday; 6: Result := FDWN_Friday; 7: Result := FDWN_Saturday; else Result := ''; end; end; function TJvTFDWNames.GetDWName(DWIndex: Integer): string; begin case Source of dwnsSysLong: Result := FormatSettings.LongDayNames[DWIndex]; dwnsSysShort: Result := FormatSettings.ShortDayNames[DWIndex]; else // dwnsCustom Result := GetDWN(DWIndex); end; end; procedure TJvTFDWNames.SetDWN(Index: Integer; const Value: string); begin case Index of 1: FDWN_Sunday := Value; 2: FDWN_Monday := Value; 3: FDWN_Tuesday := Value; 4: FDWN_Wednesday := Value; 5: FDWN_Thursday := Value; 6: FDWN_Friday := Value; 7: FDWN_Saturday := Value; end; if Source = dwnsCustom then Change; end; procedure TJvTFDWNames.SetSource(Value: TJvTFDWNameSource); begin if Value <> FSource then begin FSource := Value; Change; end; end; //=== { TJvTFDateList } ====================================================== constructor TJvTFDateList.Create; begin inherited Create; FList := TStringList.Create; FList.Sorted := True; FList.Duplicates := dupIgnore; end; destructor TJvTFDateList.Destroy; begin FList.Free; inherited Destroy; end; function TJvTFDateList.Add(ADate: TDate): Integer; begin Result := FList.Add(IntToStr(Trunc(ADate))); Change; end; procedure TJvTFDateList.Change; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TJvTFDateList.Clear; begin FList.Clear; Change; end; function TJvTFDateList.Count: Integer; begin Result := FList.Count; end; procedure TJvTFDateList.Delete(Index: Integer); begin FList.Delete(Index); Change; end; function TJvTFDateList.GetDate(Index: Integer): TDate; begin Result := StrToInt(FList[Index]); end; function TJvTFDateList.IndexOf(ADate: TDate): Integer; begin Result := FList.IndexOf(IntToStr(Trunc(ADate))); end; //=== { TJvTFNavigator } ===================================================== //constructor TJvTFNavigator.Create(AOwner: TComponent); //begin // inherited Create(AOwner); // FControls := TStringList.Create; //end; // //destructor TJvTFNavigator.Destroy; //begin // While ControlCount > 0 do // UnregisterControl(Controls[0]); // FControls.Free; // // inherited Destroy; //end; // //function TJvTFNavigator.ControlCount: Integer; //begin // Result := FControls.Count; //end; // //function TJvTFNavigator.GetControl(Index: Integer): TJvTFControl; //begin // Result := TJvTFControl(FControls.Objects[Index]); //end; // //procedure TJvTFNavigator.Navigate(aControl: TJvTFControl; // SchedNames: TStringList; Dates: TJvTFDateList); //var // I: Integer; // Control: TJvTFControl; //begin // If Navigating or not Assigned(aControl) Then // Exit; // // If Assigned(FBeforeNavigate) Then // FBeforeNavigate(Self, aControl, SchedNames, Dates); // // FNavigating := True; // Try // For I := 0 to ControlCount - 1 do // Begin // Control := Controls[I]; // If Control <> aControl Then // //Controls[I].Notify(aControl, sncNavigate); // Control.Navigate(aControl, SchedNames, Dates); // End; // Finally // FNavigating := False; // End; // // If Assigned(FAfterNavigate) Then // FAfterNavigate(Self, aControl, SchedNames, Dates); //end; // //procedure TJvTFNavigator.RegisterControl(aControl: TJvTFControl); //var // I: Integer; //begin // I := FControls.IndexOfObject(aControl); // If I = -1 Then // FControls.AddObject('', aControl); //end; // //procedure TJvTFNavigator.UnregisterControl(aControl: TJvTFControl); //var // I: Integer; //begin // I := FControls.IndexOfObject(aControl); // If I > -1 Then // FControls.Delete(I); //end; end.