pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

jvcllaz: Add JvTimeFramework components, incl adapted demo which uses sqlite3 instead of BDE.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7097 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2019-08-07 15:55:11 +00:00
parent c7dda5d7a3
commit 408079c041
42 changed files with 32355 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

342
components/jvcllaz/run/JvTimeFramework/jvtfalarm.pas Normal file
View File

@ -0,0 +1,342 @@
{-----------------------------------------------------------------------------
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: JvTFAlarm.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 JvTFAlarm;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, Controls, ExtCtrls,
JvTFManager;
type
TJvTFAlarm = class;
TJvTFAlarmInfo = class(TObject)
private
FAppt: TJvTFAppt;
FSnoozeMins: Integer;
FDismiss: Boolean;
FNextAlarmTime: TTime;
protected
property NextAlarmTime: TTime read FNextAlarmTime write FNextAlarmTime;
public
constructor Create(AAppt: TJvTFAppt); virtual;
property Appt: TJvTFAppt read FAppt;
property SnoozeMins: Integer read FSnoozeMins write FSnoozeMins;
property Dismiss: Boolean read FDismiss write FDismiss;
end;
TJvTFAlarmList = class(TStringList)
private
FOwner: TJvTFAlarm;
public
procedure Clear; override;
function GetAlarmForAppt(AAppt: TJvTFAppt): TJvTFAlarmInfo;
function GetAlarmForApptID(const ID: string): TJvTFAlarmInfo;
function IndexOfAppt(AAppt: TJvTFAppt): Integer;
procedure AddAppt(AAppt: TJvTFAppt);
procedure DeleteAppt(AAppt: TJvTFAppt);
property Owner: TJvTFAlarm read FOwner write FOwner;
end;
TJvTFAlarmEvent = procedure(Sender: TObject; AAppt: TJvTFAppt;
var SnoozeMins: Integer; var Dismiss: Boolean) of object;
{$IFDEF RTL230_UP}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF RTL230_UP}
TJvTFAlarm = class(TJvTFComponent)
private
FResources: TStringList;
FTimer: TTimer;
FCurrentDate: TDate;
FAlarmList: TJvTFAlarmList;
FOnAlarm: TJvTFAlarmEvent;
FDefaultSnoozeMins: Integer;
function GetResources: TStrings;
procedure SetResources(Value: TStrings);
function GetTimerInterval: Integer;
procedure SetTimerInterval(Value: Integer);
function GetEnabled: Boolean;
procedure SetEnabled(Value: Boolean);
procedure InternalTimer(Sender: TObject);
protected
procedure DestroyApptNotification(AAppt: TJvTFAppt); override;
procedure ConnectSchedules; virtual;
procedure DisconnectSchedules; virtual;
procedure TimerCheck; virtual;
procedure AlarmCheck; virtual;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Resources: TStrings read GetResources write SetResources;
property TimerInterval: Integer read GetTimerInterval write SetTimerInterval default 30000;
property Enabled: Boolean read GetEnabled write SetEnabled default True;
property DefaultSnoozeMins: Integer read FDefaultSnoozeMins write FDefaultSnoozeMins default 5;
property OnAlarm: TJvTFAlarmEvent read FOnAlarm write FOnAlarm;
end;
implementation
uses
JvTFUtils;
//=== { TJvTFAlarm } =========================================================
constructor TJvTFAlarm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDefaultSnoozeMins := 5;
FCurrentDate := Date;
FResources := TStringList.Create;
FTimer := TTimer.Create(Self);
FTimer.Interval := 30000;
FTimer.Enabled := True;
FTimer.OnTimer := @InternalTimer;
FAlarmList := TJvTFAlarmList.Create;
FAlarmList.Owner := Self;
end;
destructor TJvTFAlarm.Destroy;
begin
DisconnectSchedules;
FTimer.Free;
FResources.Free;
FAlarmList.Create;
FAlarmList.Free;
inherited Destroy;
end;
procedure TJvTFAlarm.Loaded;
begin
inherited Loaded;
ConnectSchedules;
end;
procedure TJvTFAlarm.AlarmCheck;
var
I, J, SnoozeMins: Integer;
Dismiss: Boolean;
Sched: TJvTFSched;
Appt: TJvTFAppt;
AlarmInfo: TJvTFAlarmInfo;
AlarmTime: TTime;
begin
// 1. Roll through all schedules and add an alarm for each appt with a start
// time that is less than the current time. (Duplicate appts will be ignored.)
// 2. Roll through the alarm list and fire an OnAlarm event when appropriate.
// 1.
for I := 0 to ScheduleCount - 1 do
begin
Sched := Schedules[I];
for J := 0 to Sched.ApptCount - 1 do
begin
Appt := Sched.Appts[J];
AlarmTime := Appt.StartTime - Appt.AlarmAdvance * ONE_MINUTE;
if (AlarmTime < Frac(Time)) and Appt.AlarmEnabled then
FAlarmList.AddAppt(Appt);
end;
end;
// 2.
for I := 0 to FAlarmList.Count - 1 do
begin
AlarmInfo := TJvTFAlarmInfo(FAlarmList.Objects[I]);
if not AlarmInfo.Dismiss and (AlarmInfo.NextAlarmTime < Frac(Time)) then
begin
SnoozeMins := AlarmInfo.SnoozeMins;
Dismiss := False;
if Assigned(FOnAlarm) then
begin
FOnAlarm(Self, AlarmInfo.Appt, SnoozeMins, Dismiss);
AlarmInfo.SnoozeMins := SnoozeMins;
AlarmInfo.Dismiss := Dismiss;
end;
AlarmInfo.NextAlarmTime := Time + SnoozeMins * ONE_MINUTE;
end;
end;
end;
procedure TJvTFAlarm.ConnectSchedules;
var
I: Integer;
CurrentSchedules: TStringList;
Schedule: TJvTFSched;
begin
CurrentSchedules := TStringList.Create;
try
FTimer.Enabled := False;
// request all appropriate schedules. Store in temporary list so that
// we can release all schedules no longer needed.
for I := 0 to Resources.Count - 1 do
begin
Schedule := RetrieveSchedule(Resources[I], Date);
CurrentSchedules.AddObject('', Schedule);
end;
// Now release all schedules no longer needed. (Cross check CurrentSchedules
// against Schedules list.)
for I := 0 to ScheduleCount - 1 do
begin
Schedule := Schedules[I];
if CurrentSchedules.IndexOfObject(Schedule) = -1 then
ReleaseSchedule(Schedule.SchedName, Schedule.SchedDate);
end;
finally
CurrentSchedules.Free;
FTimer.Enabled := True;
end;
end;
procedure TJvTFAlarm.DestroyApptNotification(AAppt: TJvTFAppt);
begin
FAlarmList.DeleteAppt(AAppt);
inherited DestroyApptNotification(AAppt);
end;
procedure TJvTFAlarm.DisconnectSchedules;
begin
ReleaseSchedules;
end;
function TJvTFAlarm.GetEnabled: Boolean;
begin
Result := FTimer.Enabled;
end;
function TJvTFAlarm.GetTimerInterval: Integer;
begin
Result := FTimer.Interval;
end;
function TJvTFAlarm.GetResources: TStrings;
begin
Result := FResources;
end;
procedure TJvTFAlarm.InternalTimer(Sender: TObject);
begin
if Trunc(Date) <> Trunc(FCurrentDate) then
begin
FCurrentDate := Date;
ConnectSchedules;
end;
TimerCheck;
end;
procedure TJvTFAlarm.SetEnabled(Value: Boolean);
begin
FTimer.Enabled := Value;
end;
procedure TJvTFAlarm.SetResources(Value: TStrings);
begin
FResources.Assign(Value);
ConnectSchedules;
end;
procedure TJvTFAlarm.SetTimerInterval(Value: Integer);
begin
FTimer.Interval := Value;
end;
procedure TJvTFAlarm.TimerCheck;
begin
AlarmCheck;
end;
//=== { TJvTFAlarmInfo } =====================================================
constructor TJvTFAlarmInfo.Create(AAppt: TJvTFAppt);
begin
inherited Create;
FAppt := AAppt;
end;
//=== { TJvTFAlarmList } =====================================================
procedure TJvTFAlarmList.AddAppt(AAppt: TJvTFAppt);
var
AlarmInfo: TJvTFAlarmInfo;
begin
if Assigned(AAppt) and (IndexOfAppt(AAppt) = -1) then
begin
AlarmInfo := TJvTFAlarmInfo.Create(AAppt);
AlarmInfo.SnoozeMins := Owner.DefaultSnoozeMins;
AlarmInfo.NextAlarmTime := AAppt.StartTime - AAppt.AlarmAdvance * ONE_MINUTE;
AddObject(AAppt.ID, AlarmInfo);
end;
end;
procedure TJvTFAlarmList.Clear;
var
I: Integer;
begin
for I := 0 to Count - 1 do
Objects[I].Free;
inherited Clear;
end;
procedure TJvTFAlarmList.DeleteAppt(AAppt: TJvTFAppt);
var
I: Integer;
begin
I := IndexOfAppt(AAppt);
if I > -1 then
begin
Objects[I].Free;
Delete(I);
end;
end;
function TJvTFAlarmList.GetAlarmForAppt(AAppt: TJvTFAppt): TJvTFAlarmInfo;
begin
Result := GetAlarmForApptID(AAppt.ID);
end;
function TJvTFAlarmList.GetAlarmForApptID(const ID: string): TJvTFAlarmInfo;
var
I: Integer;
begin
Result := nil;
I := IndexOf(ID);
if I > -1 then
Result := TJvTFAlarmInfo(Objects[I]);
end;
function TJvTFAlarmList.IndexOfAppt(AAppt: TJvTFAppt): Integer;
begin
Result := IndexOf(AAppt.ID);
end;
end.

14562
components/jvcllaz/run/JvTimeFramework/jvtfdays.pas Normal file
View File

File diff suppressed because it is too large Load Diff

548
components/jvcllaz/run/JvTimeFramework/jvtfgantt.pas Normal file
View File

@ -0,0 +1,548 @@
{-----------------------------------------------------------------------------
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: JvTFGantt.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
.CDK.REGLINK=JvTFGanttComponentsReg.pas
Created 10/6/2001 6:14:06 PM
Eagle Software CDK, Version 5.13 Rev. B
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvTFGantt;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, LMessages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
JvTFUtils, JvTFManager;
type
TJvTFGanttScrollBar = class(TScrollBar)
private
procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;
protected
procedure CreateWnd; override;
function GetLargeChange: Integer; virtual;
procedure SetLargeChange(Value: Integer); virtual;
procedure UpdateRange; virtual;
public
constructor Create(AOwner: TComponent); override;
published
property LargeChange: Integer read GetLargeChange write SetLargeChange default 1;
end;
TJvTFGanttScale = (ugsYear, ugsQuarter, ugsMonth, ugsWeek, ugsDay, ugsHour, ugsHalfHour, ugsQuarterHour, ugsMinute);
TJvTFGanttScaleFormat = class(TPersistent)
private
FScale: TJvTFGanttScale;
FFont: TFont;
FFormat: string;
FWidth: Integer;
function GetFont: TFont;
procedure SetFont(const Value: TFont);
public
constructor Create;
destructor Destroy; override;
published
property Format: string read FFormat write FFormat;
property Font: TFont read GetFont write SetFont;
property Scale: TJvTFGanttScale read FScale write FScale;
property Width: Integer read FWidth write FWidth;
end;
TJvTFGantt = class(TJvTFControl)
private
// property fields
FMajorScale: TJvTFGanttScaleFormat;
FMinorScale: TJvTFGanttScaleFormat;
FHScrollBar: TJvTFGanttScrollBar;
FVScrollBar: TJvTFGanttScrollBar;
FVisibleScrollBars: TJvTFVisibleScrollBars;
FCustomGlyphs: TBitmap;
// Other class variables
FPaintBuffer: TBitmap;
procedure CMSysColorChange(var Msg: TLMessage); message CM_SYSCOLORCHANGE;
procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;
procedure CMFontChanged(var Msg: TLMessage); message CM_FONTCHANGED;
protected
procedure DrawMajor(ACanvas: TCanvas); virtual;
procedure DrawMinor(ACanvas: TCanvas); virtual;
procedure SetVisibleScrollBars(Value: TJvTFVisibleScrollBars); virtual;
function CalcHeaderHeight: Integer;
procedure AlignScrollBars; virtual;
function GetMinorScale: TJvTFGanttScaleFormat; virtual;
procedure SetMinorScale(const Value: TJvTFGanttScaleFormat); virtual;
function GetMajorScale: TJvTFGanttScaleFormat; virtual;
procedure SetMajorScale(const Value: TJvTFGanttScaleFormat); virtual;
procedure DrawClientArea; virtual;
procedure DrawHeader(ACanvas: TCanvas); virtual;
procedure Loaded; override;
procedure Resize; override;
procedure DrawCustomGlyph(SomeBitmap: TBitmap;
TargetLeft, TargetTop, ImageIndex, NumGlyphsPerBitmap: Integer); dynamic;
function ClientCursorPos: TPoint;
function ValidMouseAtDesignTime: Boolean;
procedure AdjustComponentHeightBasedOnFontChange; virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure PrepareAllBitmaps;
procedure PrepareBitmaps(SomeGlyph: TBitmap; ResourceName: PChar); dynamic;
procedure Paint; override;
published
property MajorScale: TJvTFGanttScaleFormat read GetMajorScale write SetMajorScale;
property MinorScale: TJvTFGanttScaleFormat read GetMinorScale write SetMinorScale;
property VisibleScrollBars: TJvTFVisibleScrollBars read FVisibleScrollBars write SetVisibleScrollBars
default [vsbHorz, vsbVert];
property Align;
property Anchors;
end;
implementation
uses
JvJVCLUtils, JvResources;
//=== { TJvTFGantt } =========================================================
constructor TJvTFGantt.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FPaintBuffer := TBitmap.Create;
FCustomGlyphs := TBitmap.Create;
FVisibleScrollBars := [vsbHorz, vsbVert];
FVScrollBar := TJvTFGanttScrollBar.Create(Self);
with FVScrollBar do
begin
Kind := sbVertical;
TabStop := False;
Anchors := [];
Parent := Self;
Visible := True;
// OnScroll := ScrollBarScroll;
end;
FHScrollBar := TJvTFGanttScrollBar.Create(Self);
with FHScrollBar do
begin
Kind := sbHorizontal;
TabStop := False;
Anchors := [];
Parent := Self;
Visible := True;
// OnScroll := ScrollBarScroll;
end;
FMajorScale := TJvTFGanttScaleFormat.Create;
FMajorScale.Scale := ugsMonth;
FMajorScale.Format := 'mmmm';
FMinorScale := TJvTFGanttScaleFormat.Create;
FMinorScale.Scale := ugsDay;
FMinorScale.Format := 'dd';
PrepareAllBitmaps;
end;
destructor TJvTFGantt.Destroy;
begin
FPaintBuffer.Free;
FMajorScale.Free;
FMinorScale.Free;
FVScrollBar.Free;
FHScrollBar.Free;
FCustomGlyphs.Free;
inherited Destroy;
end;
procedure TJvTFGantt.Loaded;
begin
inherited Loaded;
AlignScrollBars;
end;
procedure TJvTFGantt.DrawMajor(ACanvas: TCanvas);
var
lCaption: string;
begin
ACanvas.Font.Assign(FMajorScale.Font);
lCaption := RsThisIsTheMajorScale;
ACanvas.TextOut((Width div 2) - (ACanvas.TextWidth(Caption) div 2), 2, lCaption);
end;
procedure TJvTFGantt.DrawMinor(ACanvas: TCanvas);
var
lCaption: string;
begin
ACanvas.Font.Assign(FMinorScale.Font);
lCaption := RsThisIsTheMinorScale;
ACanvas.TextOut((Width div 2) - (ACanvas.TextWidth(Caption) div 2),
(CalcHeaderHeight div 2) + 2, lCaption);
end;
function TJvTFGantt.CalcHeaderHeight: Integer;
begin
Result := 0;
Canvas.Font.Assign(FMajorScale.Font);
Result := Result + CanvasMaxTextHeight(Canvas);
Canvas.Font.Assign(FMinorScale.Font);
Result := Result + CanvasMaxTextHeight(Canvas);
Result := Result + 4;
end;
procedure TJvTFGantt.Resize;
begin
inherited Resize;
AlignScrollBars;
end;
procedure TJvTFGantt.SetMajorScale(const Value: TJvTFGanttScaleFormat);
begin
FMajorScale.Assign(Value);
end;
function TJvTFGantt.GetMajorScale: TJvTFGanttScaleFormat;
begin
Result := FMajorScale;
end;
procedure TJvTFGantt.SetMinorScale(const Value: TJvTFGanttScaleFormat);
begin
FMinorScale.Assign(Value);
end;
function TJvTFGantt.GetMinorScale: TJvTFGanttScaleFormat;
begin
Result := FMinorScale;
end;
procedure TJvTFGantt.SetVisibleScrollBars(Value: TJvTFVisibleScrollBars);
begin
if Value <> FVisibleScrollBars then
begin
FVisibleScrollBars := Value;
AlignScrollBars;
FVScrollBar.Visible := vsbVert in FVisibleScrollBars;
FHScrollBar.Visible := vsbHorz in FVisibleScrollBars;
end;
end;
procedure TJvTFGantt.AlignScrollBars;
begin
// DO NOT INVALIDATE GRID IN THIS METHOD
FVScrollBar.Left := ClientWidth - FVScrollBar.Width;
FVScrollBar.Top := CalcHeaderHeight;
FVScrollBar.Height := FHScrollBar.Top - FVScrollBar.Top;
FHScrollBar.Top := ClientHeight - FHScrollBar.Height;
FHScrollBar.Left := 0;
FHScrollBar.Width := FVScrollBar.Left - FHScrollBar.Left;
with FVScrollBar do
if vsbHorz in VisibleScrollBars then
Height := FHScrollBar.Top - Top
else
Height := Self.ClientHeight - Top;
with FHScrollBar do
if vsbVert in VisibleScrollBars then
Width := FVScrollBar.Left - Left
else
Width := Self.ClientWidth - Left;
end;
procedure TJvTFGantt.DrawClientArea;
begin
// Draw the client area
end;
procedure TJvTFGantt.DrawHeader(ACanvas: TCanvas);
begin
DrawMajor(ACanvas);
DrawMinor(ACanvas);
end;
procedure TJvTFGantt.Paint;
begin
inherited Paint;
with FPaintBuffer do
begin
Width := ClientWidth;
Height := ClientHeight;
with Canvas do
begin
Brush.Color := Self.Color;
FillRect(Rect(0, 0, Width, Height));
end;
DrawHeader(Canvas);
DrawClientArea;
end;
if Enabled then
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight, FPaintBuffer.Canvas.Handle, 0, 0, SRCCOPY)
else
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight, FPaintBuffer.Canvas.Handle, 0, 0, SRCCOPY)
{ wp --- to do: Above line is a workaround because DrawState is not available in the LCL
Windows.DrawState(Canvas.Handle, 0, nil, FPaintBuffer.Handle, 0, 0, 0, 0, 0, DST_BITMAP or DSS_UNION or
DSS_DISABLED);
}
end;
{ Draws SomeBitmap out to the canvas. Use ImageIndex = 0 and NumGlyphsPerBitmap = 1 to draw the entire image,
or use other values to specify sub-glyphs within the image (for bitmaps that contain several same-sized
images aligned side-to-side in a single row).
TargetLeft and TargetTop are the left and top coordinates in the Canvas where you would like this image to appear.
Use 0 and 0 to place the image in the top left corner.
CDK: Call this method from an appropriate point in your code (e.g., a "Paint" or "DrawItem" override).
Examples:
// Draws entire image:
DrawCustomGlyph(FCustomGlyphs, 0, 0, 0, 1);
// Draws last image within FCustomGlyph (which contains four side-to-side images):
DrawCustomGlyph(FCustomGlyphs, 0, 0, 3, 4);
}
procedure TJvTFGantt.DrawCustomGlyph(SomeBitmap: TBitmap;
TargetLeft, TargetTop, ImageIndex, NumGlyphsPerBitmap: Integer);
var
LocalImageWidth: Integer;
SourceRect, DestRect: TRect;
begin
with Canvas do
begin
if NumGlyphsPerBitmap = 0 then
NumGlyphsPerBitmap := 1;
LocalImageWidth := SomeBitmap.Width div NumGlyphsPerBitmap;
SourceRect.Left := ImageIndex * LocalImageWidth;
SourceRect.Top := 0;
SourceRect.Right := SourceRect.Left + LocalImageWidth;
SourceRect.Bottom := SourceRect.Top + SomeBitmap.Height;
DestRect.Left := TargetLeft;
DestRect.Top := TargetTop;
DestRect.Right := DestRect.Left + LocalImageWidth;
DestRect.Bottom := DestRect.Top + SomeBitmap.Height;
CopyRect(DestRect, SomeBitmap.Canvas, SourceRect);
end;
end;
{ Prepares glyphs for display.
The following colors in your glyphs will be replaced:
Yellow with clBtnHighlight
Silver with clBtnFace
Gray with clBtnShadow
White with clWindow
Red with clWindowText
CDK: Modify your glyphs so that they conform to the colors above, or alternatively
modify the colors referenced in the code below.
}
procedure TJvTFGantt.PrepareBitmaps(SomeGlyph: TBitmap; ResourceName: PChar);
var
LocalBitmap: TBitmap;
procedure ReplaceColors(SourceBmp, TargetBmp: TBitmap; SourceColor, TargetColor: TColor);
begin
TargetBmp.Canvas.Brush.Color := TargetColor;
TargetBmp.Canvas.BrushCopy(SourceBmp.Canvas.ClipRect, SourceBmp,
SourceBmp.Canvas.ClipRect, SourceColor);
end;
begin
LocalBitmap := TBitmap.Create;
try
LocalBitmap.LoadFromResourceName(HInstance, ResourceName);
SomeGlyph.Width := LocalBitmap.Width;
SomeGlyph.Height := LocalBitmap.Height;
{ Replace the following colors after loading bitmap:
clYellow with clBtnHighlight
clSilver with clBtnFace
clGray with clBtnShadow
clWhite with clWindow
clRed with clWindowText
}
{ Must call ReplaceColors an odd number of times, to ensure that final image ends up in SomeGlyph.
As it turns out, we need to make exactly five replacements. Note that each subsequent call to
ReplaceColors switches the order of parameters LocalBitmap and SomeGlyph. This is because
we are copying the image back and forth, replacing individual colors with each copy. }
ReplaceColors(LocalBitmap, SomeGlyph, clYellow, clBtnHighlight);
ReplaceColors(SomeGlyph, LocalBitmap, clSilver, clBtnFace);
ReplaceColors(LocalBitmap, SomeGlyph, clGray, clBtnShadow);
ReplaceColors(SomeGlyph, LocalBitmap, clWhite, clWindow);
ReplaceColors(LocalBitmap, SomeGlyph, clRed, clWindowText);
finally
LocalBitmap.Free;
end;
end;
procedure TJvTFGantt.PrepareAllBitmaps;
begin
{ CDK: Replace BITMAP_RESOURCE_NAME with the name of your bitmap resource. }
// PrepareBitmaps(FCustomGlyphs, 'BITMAP_RESOURCE_NAME');
{ CDK: If you have other Glyphs that need loading/preparing, place additional
calls to PrepareBitmaps here. }
end;
procedure TJvTFGantt.CMSysColorChange(var Msg: TLMessage);
begin
inherited;
PrepareAllBitmaps;
end;
function TJvTFGantt.ClientCursorPos: TPoint;
begin
GetCursorPos(Result);
Result := ScreenToClient(Result);
end;
function TJvTFGantt.ValidMouseAtDesignTime: Boolean;
begin
Result := False;
end;
procedure TJvTFGantt.CMDesignHitTest(var Msg: TCMDesignHitTest);
begin
// True = Allow design-time mouse hits to get through if Alt key is down.
Msg.Result := Ord(ValidMouseAtDesignTime);
end;
procedure TJvTFGantt.CMFontChanged(var Msg: TLMessage);
begin
inherited;
AdjustComponentHeightBasedOnFontChange;
end;
procedure TJvTFGantt.AdjustComponentHeightBasedOnFontChange;
begin
{ CDK: Add code to calculate the new height. If this is a composite component
and you have any edit boxes, the edit box size will have already changed
based on the new font (providing this method is called from a CM_FontChanged
message handler).
For example, your code might look like this:
LockHeight := False;
Height := Edit1.Height;
Button1.Height := Height;
LockHeight := True;
}
end;
//=== { TJvTFGanttScaleFormat } ==============================================
constructor TJvTFGanttScaleFormat.Create;
begin
// (rom) added inherited Create
inherited Create;
FFont := TFont.Create;
end;
destructor TJvTFGanttScaleFormat.Destroy;
begin
FFont.Free;
inherited Destroy;
end;
function TJvTFGanttScaleFormat.GetFont: TFont;
begin
Result := FFont;
end;
procedure TJvTFGanttScaleFormat.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
end;
//=== { TJvTFGanttScrollBar } ================================================
constructor TJvTFGanttScrollBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// If we set the csNoDesignVisible flag then visibility at design time
// is controlled by the Visible property, which is exactly what we want.
ControlStyle := ControlStyle + [csNoDesignVisible];
{
ParentCtl3D := False;
Ctl3D := False;
}
end;
procedure TJvTFGanttScrollBar.CMDesignHitTest(var Msg: TCMDesignHitTest);
begin
Msg.Result := 1;
end;
procedure TJvTFGanttScrollBar.CreateWnd;
begin
inherited CreateWnd;
UpdateRange;
end;
function TJvTFGanttScrollBar.GetLargeChange: Integer;
begin
Result := inherited LargeChange;
end;
procedure TJvTFGanttScrollBar.SetLargeChange(Value: Integer);
begin
inherited LargeChange := Value;
UpdateRange;
end;
procedure TJvTFGanttScrollBar.UpdateRange;
var
Info: TScrollInfo;
begin
FillChar(Info, SizeOf(Info), 0);
with Info do
begin
cbSize := SizeOf(Info);
fMask := SIF_PAGE;
nPage := LargeChange;
end;
SetScrollInfo(Handle, SB_CTL, Info, True);
end;
end.

4076
components/jvcllaz/run/JvTimeFramework/jvtfglance.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1585
components/jvcllaz/run/JvTimeFramework/jvtfglancetextviewer.pas Normal file
View File

File diff suppressed because it is too large Load Diff

5369
components/jvcllaz/run/JvTimeFramework/jvtfmanager.pas Normal file
View File

File diff suppressed because it is too large Load Diff

611
components/jvcllaz/run/JvTimeFramework/jvtfmonths.pas Normal file
View File

@ -0,0 +1,611 @@
{-----------------------------------------------------------------------------
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: JvTFMonths.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 JvTFMonths;
{$mode objfpc}{$H+}
//{$mode delphi}
interface
uses
LCLIntf, LCLType, LMessages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
JvTFGlance, JvTFUtils, JvTFManager;
type
TJvTFMonthsScrollSize = (mssMonth, mssWeek);
TJvTFMonths = class(TJvTFCustomGlance)
private
FDisplayDate: TDate;
FDWNames: TJvTFDWNames;
FDWTitleAttr: TJvTFGlanceTitle;
FOnDrawDWTitle: TJvTFDrawDWTitleEvent;
FOnUpdateTitle: TJvTFUpdateTitleEvent;
FOffDays: TTFDaysOfWeek;
FExtraDayCellAttr: TJvTFGlanceCellAttr;
FOffDayCellAttr: TJvTFGlanceCellAttr;
FScrollSize: TJvTFMonthsScrollSize;
FSplitSatSun: Boolean;
FDayFormat: string;
FFirstDayOfMonthFormat: string;
function GetMonth: Word;
procedure SetMonth(Value: Word);
function GetYear: Word;
procedure SetYear(Value: Word);
procedure SetDisplayDate(Value: TDate);
procedure SetDWNames(Value: TJvTFDWNames);
procedure SetDWTitleAttr(Value: TJvTFGlanceTitle);
procedure SetOffDays(Value: TTFDaysOfWeek);
procedure SetExtraDayCellAttr(Value: TJvTFGlanceCellAttr);
procedure SetOffDayCellAttr(Value: TJvTFGlanceCellAttr);
procedure SetSplitSatSun(Value: Boolean);
procedure SetDayFormat(const Value: string);
procedure SetFirstDayOfMonthFormat(const Value: string);
protected
procedure SetStartOfWeek(Value: TTFDayOfWeek); override;
procedure SetColCount(Value: Integer); override;
procedure ConfigCells; override;
procedure DWNamesChange(Sender: TObject);
procedure Navigate(AControl: TJvTFControl; ASchedNames: TStringList;
Dates: TJvTFDateList); override;
// draws the DWTitles
procedure DrawTitle(ACanvas: TCanvas); override;
procedure UpdateTitle;
procedure NextMonth;
procedure PrevMonth;
procedure NextWeek;
procedure PrevWeek;
function GetCellTitleText(Cell: TJvTFGlanceCell): string; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetDataTop: Integer; override;
function GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr; override;
function CellIsExtraDay(ACell: TJvTFGlanceCell): Boolean;
function CellIsOffDay(ACell: TJvTFGlanceCell): Boolean;
function DOWShowing(DOW: TTFDayOfWeek): Boolean;
procedure ScrollPrev;
procedure ScrollNext;
published
property ScrollSize: TJvTFMonthsScrollSize read FScrollSize write FScrollSize default mssMonth;
property Month: Word read GetMonth write SetMonth;
property Year: Word read GetYear write SetYear;
property DisplayDate: TDate read FDisplayDate write SetDisplayDate;
property DWNames: TJvTFDWNames read FDWNames write SetDWNames;
property DWTitleAttr: TJvTFGlanceTitle read FDWTitleAttr write SetDWTitleAttr;
property OffDays: TTFDaysOfWeek read FOffDays write SetOffDays default [dowSunday, dowSaturday];
property ExtraDayCellAttr: TJvTFGlanceCellAttr read FExtraDayCellAttr write SetExtraDayCellAttr;
property OffDayCellAttr: TJvTFGlanceCellAttr read FOffDayCellAttr write SetOffDayCellAttr;
property SplitSatSun: Boolean read FSplitSatSun write SetSplitSatSun default False;
property OnDrawDWTitle: TJvTFDrawDWTitleEvent read FOnDrawDWTitle write FOnDrawDWTitle;
property OnUpdateTitle: TJvTFUpdateTitleEvent read FOnUpdateTitle write FOnUpdateTitle;
property StartOfWeek;
property ColCount;
property FirstDayOfMonthFormat: string read FFirstDayOfMonthFormat write SetFirstDayOfMonthFormat;
property DayFormat: string read FDayFormat write SetDayFormat;
// property Navigator;
// property OnNavigate;
end;
implementation
uses
DateUtils;
constructor TJvTFMonths.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DisplayDate := Date;
FOffDays := [dowSunday, dowSaturday];
FScrollSize := mssMonth;
FDWNames := TJvTFDWNames.Create;
FDWNames.OnChange := @DWNamesChange;
FExtraDayCellAttr := TJvTFGlanceCellAttr.Create(Self);
FOffDayCellAttr := TJvTFGlanceCellAttr.Create(Self);
CellAttr.TitleAttr.Color := clWhite;
FExtraDayCellAttr.TitleAttr.Color := clWhite;
FOffDayCellAttr.TitleAttr.Color := clWhite;
FDayFormat := 'd';
FFirstDayOfMonthFormat := 'mmm d';
FDWTitleAttr := TJvTFGlanceTitle.Create(Self);
with FDWTitleAttr do
begin
// Assign(TitleAttr);
TxtAttr.Font.Size := 8;
TxtAttr.Font.Style := [];
Height := 20;
Visible := True;
FrameAttr.Style := fs3DRaised;
OnChange := @GlanceTitleChange;
end;
end;
destructor TJvTFMonths.Destroy;
begin
FDWNames.OnChange := nil;
FDWNames.Free;
FDWTitleAttr.Free;
FExtraDayCellAttr.Free;
FOffDayCellAttr.Free;
inherited Destroy;
end;
function TJvTFMonths.CellIsExtraDay(ACell: TJvTFGlanceCell): Boolean;
var
Y, M, D: Word;
begin
DecodeDate(ACell.CellDate, Y, M, D);
Result := (Y <> Self.Year) or (M <> Self.Month);
end;
function TJvTFMonths.CellIsOffDay(ACell: TJvTFGlanceCell): Boolean;
begin
Result := DateToDOW(ACell.CellDate) in OffDays
end;
procedure TJvTFMonths.ConfigCells;
var
Row, Col, SplitCount: Integer;
Cell: TJvTFGlanceCell;
begin
(*
For Row := 0 to RowCount - 1 do
For Col := 0 to ColCount - 1 do
begin
Cell := Cells.Cells[Col, Row];
if SplitSatSun and (DateToDow(Cell.CellDate) = dowSaturday) Then
SplitCell(Cell)
else
Cell.Combine;
end;
{
Found := False;
Col := 0;
While (Col < ColCount) and not Found do
if DateToDOW(Cells.Cells[Col, 0].CellDate) = dowSaturday Then
Found := True
else
Inc(Col);
if Found Then
For Row := 0 to RowCount - 1 do
if SplitSatSun Then
SplitCell(Cells.Cells[Col, Row])
else
Cells.Cells[Col, Row].Combine;
}
*)
for Row := 0 to RowCount - 1 do
begin
SplitCount := 0;
for Col := 0 to ColCount - 1 do
begin
Cell := Cells.Cells[Col, Row];
SetCellDate(Cell, OriginDate + Row * 7 + Col + SplitCount);
if SplitSatSun and (DateToDOW(Cell.CellDate) = dowSaturday) then
SplitCell(Cell)
else
CombineCell(Cell);
if Cell.IsSplit then
begin
Inc(SplitCount);
SetCellDate(Cell.SubCell, OriginDate + Row * 7 + Col + SplitCount);
end;
end;
end;
inherited ConfigCells;
end;
function TJvTFMonths.DOWShowing(DOW: TTFDayOfWeek): Boolean;
var
I: Integer;
TestDOW: TTFDayOfWeek;
begin
// THIS ROUTINE SUPPORTS ONLY SAT/SUN SPLITS
if (DOW = dowSunday) and SplitSatSun then
Result := DOWShowing(dowSaturday)
else
begin
I := 0;
Result := False;
TestDOW := StartOfWeek;
while (I < ColCount) and not Result do
if TestDOW = DOW then
Result := True
else
IncDOW(TestDOW, 1);
end;
end;
procedure TJvTFMonths.DrawTitle(ACanvas: TCanvas);
var
I, Col, LineBottom: Integer;
CurrDOW: TTFDayOfWeek;
R, TempRect, TxtRect, TextBounds: TRect;
OldPen: TPen;
OldBrush: TBrush;
OldFont: TFont;
Txt: string;
begin
inherited DrawTitle(ACanvas);
if not DWTitleAttr.Visible then
Exit;
with ACanvas do
begin
OldPen := TPen.Create;
OldPen.Assign(Pen);
OldBrush := TBrush.Create;
OldBrush.Assign(Brush);
OldFont := TFont.Create;
OldFont.Assign(Font);
end;
// draw the DWTitles
R.Top := inherited GetDataTop;
R.Bottom := GetDataTop;
CurrDOW := StartOfWeek;
for Col := 0 to ColCount - 1 do
begin
TempRect := WholeCellRect(Col, 0);
R.Left := TempRect.Left;
R.Right := TempRect.Right;
TxtRect := R;
InflateRect(TxtRect, -1, -1);
with ACanvas do
begin
Brush.Color := DWTitleAttr.Color;
FillRect(R);
case DWTitleAttr.FrameAttr.Style of
fs3DRaised:
Draw3DFrame(ACanvas, R, clBtnHighlight, clBtnShadow);
fs3DLowered:
Draw3DFrame(ACanvas, R, clBtnShadow, clBtnHighlight);
fsFlat:
begin
Pen.Color := DWTitleAttr.FrameAttr.Color;
Pen.Width := DWTitleAttr.FrameAttr.Width;
if Col = 0 then
begin
MoveTo(R.Left, R.Top);
LineTo(R.Left, R.Bottom);
end;
PolyLine([Point(R.Right - 1, R.Top),
Point(R.Right - 1, R.Bottom - 1),
Point(R.Left - 1, R.Bottom - 1)]);
end;
fsNone:
begin
Pen.Color := DWTitleAttr.FrameAttr.Color;
Pen.Width := 1;
LineBottom := R.Bottom - 1;
for I := 1 to DWTitleAttr.FrameAttr.Width do
begin
MoveTo(R.Left, LineBottom);
LineTo(R.Right, LineBottom);
Dec(LineBottom);
end;
end;
end;
Txt := DWNames.GetDWName(DOWToBorl(CurrDOW));
if SplitSatSun and (CurrDOW = dowSaturday) then
begin
IncDOW(CurrDOW, 1);
Txt := Txt + '/' + DWNames.GetDWName(DOWToBorl(CurrDOW));
end;
Font := DWTitleAttr.TxtAttr.Font;
DrawAngleText(ACanvas, TxtRect, TextBounds,
DWTitleAttr.TxtAttr.Rotation,
DWTitleAttr.TxtAttr.AlignH,
DWTitleAttr.TxtAttr.AlignV, Txt);
end;
if Assigned(FOnDrawDWTitle) then
FOnDrawDWTitle(Self, ACanvas, R, CurrDOW, Txt);
IncDOW(CurrDOW, 1);
end;
with ACanvas do
begin
Pen.Assign(OldPen);
Brush.Assign(OldBrush);
Font.Assign(OldFont);
OldPen.Free;
OldBrush.Free;
OldFont.Free;
end;
end;
procedure TJvTFMonths.DWNamesChange(Sender: TObject);
begin
Invalidate;
end;
function TJvTFMonths.GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr;
begin
if CellIsSelected(ACell) then
Result := SelCellAttr
else
if CellIsExtraDay(ACell) then
Result := ExtraDayCellAttr
else
if CellIsOffDay(ACell) then
Result := OffDayCellAttr
else
Result := CellAttr;
end;
function TJvTFMonths.GetCellTitleText(Cell: TJvTFGlanceCell): string;
begin
if CellIsExtraDay(Cell) and (IsFirstOfMonth(Cell.CellDate) or EqualDates(Cell.CellDate, OriginDate)) then
Result := FormatDateTime(FirstDayOfMonthFormat, Cell.CellDate)
else
Result := FormatDateTime(DayFormat, Cell.CellDate);
end;
function TJvTFMonths.GetDataTop: Integer;
begin
Result := inherited GetDataTop;
if DWTitleAttr.Visible then
Inc(Result, DWTitleAttr.Height);
end;
function TJvTFMonths.GetMonth: Word;
begin
Result := ExtractMonth(DisplayDate);
end;
function TJvTFMonths.GetYear: Word;
begin
Result := ExtractYear(DisplayDate);
end;
procedure TJvTFMonths.Navigate(AControl: TJvTFControl;
ASchedNames: TStringList; Dates: TJvTFDateList);
begin
inherited Navigate(AControl, ASchedNames, Dates);
if Dates.Count > 0 then
DisplayDate := Dates[0];
end;
procedure TJvTFMonths.NextMonth;
var
Temp: TDateTime;
begin
Temp := DisplayDate;
IncMonths(Temp, 1);
DisplayDate := Temp;
end;
procedure TJvTFMonths.NextWeek;
var
Temp: TDateTime;
begin
Temp := DisplayDate;
IncWeeks(Temp, 1);
DisplayDate := Temp;
end;
procedure TJvTFMonths.PrevMonth;
var
Temp: TDateTime;
begin
Temp := DisplayDate;
IncMonths(Temp, -1);
DisplayDate := Temp;
end;
procedure TJvTFMonths.PrevWeek;
var
Temp: TDateTime;
begin
Temp := DisplayDate;
IncWeeks(Temp, -1);
DisplayDate := Temp;
end;
procedure TJvTFMonths.ScrollNext;
begin
if ScrollSize = mssMonth then
NextMonth
else
NextWeek;
end;
procedure TJvTFMonths.ScrollPrev;
begin
if ScrollSize = mssMonth then
PrevMonth
else
PrevWeek;
end;
procedure TJvTFMonths.SetColCount(Value: Integer);
begin
Value := Lesser(Value, 7);
inherited SetColCount(Value);
end;
procedure TJvTFMonths.SetDayFormat(const Value: string);
begin
if Value <> FDayFormat then
begin
FDayFormat := Value;
Invalidate;
end;
end;
procedure TJvTFMonths.SetDisplayDate(Value: TDate);
begin
FDisplayDate := Value;
if ScrollSize = mssMonth then
StartDate := FirstOfMonth(Value)
else
StartDate := Value;
UpdateTitle;
end;
procedure TJvTFMonths.SetDWNames(Value: TJvTFDWNames);
begin
FDWNames.Assign(Value);
end;
procedure TJvTFMonths.SetDWTitleAttr(Value: TJvTFGlanceTitle);
begin
FDWTitleAttr.Assign(Value);
end;
procedure TJvTFMonths.SetExtraDayCellAttr(Value: TJvTFGlanceCellAttr);
begin
FExtraDayCellAttr.Assign(Value);
end;
procedure TJvTFMonths.SetFirstDayOfMonthFormat(const Value: string);
begin
if Value <> FFirstDayOfMonthFormat then
begin
FFirstDayOfMonthFormat := Value;
Invalidate;
end;
end;
procedure TJvTFMonths.SetMonth(Value: Word);
var
Y, M, D: Word;
begin
// Don't set the month while loading, the DisplayDate will be loaded as well
if csLoading in ComponentState then
Exit;
EnsureMonth(Value);
DecodeDate(DisplayDate, Y, M, D);
if Value <> M then
begin
// Ensure the day is still inside the valid values for the new month
if D > DaysInAMonth(Y, Value) then
D := DaysInAMonth(Y, Value);
DisplayDate := EncodeDate(Y, Value, D);
end;
end;
procedure TJvTFMonths.SetOffDayCellAttr(Value: TJvTFGlanceCellAttr);
begin
FOffDayCellAttr.Assign(Value);
end;
procedure TJvTFMonths.SetOffDays(Value: TTFDaysOfWeek);
begin
if Value <> FOffDays then
begin
FOffDays := Value;
Invalidate;
end;
end;
procedure TJvTFMonths.SetSplitSatSun(Value: Boolean);
begin
if Value <> FSplitSatSun then
begin
if DOWShowing(dowSunday) or DOWShowing(dowSaturday) then
if Value then
begin
if StartOfWeek = dowSunday then
StartOfWeek := dowMonday;
ColCount := ColCount - 1;
end
else
ColCount := ColCount + 1;
FSplitSatSun := Value;
Cells.ReconfigCells;
end;
end;
procedure TJvTFMonths.SetStartOfWeek(Value: TTFDayOfWeek);
begin
if SplitSatSun and (Value = dowSunday) then
Value := dowSaturday;
inherited SetStartOfWeek(Value);
end;
procedure TJvTFMonths.SetYear(Value: Word);
var
Y, M, D: Word;
begin
// Don't set the year while loading, the DisplayDate will be loaded as well
if csLoading in ComponentState then
Exit;
DecodeDate(DisplayDate, Y, M, D);
if Value <> Y then
begin
// Ensure the day is still inside the valid values for the month of
// the new year. This case only happens with February, by the way.
if D > DaysInAMonth(Value, M) then
D := DaysInAMonth(Value, M);
DisplayDate := EncodeDate(Value, M, D);
end;
end;
procedure TJvTFMonths.UpdateTitle;
var
NewTitle: string;
begin
NewTitle := FormatDateTime('mmmm yyyy', DisplayDate);
if NewTitle <> TitleAttr.Title then
begin
if Assigned(FOnUpdateTitle) then
FOnUpdateTitle(Self, NewTitle);
TitleAttr.Title := NewTitle;
end;
end;
end.

269
components/jvcllaz/run/JvTimeFramework/jvtfsparsematrix.pas Normal file
View File

@ -0,0 +1,269 @@
{-----------------------------------------------------------------------------
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: JvTFSparseMatrix.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 JvTFSparseMatrix;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
// NativeInt = Integer;
EJvTFSparseMatrixError = class(Exception);
PSMQuantum = ^TSMQuantum;
TSMQuantum = record
Index: Integer;
Data: NativeInt;
Link: PSMQuantum;
end;
TJvTFSparseMatrix = class(TObject)
private
FMatrix: TSMQuantum;
FNullValue: NativeInt;
procedure SetNullValue(Value: NativeInt);
function GetData(Row, Col: Integer): NativeInt;
procedure SetData(Row, Col: Integer; Value: NativeInt);
procedure Put(Row, Col: Integer; Data: NativeInt);
function Get(Row, Col: Integer): NativeInt;
function FindQuantum(Row, Col: Integer;
var Prev, Curr: PSMQuantum; var RowExists: Boolean): Boolean;
public
destructor Destroy; override;
procedure Clear;
procedure Pack;
procedure CopyTo(DestMatrix: TJvTFSparseMatrix);
property Data[Row, Col: Integer]: NativeInt read GetData write SetData; default;
property NullValue: NativeInt read FNullValue write SetNullValue default 0;
procedure Dump(const DumpList: TStrings);
end;
implementation
uses
JvResources;
destructor TJvTFSparseMatrix.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TJvTFSparseMatrix.Clear;
var
P, CurrRow, CurrCol: PSMQuantum;
begin
CurrRow := PSMQuantum(FMatrix.Data);
while CurrRow <> nil do
begin
CurrCol := CurrRow^.Link;
while CurrCol <> nil do
begin
P := CurrCol;
CurrCol := CurrCol^.Link;
Dispose(P);
end;
P := CurrRow;
CurrRow := PSMQuantum(CurrRow^.Data);
Dispose(P);
end;
FMatrix.Data := 0;
end;
procedure TJvTFSparseMatrix.CopyTo(DestMatrix: TJvTFSparseMatrix);
var
CurrRow, CurrCol: PSMQuantum;
begin
DestMatrix.Clear;
DestMatrix.NullValue := NullValue;
CurrRow := PSMQuantum(FMatrix.Data);
while CurrRow <> nil do
begin
CurrCol := CurrRow^.Link;
while CurrCol <> nil do
begin
DestMatrix[CurrRow^.Index, CurrCol^.Index] := CurrCol^.Data;
CurrCol := CurrCol^.Link;
end;
CurrRow := PSMQuantum(CurrRow^.Data);
end;
end;
procedure TJvTFSparseMatrix.Dump(const DumpList: TStrings);
var
CurrRow, CurrCol: PSMQuantum;
begin
DumpList.Clear;
CurrRow := PSMQuantum(FMatrix.Data);
DumpList.BeginUpdate;
try
while CurrRow <> nil do
begin
CurrCol := CurrRow^.Link;
while CurrCol <> nil do
begin
DumpList.Add('(' + IntToStr(CurrRow^.Index) + ', ' +
IntToStr(CurrCol^.Index) + ') ' +
IntToStr(CurrCol^.Data));
CurrCol := CurrCol^.Link;
end;
CurrRow := PSMQuantum(CurrRow^.Data);
end;
finally
DumpList.EndUpdate;
end;
end;
function TJvTFSparseMatrix.FindQuantum(Row, Col: Integer;
var Prev, Curr: PSMQuantum; var RowExists: Boolean): Boolean;
begin
Prev := @FMatrix;
Curr := PSMQuantum(FMatrix.Data);
Result := False;
RowExists := False;
// Find Row Header
while (Curr <> nil) and (Curr^.Index < Row) do
begin
Prev := Curr;
Curr := PSMQuantum(Curr^.Data);
end;
// If Row Header found, then find col
if (Curr <> nil) and (Curr^.Index = Row) then
begin
RowExists := True;
Prev := Curr;
Curr := Curr^.Link;
while (Curr <> nil) and (Curr^.Index < Col) do
begin
Prev := Curr;
Curr := Curr^.Link;
end;
Result := (Curr <> nil) and (Curr^.Index = Col);
end;
end;
function TJvTFSparseMatrix.Get(Row, Col: Integer): NativeInt;
var
Prev, Curr: PSMQuantum;
RowExists: Boolean;
begin
if FindQuantum(Row, Col, Prev, Curr, RowExists) then
Result := Curr^.Data
else
Result := NullValue;
end;
function TJvTFSparseMatrix.GetData(Row, Col: Integer): NativeInt;
begin
Result := Get(Row, Col);
end;
procedure TJvTFSparseMatrix.Put(Row, Col: Integer; Data: NativeInt);
var
P, Prev, Curr: PSMQuantum;
RowExists: Boolean;
begin
if FindQuantum(Row, Col, Prev, Curr, RowExists) then
if Data <> NullValue then
Curr^.Data := Data
else
begin
Prev^.Link := Curr^.Link;
Dispose(Curr);
end
else
if Data <> NullValue then
begin
if not RowExists then
begin
New(P);
P^.Index := Row;
P^.Link := nil;
P^.Data := Prev^.Data;
PSMQuantum(Prev^.Data) := P;
Prev := P;
end;
New(P);
P^.Index := Col;
P^.Data := Data;
P^.Link := Prev^.Link;
Prev^.Link := P;
end;
end;
procedure TJvTFSparseMatrix.SetData(Row, Col: Integer; Value: NativeInt);
begin
Put(Row, Col, Value);
end;
procedure TJvTFSparseMatrix.SetNullValue(Value: NativeInt);
begin
if FMatrix.Data = 0 then
FNullValue := Value
else
raise EJvTFSparseMatrixError.CreateRes(@RsEMatrixMustBeEmpty);
end;
procedure TJvTFSparseMatrix.Pack;
var
P, Prev, CurrRow: PSMQuantum;
begin
CurrRow := PSMQuantum(FMatrix.Data);
Prev := @FMatrix;
while CurrRow <> nil do
begin
if CurrRow^.Link <> nil then
begin
Prev := CurrRow;
CurrRow := PSMQuantum(CurrRow^.Data);
end
else
begin
P := CurrRow;
Prev^.Data := CurrRow^.Data;
Dispose(P);
CurrRow := PSMQuantum(Prev^.Data);
end;
end;
end;
end.

827
components/jvcllaz/run/JvTimeFramework/jvtfutils.pas Normal file
View File

@ -0,0 +1,827 @@
{-----------------------------------------------------------------------------
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: JvTFUtils.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 JvTFUtils;
{$mode objfpc}{$H+}
interface
uses
//Windows,
LCLType, LCLIntf, Types,
Graphics, Controls, Classes, SysUtils;
(*
{$IFNDEF COMPILER12_UP} // Delphi 2009 knows System::TDate and System::TTime
{$HPPEMIT '#ifndef TDate'}
{$HPPEMIT '#define TDate Controls::TDate'}
{$HPPEMIT '#define TTime Controls::TTime'}
{$HPPEMIT '#endif'}
{$ENDIF ~COMPILER12_UP}
*)
type
TJvTFVisibleScrollBars = set of (vsbHorz, vsbVert);
EJvTFDateError = class(Exception);
TTFDayOfWeek = (dowSunday, dowMonday, dowTuesday, dowWednesday,
dowThursday, dowFriday, dowSaturday);
TTFDaysOfWeek = set of TTFDayOfWeek;
TJvTFVAlignment = (vaTop, vaCenter, vaBottom);
TJvTFDirection = (dirUp, dirDown, dirLeft, dirRight);
const
DOW_WEEK: TTFDaysOfWeek = [dowSunday..dowSaturday];
DOW_WEEKEND: TTFDaysOfWeek = [dowSunday, dowSaturday];
DOW_WORKWEEK: TTFDaysOfWeek = [dowMonday..dowFriday];
ONE_HOUR = 1 / 24;
ONE_MINUTE = ONE_HOUR / 60;
ONE_SECOND = ONE_MINUTE / 60;
ONE_MILLISECOND = ONE_SECOND / 1000;
function ExtractYear(ADate: TDateTime): Word;
function ExtractMonth(ADate: TDateTime): Word;
function ExtractDay(ADate: TDateTime): Word;
function ExtractHours(ATime: TDateTime): Word;
function ExtractMins(ATime: TDateTime): Word;
function ExtractSecs(ATime: TDateTime): Word;
function ExtractMSecs(ATime: TDateTime): Word;
function FirstOfMonth(ADate: TDateTime): TDateTime;
function GetDayOfNthDOW(Year, Month, DOW, N: Word): Word;
function GetWeeksInMonth(Year, Month: Word; StartOfWeek: Integer): Word;
procedure IncBorlDOW(var BorlDOW: Integer; N: Integer = 1);
procedure IncDOW(var DOW: TTFDayOfWeek; N: Integer = 1);
procedure IncDays(var ADate: TDateTime; N: Integer = 1);
procedure IncWeeks(var ADate: TDateTime; N: Integer = 1);
procedure IncMonths(var ADate: TDateTime; N: Integer = 1);
procedure IncYears(var ADate: TDateTime; N: Integer = 1);
function EndOfMonth(ADate: TDateTime): TDateTime;
function IsFirstOfMonth(ADate: TDateTime): Boolean;
function IsEndOfMonth(ADate: TDateTime): Boolean;
procedure EnsureMonth(Month: Word);
procedure EnsureDOW(DOW: Word);
function EqualDates(D1, D2: TDateTime): Boolean;
function Lesser(N1, N2: Integer): Integer;
function Greater(N1, N2: Integer): Integer;
function GetDivLength(TotalLength, DivCount, DivNum: Integer): Integer;
function GetDivNum(TotalLength, DivCount, X: Integer): Integer;
function GetDivStart(TotalLength, DivCount, DivNum: Integer): Integer;
function DOWToBorl(ADOW: TTFDayOfWeek): Integer;
function BorlToDOW(BorlDOW: Integer): TTFDayOfWeek;
function DateToDOW(ADate: TDateTime): TTFDayOfWeek;
procedure CalcTextPos(ACanvas: TCanvas;
HostRect: TRect; var TextLeft, TextTop: Integer;
var TextBounds: TRect; AFont: TFont; AAngle: Integer;
HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: String);
{
procedure CalcTextPos(HostRect: TRect; var TextLeft, TextTop: Integer;
var TextBounds: TRect; AFont: TFont; AAngle: Integer;
HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: string);
}
procedure DrawAngleText(ACanvas: TCanvas; HostRect: TRect;
var TextBounds: TRect; AAngle: Integer; HAlign: TAlignment;
VAlign: TJvTFVAlignment; ATxt: string);
function RectWidth(ARect: TRect): Integer;
function RectHeight(ARect: TRect): Integer;
function EmptyRect: TRect;
function IsClassByName(Obj: TObject; ClassName: string): Boolean;
function StringsToStr(const List: TStrings; const Sep: string;
const AllowEmptyString: Boolean = True): string;
implementation
uses
Math, JvResources;
function ExtractYear(ADate: TDateTime): Word;
var
M, D: Word;
begin
DecodeDate(ADate, Result, M, D);
end;
function ExtractMonth(ADate: TDateTime): Word;
var
Y, D: Word;
begin
DecodeDate(ADate, Y, Result, D);
end;
function ExtractDay(ADate: TDateTime): Word;
var
Y, M: Word;
begin
DecodeDate(ADate, Y, M, Result);
end;
function FirstOfMonth(ADate: TDateTime): TDateTime;
var
Y, M, D: Word;
begin
DecodeDate(ADate, Y, M, D);
Result := EncodeDate(Y, M, 1);
end;
function GetDayOfNthDOW(Year, Month, DOW, N: Word): Word;
var
FirstDayDOW: Word;
WorkDate: TDateTime;
begin
WorkDate := EncodeDate(Year, Month, 1);
FirstDayDOW := DayOfWeek(WorkDate);
WorkDate := WorkDate + (DOW - FirstDayDOW);
if DOW < FirstDayDOW then
WorkDate := WorkDate + 7;
// WorkDate is now at the first DOW
// Now adjust for N
WorkDate := WorkDate + (7 * (N - 1));
Result := ExtractDay(WorkDate);
// Finally, check to make sure WorkDate is in the given month
if Trunc(EncodeDate(Year, Month, 1)) <> Trunc(FirstOfMonth(WorkDate)) then
raise EJvTFDateError.CreateRes(@RsEResultDoesNotFallInMonth);
end;
function GetWeeksInMonth(Year, Month: Word; StartOfWeek: Integer): Word;
var
DOW,
EndOfWeek: Integer;
EOM,
WorkDate: TDateTime;
begin
// Get the end of the week
EndOfWeek := StartOfWeek;
IncBorlDOW(EndOfWeek, -1);
// Start working at the first of the month
WorkDate := EncodeDate(Year, Month, 1);
// Get the end of the month
EOM := EndOfMonth(WorkDate);
// Get the day the first falls on
DOW := DayOfWeek(WorkDate);
// Advance WorkDate to the end of the week
while DOW <> EndOfWeek do
begin
IncBorlDOW(DOW, 1);
WorkDate := WorkDate + 1;
end;
// We're now on week 1
Result := 1;
// Now roll through the rest of the month
while Trunc(WorkDate) < Trunc(EOM) do
begin
Inc(Result);
IncWeeks(WorkDate, 1);
end;
end;
procedure IncBorlDOW(var BorlDOW: Integer; N: Integer); // N defaults to 1
begin
BorlDOW := (BorlDOW + (N mod 7)) mod 7;
if BorlDOW = 0 then
BorlDOW := 7;
BorlDOW := Abs(BorlDOW);
end;
procedure IncDOW(var DOW: TTFDayOfWeek; N: Integer);
// N defaults to 1
var
BorlDOW: Integer;
begin
BorlDOW := DOWToBorl(DOW);
IncBorlDOW(BorlDOW, N);
DOW := BorlToDOW(BorlDOW);
end;
procedure IncDays(var ADate: TDateTime; N: Integer);
// N defaults to 1
begin
ADate := ADate + N;
end;
procedure IncWeeks(var ADate: TDateTime; N: Integer);
// N defaults to 1
begin
ADate := ADate + N * 7;
end;
procedure IncMonths(var ADate: TDateTime; N: Integer);
// N defaults to 1
var
Y, M, D, EOMD: Word;
X : Cardinal;
begin
DecodeDate(ADate, Y, M, D);
X := ((Y * 12) + M - 1 + N);
Y := X div 12;
M := (X mod 12) + 1;
// Be careful not to get invalid date in Feb.
if M = 2 then
begin
EOMD := ExtractDay(EndOfMonth(EncodeDate(Y, M, 1)));
if D > EOMD then
D := EOMD;
end;
ADate := EncodeDate(Y, M, D);
end;
procedure IncYears(var ADate: TDateTime; N: Integer);
// N defaults to 1
var
Y, M, D, EOMD: Word;
begin
DecodeDate(ADate, Y, M, D);
Inc(Y, N);
// Be careful not to get invalid date in Feb.
if M = 2 then
begin
EOMD := ExtractDay(EndOfMonth(EncodeDate(Y, M, 1)));
if D > EOMD then
D := EOMD;
end;
ADate := EncodeDate(Y, M, D);
end;
function EndOfMonth(ADate: TDateTime): TDateTime;
var
Y, M, D: Word;
begin
DecodeDate(ADate, Y, M, D);
Inc(M);
if M > 12 then
begin
M := 1;
Inc(Y);
end;
Result := EncodeDate(Y, M, 1) - 1;
end;
function IsFirstOfMonth(ADate: TDateTime): Boolean;
var
Y, M, D: Word;
begin
DecodeDate(ADate, Y, M, D);
Result := D = 1;
end;
function IsEndOfMonth(ADate: TDateTime): Boolean;
begin
Result := EqualDates(ADate, EndOfMonth(ADate));
end;
procedure EnsureMonth(Month: Word);
begin
if (Month < 1) or (Month > 12) then
raise EJvTFDateError.CreateResFmt(@RsEInvalidMonthValue, [Month]);
end;
procedure EnsureDOW(DOW: Word);
begin
if (DOW < 1) or (DOW > 7) then
raise EJvTFDateError.CreateResFmt(@RsEInvalidDayOfWeekValue, [DOW]);
end;
function EqualDates(D1, D2: TDateTime): Boolean;
begin
Result := Trunc(D1) = Trunc(D2);
end;
function ExtractHours(ATime: TDateTime): Word;
var
M, S, MS: Word;
begin
DecodeTime(ATime, Result, M, S, MS);
end;
function ExtractMins(ATime: TDateTime): Word;
var
H, S, MS: Word;
begin
DecodeTime(ATime, H, Result, S, MS);
end;
function ExtractSecs(ATime: TDateTime): Word;
var
H, M, MS: Word;
begin
DecodeTime(ATime, H, M, Result, MS);
end;
function ExtractMSecs(ATime: TDateTime): Word;
var
H, M, S: Word;
begin
DecodeTime(ATime, H, M, S, Result);
end;
function Lesser(N1, N2: Integer): Integer;
begin
if N1 < N2 then
Result := N1
else
Result := N2;
end;
function Greater(N1, N2: Integer): Integer;
begin
if N1 > N2 then
Result := N1
else
Result := N2;
end;
function GetDivLength(TotalLength, DivCount, DivNum: Integer): Integer;
begin
if (DivNum < 0) or (DivNum >= DivCount) then
Result := -1
else
begin
Result := TotalLength div DivCount;
if DivNum < TotalLength mod DivCount then
Inc(Result);
end;
end;
function GetDivNum(TotalLength, DivCount, X: Integer): Integer;
var
Base,
MakeUp,
MakeUpWidth: Integer;
begin
if (X < 0) or (X >= TotalLength) then
Result := -1
else
begin
Base := TotalLength div DivCount;
MakeUp := TotalLength mod DivCount;
MakeUpWidth := MakeUp * (Base + 1);
if X < MakeUpWidth then
Result := X div (Base + 1)
else
Result := (X - MakeUpWidth) div Base + MakeUp;
end;
end;
function GetDivStart(TotalLength, DivCount, DivNum: Integer): Integer;
var
Base,
MakeUp,
MakeUpWidth: Integer;
begin
if (DivNum < 0) or (DivNum >= DivCount) then
Result := -1
else
begin
Base := TotalLength div DivCount;
MakeUp := TotalLength mod DivCount;
MakeUpWidth := MakeUp * (Base + 1);
if DivNum <= MakeUp then
Result := DivNum * (Base + 1)
else
Result := (DivNum - MakeUp) * Base + MakeUpWidth;
end;
end;
function DOWToBorl(ADOW: TTFDayOfWeek): Integer;
begin
Result := Ord(ADOW) + 1;
end;
function BorlToDOW(BorlDOW: Integer): TTFDayOfWeek;
begin
Result := TTFDayOfWeek(BorlDOW - 1);
end;
function DateToDOW(ADate: TDateTime): TTFDayOfWeek;
var
BorlDOW: Integer;
begin
BorlDOW := DayOfWeek(ADate);
Result := BorlToDOW(BorlDOW);
end;
procedure CalcTextPos(ACanvas: TCanvas; HostRect: TRect; var TextLeft, TextTop: Integer;
var TextBounds: TRect; AFont: TFont; AAngle: Integer;
HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: String);
var
sinAngle, cosAngle: Extended;
size: TSize;
X, Y: Integer;
A, B, C, D: Integer;
lb, lt, rb, rt: TPoint;
begin
SinCos(AAngle * pi / 18000, sinAngle, cosAngle);
ACanvas.Font := AFont;
size := ACanvas.TextExtent(ATxt);
X := 0;
Y := 0;
if AAngle <= 90 then
begin { 1.Quadrant }
X := 0;
Y := Trunc(size.cx * sinAngle);
// Y := Trunc(Size.cx * Sin(AAngle * Pi / 180));
end
else
if AAngle <= 180 then
begin { 2.Quadrant }
X := Trunc(size.cx * -cosAngle);
// X := Trunc(Size.cx * -Cos(AAngle * Pi / 180));
Y := Trunc(size.cx * sinAngle + size.cy * -cosAngle);
// Y := Trunc(Size.cx * Sin(AAngle * Pi / 180) + Size.cy * Cos((180 - AAngle) * Pi / 180));
end
else
if AAngle <= 270 then
begin { 3.Quadrant }
X := Trunc(size.cx * -cosAngle + size.cy * -sinAngle);
// X := Trunc(Size.cx * -Cos(AAngle * Pi / 180) + Size.cy * Sin((AAngle - 180) * Pi / 180));
Y := Trunc(Size.cy * -cosAngle);
// Y := Trunc(Size.cy * Sin((270 - AAngle) * Pi / 180));
end
else
if AAngle <= 360 then
begin { 4.Quadrant }
X := Trunc(size.cy * -sinAngle);
// X := Trunc(Size.cy * Sin((360 - AAngle) * Pi / 180));
Y := 0;
end;
TextLeft := HostRect.Left + X;
TextTop := HostRect.Top + Y;
//ARect.Top := ARect.Top + Y;
//ARect.Left := ARect.Left + X;
X := Abs(Trunc(size.cx * cosAngle)) + Abs(Trunc(size.cy * sinAngle));
// X := Abs(Trunc(Size.cx * Cos(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Sin(AAngle * Pi / 180)));
Y := Abs(Trunc(size.cx * sinAngle)) + Abs(Trunc(size.cy * cosAngle));
// Y := Abs(Trunc(Size.cx * Sin(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Cos(AAngle * Pi / 180)));
case HAlign of
taCenter:
//ARect.Left := ARect.Left + ((RectWidth(SaveRect) - X) div 2);
TextLeft := TextLeft + ((RectWidth(HostRect) - X) div 2);
taRightJustify:
//ARect.Left := ARect.Left + RectWidth(SaveRect) - X;
TextLeft := TextLeft + RectWidth(HostRect) - X;
end;
case VAlign of
vaCenter:
//ARect.Top := ARect.Top + ((RectHeight(SaveRect) - Y) div 2);
TextTop := TextTop + ((RectHeight(HostRect) - Y) div 2);
vaBottom:
//ARect.Top := ARect.Top + RectHeight(SaveRect) - Y;
TextTop := TextTop + RectHeight(HostRect) - Y;
end;
//ARect.Right := ARect.Left + X;
//ARect.Bottom := ARect.Top + Y;
//********************************************
// calculate the border areas
A := Trunc(size.cy * sinAngle);
// A := Trunc(size.cy * Sin(AAngle * Pi / 180));
B := Trunc(size.cy * cosAngle);
// B := Trunc(size.cy * Cos(AAngle * Pi / 180));
C := Trunc(size.cx * cosAngle);
// C := Trunc(size.cx * Cos(AAngle * Pi / 180));
D := Trunc(size.cx * sinAngle);
// D := Trunc(Size.cx * Sin(AAngle * Pi / 180));
//lt := ARect.TopLeft;
lt := Point(TextLeft, TextTop);
lb := lt;
lb.X := lb.X + A;
lb.Y := lb.Y + B;
rb := lb;
rb.X := rb.X + C;
rb.Y := rb.Y - D;
rt := rb;
rt.X := rt.X - A;
rt.Y := rt.Y - B;
TextBounds.Left := Lesser(Lesser(lt.X, lb.X), Lesser(rb.X, rt.X));
TextBounds.Right := Greater(Greater(lt.X, lb.X), Greater(rb.X, rt.X));
TextBounds.Top := Lesser(Lesser(lt.Y, lb.Y), Lesser(rb.Y, rt.Y));
TextBounds.Bottom := Greater(Greater(lt.Y, lb.Y), Greater(rb.Y, rt.Y));
//*********************************************************************************************
end;
(*
//////////////////////////////////////////////////////////////////
// Credit for the CalcTextPos routine goes to Joerg Lingner. //
// It comes from his JLLabel component (freeware - Torry's). //
// It is used here with his permission. Thanks Joerg! //
// He can be reached at jlingner att t-online dott de //
//////////////////////////////////////////////////////////////////
procedure CalcTextPos(HostRect: TRect; var TextLeft, TextTop: Integer;
var TextBounds: TRect; AFont: TFont; AAngle: Integer;
HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: string);
{==========================================================================}
{ Calculate text pos. depend. on: Font, Escapement, Alignment and length }
{--------------------------------------------------------------------------}
var
DC: HDC;
hSavFont: HFONT;
Size: TSize;
X, Y: Integer;
//cStr : array[0..255] of Char;
PTxt: PChar;
A, B, C, D: Integer;
lb, lt, rb, rt: TPoint;
begin
AAngle := AAngle div 10;
PTxt := StrAlloc((Length(ATxt) + 4) * SizeOf(Char));
StrPCopy(PTxt, ATxt);
//StrPCopy(cStr, ATxt);
DC := GetDC(HWND_DESKTOP);
hSavFont := SelectObject(DC, AFont.Handle);
//GetTextExtentPoint32(DC, cStr, Length(ATxt), Size);
Windows.GetTextExtentPoint32(DC, PTxt, StrLen(PTxt), Size);
StrDispose(PTxt);
SelectObject(DC, hSavFont);
ReleaseDC(HWND_DESKTOP, DC);
X := 0;
Y := 0;
if AAngle <= 90 then
begin { 1.Quadrant }
X := 0;
Y := Trunc(Size.cx * Sin(AAngle * Pi / 180));
end
else
if AAngle <= 180 then
begin { 2.Quadrant }
X := Trunc(Size.cx * -Cos(AAngle * Pi / 180));
Y := Trunc(Size.cx * Sin(AAngle * Pi / 180) + Size.cy * Cos((180 - AAngle) * Pi / 180));
end
else
if AAngle <= 270 then
begin { 3.Quadrant }
X := Trunc(Size.cx * -Cos(AAngle * Pi / 180) + Size.cy * Sin((AAngle - 180) * Pi / 180));
Y := Trunc(Size.cy * Sin((270 - AAngle) * Pi / 180));
end
else
if AAngle <= 360 then
begin { 4.Quadrant }
X := Trunc(Size.cy * Sin((360 - AAngle) * Pi / 180));
Y := 0;
end;
TextLeft := HostRect.Left + X;
TextTop := HostRect.Top + Y;
//ARect.Top := ARect.Top + Y;
//ARect.Left := ARect.Left + X;
X := Abs(Trunc(Size.cx * Cos(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Sin(AAngle * Pi / 180)));
Y := Abs(Trunc(Size.cx * Sin(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Cos(AAngle * Pi / 180)));
case HAlign of
taCenter:
//ARect.Left := ARect.Left + ((RectWidth(SaveRect) - X) div 2);
TextLeft := TextLeft + ((RectWidth(HostRect) - X) div 2);
taRightJustify:
//ARect.Left := ARect.Left + RectWidth(SaveRect) - X;
TextLeft := TextLeft + RectWidth(HostRect) - X;
end;
case VAlign of
vaCenter:
//ARect.Top := ARect.Top + ((RectHeight(SaveRect) - Y) div 2);
TextTop := TextTop + ((RectHeight(HostRect) - Y) div 2);
vaBottom:
//ARect.Top := ARect.Top + RectHeight(SaveRect) - Y;
TextTop := TextTop + RectHeight(HostRect) - Y;
end;
//ARect.Right := ARect.Left + X;
//ARect.Bottom := ARect.Top + Y;
//********************************************
// calculate the border areas
A := Trunc(Size.cy * Sin(AAngle * Pi / 180));
B := Trunc(Size.cy * Cos(AAngle * Pi / 180));
C := Trunc(Size.cx * Cos(AAngle * Pi / 180));
D := Trunc(Size.cx * Sin(AAngle * Pi / 180));
//lt := ARect.TopLeft;
lt := Point(TextLeft, TextTop);
lb := lt;
lb.X := lb.X + A;
lb.Y := lb.Y + B;
rb := lb;
rb.X := rb.X + C;
rb.Y := rb.Y - D;
rt := rb;
rt.X := rt.X - A;
rt.Y := rt.Y - B;
TextBounds.Left := Lesser(Lesser(lt.X, lb.X), Lesser(rb.X, rt.X));
TextBounds.Right := Greater(Greater(lt.X, lb.X), Greater(rb.X, rt.X));
TextBounds.Top := Lesser(Lesser(lt.Y, lb.Y), Lesser(rb.Y, rt.Y));
TextBounds.Bottom := Greater(Greater(lt.Y, lb.Y), Greater(rb.Y, rt.Y));
//*********************************************************************************************
end; *)
procedure DrawAngleText(ACanvas: TCanvas; HostRect: TRect;
var TextBounds: TRect; AAngle: Integer; HAlign: TAlignment;
VAlign: TJvTFVAlignment; ATxt: string);
var
// LogFont: TLogFont;
TxtRect: TRect;
Flags: UINT;
PTxt: PChar;
ClipRgn: HRgn;
TextLeft, TextTop: Integer;
ts: TTextStyle;
begin
//TxtRect := ARect;
CalcTextPos(ACanvas, HostRect, TextLeft, TextTop, TextBounds, ACanvas.Font,
AAngle, HAlign, VAlign, ATxt);
ACanvas.Font.Orientation := AAngle;
{
Windows.GetObject(ACanvas.Font.Handle, SizeOf(LogFont), @LogFont);
LogFont.lfEscapement := AAngle;
LogFont.lfOrientation := LogFont.lfEscapement;
ACanvas.Font.Handle := CreateFontIndirect(LogFont);
Flags := DT_NOPREFIX or DT_LEFT or DT_TOP or DT_NOCLIP or DT_SINGLELINE;
}
ts := ACanvas.TextStyle;
ts.Alignment := taLeftJustify;
ts.Layout := tlTop;
ts.Clipping := false; // why need a ClipRect then?
{
PTxt := StrAlloc((Length(ATxt) + 4) * SizeOf(Char));
StrPCopy(PTxt, ATxt);
}
//ClipRgn := Windows.CreateRectRgn(ARect.Left, ARect.Top,
// ARect.Right, ARect.Bottom);
ACanvas.ClipRect := HostRect;
{
ClipRgn := Windows.CreateRectRgn(HostRect.Left, HostRect.Top,
HostRect.Right, HostRect.Bottom);
Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);
}
//Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);
TxtRect := Rect(TextLeft, TextTop, TextLeft + 1, TextTop + 1);
ACanvas.TextRect(TxtRect, TxtRect.Left, TxtRect.Top, ATxt, ts);
// Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);
{
Windows.SelectClipRgn(ACanvas.Handle, 0);
Windows.DeleteObject(ClipRgn);
StrDispose(PTxt);
ACanvas.Font.Handle := 0;
}
//ARect := TxtRect;
end;
(*
procedure DrawAngleText(ACanvas: TCanvas; HostRect: TRect;
var TextBounds: TRect; AAngle: Integer; HAlign: TAlignment;
VAlign: TJvTFVAlignment; ATxt: string);
var
LogFont: TLogFont;
TxtRect: TRect;
Flags: UINT;
PTxt: PChar;
ClipRgn: HRgn;
TextLeft,
TextTop: Integer;
begin
//TxtRect := ARect;
//CalcTextPos(TxtRect, ACanvas.Font, AAngle, HAlign, VAlign, ATxt);
CalcTextPos(HostRect, TextLeft, TextTop, TextBounds, ACanvas.Font, AAngle,
HAlign, VAlign, ATxt);
Windows.GetObject(ACanvas.Font.Handle, SizeOf(LogFont), @LogFont);
LogFont.lfEscapement := AAngle;
LogFont.lfOrientation := LogFont.lfEscapement;
ACanvas.Font.Handle := CreateFontIndirect(LogFont);
Flags := DT_NOPREFIX or DT_LEFT or DT_TOP or DT_NOCLIP or DT_SINGLELINE;
PTxt := StrAlloc((Length(ATxt) + 4) * SizeOf(Char));
StrPCopy(PTxt, ATxt);
//ClipRgn := Windows.CreateRectRgn(ARect.Left, ARect.Top,
// ARect.Right, ARect.Bottom);
ClipRgn := Windows.CreateRectRgn(HostRect.Left, HostRect.Top,
HostRect.Right, HostRect.Bottom);
Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);
//Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);
TxtRect := Rect(TextLeft, TextTop, TextLeft + 1, TextTop + 1);
Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);
Windows.SelectClipRgn(ACanvas.Handle, 0);
Windows.DeleteObject(ClipRgn);
StrDispose(PTxt);
ACanvas.Font.Handle := 0;
//ARect := TxtRect;
end;
*)
function RectWidth(ARect: TRect): Integer;
begin
Result := ARect.Right - ARect.Left;
end;
function RectHeight(ARect: TRect): Integer;
begin
Result := ARect.Bottom - ARect.Top;
end;
function EmptyRect: TRect;
begin
Result := Rect(0, 0, 0, 0);
end;
function IsClassByName(Obj: TObject; ClassName: string): Boolean;
var
ClassRef: TClass;
begin
Result := False;
ClassRef := Obj.ClassType;
while (ClassRef <> nil) and not Result do
if ClassRef.ClassName = ClassName then
Result := True
else
ClassRef := ClassRef.ClassParent;
end;
{ Routines copied from JcStrings }
function StringsToStr(const List: TStrings; const Sep: string;
const AllowEmptyString: Boolean = True): string;
var
I, L: SizeInt;
begin
Result := '';
for I := 0 to List.Count - 1 do
begin
if (List[I] <> '') or AllowEmptyString then
begin
// don't combine these into one addition, somehow it hurts performance
Result := Result + List[I];
Result := Result + Sep;
end;
end;
// remove terminating separator
if List.Count > 0 then
begin
L := Length(Sep);
Delete(Result, Length(Result) - L + 1, L);
end;
end;
end.

494
components/jvcllaz/run/JvTimeFramework/jvtfweeks.pas Normal file
View File

@ -0,0 +1,494 @@
{-----------------------------------------------------------------------------
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: JvTFWeeks.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 JvTFWeeks;
{$mode objfpc}{$H+}
interface
uses
LCLIntf, LCLType, LMessages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
JvTFManager, JvTFGlance, JvTFUtils;
type
TJvTFDispOrder = (doLeftRight, doTopBottom);
TJvTFWeeks = class(TJvTFCustomGlance)
private
FWeekCount: Integer;
FDisplayDays: TTFDaysOfWeek;
FSplitDay: TTFDayOfWeek;
FIgnoreSplit: Boolean;
FDisplayOrder: TJvTFDispOrder;
FDWNames: TJvTFDWNames;
FDWTitleAttr: TJvTFGlanceTitle;
FOnDrawDWTitle: TJvTFDrawDWTitleEvent;
FOnUpdateTitle: TJvTFUpdateTitleEvent;
function GetDisplayDate: TDate;
procedure SetDisplayDate(Value: TDate);
procedure SetWeekCount(Value: Integer);
procedure SetDisplayDays(Value: TTFDaysOfWeek);
procedure SetSplitDay(Value: TTFDayOfWeek);
procedure SetIgnoreSplit(Value: Boolean);
procedure SetDisplayOrder(Value: TJvTFDispOrder);
procedure SetDWNames(Value: TJvTFDWNames);
procedure SetDWTitleAttr(Value: TJvTFGlanceTitle);
protected
procedure ConfigCells; override;
procedure SetStartOfWeek(Value: TTFDayOfWeek); override;
procedure DWNamesChange(Sender: TObject);
procedure Navigate(AControl: TJvTFControl; ASchedNames: TStringList;
Dates: TJvTFDateList); override;
function GetSplitParentDay: TTFDayOfWeek;
function GetCellTitleText(Cell: TJvTFGlanceCell): string; override;
// draws the DW Titles
procedure DrawTitle(ACanvas: TCanvas); override;
procedure UpdateTitle;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetDataTop: Integer; override;
function DisplayDayCount: Integer;
procedure PrevWeek;
procedure NextWeek;
published
property DisplayDate: TDate read GetDisplayDate write SetDisplayDate;
property DisplayDays: TTFDaysOfWeek read FDisplayDays write SetDisplayDays
default [dowSunday..dowSaturday];
property DisplayOrder: TJvTFDispOrder read FDisplayOrder write SetDisplayOrder;
property DWNames: TJvTFDWNames read FDWNames write SetDWNames;
property DWTitleAttr: TJvTFGlanceTitle read FDWTitleAttr write SetDWTitleAttr;
property IgnoreSplit: Boolean read FIgnoreSplit write SetIgnoreSplit default False;
property SplitDay: TTFDayOfWeek read FSplitDay write SetSplitDay default dowSunday;
property WeekCount: Integer read FWeekCount write SetWeekCount default 1;
property OnDrawDWTitle: TJvTFDrawDWTitleEvent read FOnDrawDWTitle write FOnDrawDWTitle;
property OnUpdateTitle: TJvTFUpdateTitleEvent read FOnUpdateTitle write FOnUpdateTitle;
property StartOfWeek default dowMonday;
// property Navigator;
// property OnNavigate;
end;
implementation
uses
JvResources;
procedure TJvTFWeeks.ConfigCells;
var
Row, Col, CalcRowCount: Integer;
CurrDate: TDateTime;
DayToSplit: TTFDayOfWeek;
CanSplit: Boolean;
procedure DisplayDateCheck;
begin
while not (DateToDOW(CurrDate) in DisplayDays) do
IncDays(CurrDate, 1);
end;
procedure ConfigCell(ACell: TJvTFGlanceCell);
var
TestDay: TTFDayOfWeek;
begin
DisplayDateCheck;
SetCellDate(ACell, CurrDate);
TestDay := DateToDOW(CurrDate);
IncDays(CurrDate, 1);
if (TestDay = DayToSplit) and (SplitDay in DisplayDays) and CanSplit then
begin
SplitCell(ACell);
DisplayDateCheck;
SetCellDate(ACell.Subcell, CurrDate);
IncDays(CurrDate, 1);
end
else
CombineCell(ACell);
end;
begin
if WeekCount = 1 then
begin
ColCount := 2;
CalcRowCount := DisplayDayCount;
if Odd(CalcRowCount) and not (SplitDay in DisplayDays) then
Inc(CalcRowCount);
RowCount := CalcRowCount div 2;
CanSplit := not IgnoreSplit and Odd(DisplayDayCount);
end
else
begin
if not IgnoreSplit and (SplitDay in DisplayDays) then
ColCount := DisplayDayCount - 1
else
ColCount := DisplayDayCount;
RowCount := WeekCount;
CanSplit := not IgnoreSplit;
end;
DayToSplit := GetSplitParentDay;
CurrDate := OriginDate;
if DisplayOrder = doLeftRight then
for Row := 0 to RowCount - 1 do
for Col := 0 to ColCount - 1 do
ConfigCell(Cells.Cells[Col, Row])
else
for Col := 0 to ColCount - 1 do
for Row := 0 to RowCount - 1 do
ConfigCell(Cells.Cells[Col, Row]);
inherited ConfigCells;
end;
constructor TJvTFWeeks.Create(AOwner: TComponent);
begin
FWeekCount := 1;
FDisplayDays := DOW_WEEK;
FSplitDay := dowSunday;
FIgnoreSplit := False;
inherited Create(AOwner);
GapSize := 4;
CellAttr.TitleAttr.Color := clWhite;
CellAttr.TitleAttr.FrameAttr.Color := clGray;
FDWNames := TJvTFDWNames.Create;
FDWNames.OnChange := @DWNamesChange;
FDWTitleAttr := TJvTFGlanceTitle.Create(Self);
with FDWTitleAttr do
begin
Assign(TitleAttr);
TxtAttr.Font.Size := 8;
Height := 20;
OnChange := @GlanceTitleChange;
end;
StartOfWeek := dowMonday;
DisplayDate := Date;
end;
destructor TJvTFWeeks.Destroy;
begin
FDWNames.OnChange := nil;
FDWNames.Free;
FDWTitleAttr.OnChange := nil;
FDWTitleAttr.Free;
inherited Destroy;
end;
function TJvTFWeeks.DisplayDayCount: Integer;
var
DOW: TTFDayOfWeek;
begin
Result := 0;
for DOW := Low(TTFDayOfWeek) to High(TTFDayOfWeek) do
if DOW in DisplayDays then
Inc(Result);
end;
procedure TJvTFWeeks.DrawTitle(ACanvas: TCanvas);
var
I, Col, LineBottom: Integer;
SplitParentDay, CurrDOW: TTFDayOfWeek;
ARect, TempRect, TxtRect, TextBounds: TRect;
OldPen: TPen;
OldBrush: TBrush;
OldFont: TFont;
Txt: string;
procedure CheckCurrDOW;
begin
while not (CurrDOW in DisplayDays) do
IncDOW(CurrDOW, 1);
end;
begin
inherited DrawTitle(ACanvas);
// Don't draw the DW Titles if we're only showing one week.
if not DWTitleAttr.Visible or (WeekCount = 1) then
Exit;
with ACanvas do
begin
OldPen := TPen.Create;
OldPen.Assign(Pen);
OldBrush := TBrush.Create;
OldBrush.Assign(Brush);
OldFont := TFont.Create;
OldFont.Assign(Font);
end;
// draw the DWTitles
ARect.Top := inherited GetDataTop;
ARect.Bottom := GetDataTop;
CurrDOW := StartOfWeek;
SplitParentDay := GetSplitParentDay;
for Col := 0 to ColCount - 1 do
begin
TempRect := WholeCellRect(Col, 0);
ARect.Left := TempRect.Left;
ARect.Right := TempRect.Right;
TxtRect := ARect;
InflateRect(TxtRect, -1, -1);
with ACanvas do
begin
Brush.Color := DWTitleAttr.Color;
FillRect(ARect);
case DWTitleAttr.FrameAttr.Style of
fs3DRaised:
Draw3DFrame(ACanvas, ARect, clBtnHighlight, clBtnShadow);
fs3DLowered:
Draw3DFrame(ACanvas, ARect, clBtnShadow, clBtnHighlight);
fsFlat:
begin
Pen.Color := DWTitleAttr.FrameAttr.Color;
Pen.Width := DWTitleAttr.FrameAttr.Width;
if Col = 0 then
begin
MoveTo(ARect.Left, ARect.Top);
LineTo(ARect.Left, ARect.Bottom);
end;
Polyline([
Point(ARect.Right - 1, ARect.Top),
Point(ARect.Right - 1, ARect.Bottom - 1),
Point(ARect.Left - 1, ARect.Bottom - 1)
]);
end;
fsNone:
begin
Pen.Color := DWTitleAttr.FrameAttr.Color;
Pen.Width := 1;
LineBottom := ARect.Bottom - 1;
for I := 1 to DWTitleAttr.FrameAttr.Width do
begin
MoveTo(ARect.Left, LineBottom);
LineTo(ARect.Right, LineBottom);
Dec(LineBottom);
end;
end;
end;
CheckCurrDOW;
Txt := DWNames.GetDWName(DOWToBorl(CurrDOW));
if (CurrDOW = SplitParentDay) and (SplitDay in DisplayDays) and not IgnoreSplit then
begin
IncDOW(CurrDOW, 1);
CheckCurrDOW;
Txt := Txt + '/' + DWNames.GetDWName(DOWToBorl(CurrDOW));
end;
Font := DWTitleAttr.TxtAttr.Font;
DrawAngleText(ACanvas, TxtRect, TextBounds,
DWTitleAttr.TxtAttr.Rotation,
DWTitleAttr.TxtAttr.AlignH,
DWTitleAttr.TxtAttr.AlignV, Txt);
end;
if Assigned(FOnDrawDWTitle) then
FOnDrawDWTitle(Self, ACanvas, ARect, CurrDOW, Txt);
IncDOW(CurrDOW, 1);
end;
with ACanvas do
begin
Pen.Assign(OldPen);
Brush.Assign(OldBrush);
Font.Assign(OldFont);
OldPen.Free;
OldBrush.Free;
OldFont.Free;
end;
end;
procedure TJvTFWeeks.DWNamesChange(Sender: TObject);
begin
UpdateCellTitles;
Invalidate;
end;
function TJvTFWeeks.GetCellTitleText(Cell: TJvTFGlanceCell): string;
begin
Result := '';
//Result := FormatDateTime('dddd, mmm d', Cell.CellDate);
if Assigned(DWNames) then
begin
if WeekCount = 1 then
Result := DWNames.GetDWName(DayOfWeek(Cell.CellDate)) + ', ';
if DateFormat = '' then
Result := Result + FormatDateTime('mmm d', Cell.CellDate)
else
Result := Result + FormatDateTime(DateFormat, Cell.CellDate);
end
else
Result := FormatDateTime(DateFormat, Cell.CellDate);
end;
function TJvTFWeeks.GetDataTop: Integer;
begin
Result := inherited GetDataTop;
if DWTitleAttr.Visible and (WeekCount > 1) then
Inc(Result, DWTitleAttr.Height);
end;
function TJvTFWeeks.GetDisplayDate: TDate;
begin
Result := StartDate;
end;
function TJvTFWeeks.GetSplitParentDay: TTFDayOfWeek;
begin
Result := SplitDay;
IncDOW(Result, -1);
while not (Result in DisplayDays) and (Result <> SplitDay) do
IncDOW(Result, -1);
end;
procedure TJvTFWeeks.Navigate(AControl: TJvTFControl;
ASchedNames: TStringList; Dates: TJvTFDateList);
begin
inherited Navigate(AControl, ASchedNames, Dates);
if Dates.Count > 0 then
DisplayDate := Dates[0];
end;
procedure TJvTFWeeks.NextWeek;
begin
DisplayDate := DisplayDate + 7;
end;
procedure TJvTFWeeks.PrevWeek;
begin
DisplayDate := DisplayDate - 7;
end;
procedure TJvTFWeeks.SetDisplayDate(Value: TDate);
begin
StartDate := Value;
UpdateTitle;
end;
procedure TJvTFWeeks.SetDisplayDays(Value: TTFDaysOfWeek);
begin
if Value = [] then
Exit;
if Value <> FDisplayDays then
begin
FDisplayDays := Value;
ReconfigCells;
end;
end;
procedure TJvTFWeeks.SetDisplayOrder(Value: TJvTFDispOrder);
begin
if WeekCount > 1 then
Value := doLeftRight;
if Value <> FDisplayOrder then
begin
FDisplayOrder := Value;
ReconfigCells;
end;
end;
procedure TJvTFWeeks.SetDWNames(Value: TJvTFDWNames);
begin
FDWNames.Assign(Value);
end;
procedure TJvTFWeeks.SetDWTitleAttr(Value: TJvTFGlanceTitle);
begin
FDWTitleAttr.Assign(Value);
end;
procedure TJvTFWeeks.SetIgnoreSplit(Value: Boolean);
begin
if Value <> FIgnoreSplit then
begin
FIgnoreSplit := Value;
ReconfigCells;
end;
end;
procedure TJvTFWeeks.SetSplitDay(Value: TTFDayOfWeek);
begin
if Value <> FSplitDay then
begin
FSplitDay := Value;
ReconfigCells;
end;
end;
procedure TJvTFWeeks.SetStartOfWeek(Value: TTFDayOfWeek);
begin
if not IgnoreSplit and (Value = SplitDay) then
IncDOW(Value, -1);
inherited SetStartOfWeek(Value);
end;
procedure TJvTFWeeks.SetWeekCount(Value: Integer);
begin
Value := Greater(Value, 1);
if Value <> FWeekCount then
begin
DisplayOrder := doLeftRight;
FWeekCount := Value;
ReconfigCells;
end;
end;
procedure TJvTFWeeks.UpdateTitle;
var
NewTitle: string;
begin
NewTitle := Format(RsWeekOf, [FormatDateTime('mmm d, yyyy', OriginDate)]);
if NewTitle <> TitleAttr.Title then
begin
if Assigned(FOnUpdateTitle) then
FOnUpdateTitle(Self, NewTitle);
TitleAttr.Title := NewTitle;
end;
end;
end.