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

10
components/jvcllaz/design/JvTimeFramework/images/images.txt Normal file
View File

@ -0,0 +1,10 @@
tjvtfalarm.bmp
tjvtfdays.bmp
tjvtfdaysprinter.bmp
tjvtfglance.bmp
tjvtfglancetextviewer.bmp
tjvtfmonths.bmp
tjvtfnavigator.bmp
tjvtfschedulemanager.bmp
tjvtfuniversalprinter.bmp
tjvtfweeks.bmp

1
components/jvcllaz/design/JvTimeFramework/images/make_res.bat Normal file
View File

@ -0,0 +1 @@
lazres ../../../resource/jvtimeframeworkreg.res @images.txt

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfalarm.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfdays.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfdaysprinter.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfglance.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfglancetextviewer.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfmonths.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfnavigator.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfschedulemanager.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfuniversalprinter.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
components/jvcllaz/design/JvTimeFramework/images/tjvtfweeks.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

48
components/jvcllaz/design/JvTimeFramework/jvtimeframeworkreg.pas Normal file
View File

@ -0,0 +1,48 @@
unit JvTimeFrameworkReg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
procedure Register;
implementation
{$R ../../resource/jvtimeframeworkreg.res}
uses
//Controls,
JvDsgnConsts,
JvTFGlance, JvTFGlanceTextViewer, JvTFMonths, JvTFWeeks, JvTFDays,
JvTFAlarm, JvTFManager;
procedure Register;
begin
RegisterComponents(RsPaletteJvclVisual, [
TJvTFScheduleManager,
TJvTFMonths, TJvTFWeeks, TJvTFDays, TJvTFAlarm, TJvTFGlanceTextViewer,
TJvTFUniversalPrinter, TJvTFDaysPrinter
]);
// RegisterPropertyEditor(TypeInfo(TJvTFGlanceCells, TJvTFMonths, 'Cells', nil);
(*
// RegisterPropertyEditor(TypeInfo(string), TJvTFControl, 'Version', TutfVersionEditor);
// RegisterPropertyEditor(TypeInfo(string), TJvTFScheduleManager, 'Version', TutfVersionEditor);
RegisterComponents(RsPaletteTimeFramework, [TJvTFGlanceTextViewer, TJvTFMonths,
TJvTFWeeks, TJvTFAlarm]);
// RegisterPropertyEditor(TypeInfo(TJvTFGlanceCells), '', 'Cells',
// TJvTFGlanceCellsProperty);
// register a nil property editor for now, so cells cannot be added,
// deleted, or moved at design time... BAD THINGS HAPPEN
RegisterPropertyEditor(TypeInfo(TJvTFGlanceCells), TJvTFMonths, 'Cells', nil);
RegisterComponents(RsPaletteTimeFramework, [TJvTFDays, TJvTFDaysPrinter]);
*)
end;
end.

BIN
components/jvcllaz/examples/JvTimeFramework/Data.sqlite Normal file
View File

Binary file not shown.

127
components/jvcllaz/examples/JvTimeFramework/JvTimeFrameDemo.lpi Normal file
View File

@ -0,0 +1,127 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="JvTimeFrameDemo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="6">
<Item1>
<PackageName Value="Printer4Lazarus"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
<Item3>
<PackageName Value="DateTimeCtrls"/>
</Item3>
<Item4>
<PackageName Value="SQLDBLaz"/>
</Item4>
<Item5>
<PackageName Value="JvTimeFrameworkLazR"/>
</Item5>
<Item6>
<PackageName Value="LCL"/>
</Item6>
</RequiredPackages>
<Units Count="6">
<Unit0>
<Filename Value="JvTimeFrameDemo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="tfmain.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="PhotoOpMain"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="tfMain"/>
</Unit1>
<Unit2>
<Filename Value="tfvisibleresources.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="VisibleResources"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="tfVisibleResources"/>
</Unit2>
<Unit3>
<Filename Value="tfshare.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="tfShare"/>
</Unit3>
<Unit4>
<Filename Value="tfapptedit.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="ApptEdit"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="tfApptEdit"/>
</Unit4>
<Unit5>
<Filename Value="tfprintprogress.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="PrintProgress"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="tfPrintProgress"/>
</Unit5>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="../../bin/$(TargetCPU)-$(TargetOS)/JvTimeFrameDemo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

35
components/jvcllaz/examples/JvTimeFramework/JvTimeFrameDemo.lpr Normal file
View File

@ -0,0 +1,35 @@
program JvTimeFrameDemo;
{%File 'dbUTF'}
uses
InterfaceBase, SysUtils, Dialogs,
Forms, datetimectrls, printer4lazarus, Interfaces,
tfMain in 'PhotoOpUnit.pas' {PhotoOpMain},
tfVisibleResources in 'VisibleResourcesUnit.pas' {VisibleResources},
tfShare in 'ShareUnit.pas' {Share},
tfApptEdit in 'ApptEditUnit.pas' {ApptEdit},
tfPrintProgress in 'PrintProgressUnit.pas' {PrintProgress};
{$R *.res}
var
fn: String;
begin
Application.Scaled:=True;
Application.Initialize;
fn := Application.Location + 'data.sqlite';
if not FileExists(fn) then begin
MessageDlg('Database file "' + fn + '" not found. Copy it from the source directory to here.',
mtError, [mbOK], 0);
Halt;
end;
Application.CreateForm(TPhotoOpMain, PhotoOpMain);
Application.CreateForm(TVisibleResources, VisibleResources);
Application.CreateForm(TShare, Share);
Application.CreateForm(TApptEdit, ApptEdit);
Application.CreateForm(TPrintProgress, PrintProgress);
Application.Run;
end.

18
components/jvcllaz/examples/JvTimeFramework/readme.txt Normal file
View File

@ -0,0 +1,18 @@
The JvTimeFrameDemo of the JVCL Lazarus port uses an SQLite3 database to store
the data. In order to run this demo you must have SQLite3 installed, or you must
copy the sqlite3.dll to the folder with JvTimeFrameDemo.exe.
It is also required to copy the data base file, data.sqlite, from the source
directory (the directory which contains this readme.txt) to the folder with
JvTimeFrameDemo.exe.
--------------------------------------------------------------------------------
Original text:
The PhotoOp demo uses a Paradox database to store the data. In order to run this
demo, you need to have the BDE installed and correctly configured. In addition,
the path to the data is restricted in Paradox. If you get an error about the
path being too long when you start the application, copy the executable and
the \Data subfolder from the source folder to a folder with a shorter path and
run the demo from that location instead.

389
components/jvcllaz/examples/JvTimeFramework/tfapptedit.lfm Normal file
View File

@ -0,0 +1,389 @@
object ApptEdit: TApptEdit
Left = 218
Height = 210
Top = 152
Width = 350
AutoSize = True
Caption = 'ApptEdit'
ClientHeight = 210
ClientWidth = 350
Color = clBtnFace
Font.Color = clWindowText
OnClose = FormClose
OnShow = FormShow
Position = poScreenCenter
LCLVersion = '2.1.0.0'
Scaled = False
object Bevel1: TBevel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 6
Height = 10
Top = 29
Width = 338
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
BorderSpacing.Right = 6
Shape = bsBottomLine
end
object Bevel2: TBevel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = EndDatePicker
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 6
Height = 10
Top = 97
Width = 338
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
BorderSpacing.Right = 6
Shape = bsBottomLine
end
object Label1: TLabel
AnchorSideLeft.Control = Image1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = StartDatePicker
AnchorSideTop.Side = asrCenter
Left = 50
Height = 15
Top = 51
Width = 56
BorderSpacing.Left = 12
Caption = 'Start &Time:'
FocusControl = StartDatePicker
ParentColor = False
end
object Label3: TLabel
AnchorSideLeft.Control = Label1
AnchorSideTop.Control = EndDatePicker
AnchorSideTop.Side = asrCenter
Left = 50
Height = 15
Top = 78
Width = 52
Caption = '&End Time:'
FocusControl = EndDatePicker
ParentColor = False
end
object Label5: TLabel
AnchorSideLeft.Control = UpDown1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = AlarmAdvanceEdit
AnchorSideTop.Side = asrCenter
Left = 192
Height = 15
Top = 119
Width = 80
BorderSpacing.Left = 8
BorderSpacing.Right = 6
Caption = 'minutes before'
ParentColor = False
end
object Label6: TLabel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Edit1
AnchorSideTop.Side = asrCenter
Left = 6
Height = 15
Top = 10
Width = 42
BorderSpacing.Left = 6
Caption = '&Subject:'
FocusControl = Edit1
ParentColor = False
end
object Image1: TImage
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Bevel1
AnchorSideTop.Side = asrBottom
Left = 6
Height = 32
Top = 47
Width = 32
AutoSize = True
BorderSpacing.Left = 6
BorderSpacing.Top = 8
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869633006000089504E47
0D0A1A0A0000000D4948445200000020000000200806000000737A7AF4000005
F7494441545885D596DD53135718C6BDE81FD10B2FFB2778D90BEFFA310326BB
212ACE74A622524BA58C1843BAC9D92C84AAD4CAA0A2824644B47C683AC340B2
399BC4E84C35241A3F08042480094128109290F02DF0F44241680802ED45FBDC
ED39EFEEEFD9739EF3EEEEDAF57FD2D72AF3A7193F998FC8096D6678C925D759
07E53AEB20C34B2E39A1CD193F998F30A72CBBFF757066B1F94B86977C324E5C
C8A9684F16D5BE82BABE1FDAC610B48D21A8EBFB71E2460F722ADCD3324E5C60
78C997A1B1C8FE399833EF51E86D5D0ABD6D4A5DDF8FB3E62848731805359DC8
AFF222AFD285BC4A17BEBFF414C7AB7DD0350DA2DC1243F1ED016409F604AB97
7A3339F39E1DC1F7973AF3E45A71A6D0D8BD7CA66D023F5EEB44B6C18E43061B
2A4D1DB8F7B00F0E6F180E6F184DCE002E983A70C86047B6C18EC21A1FCEB44D
A0D0E85F9671E2C27E83A3705B7086500D43E8BCAE69105C4310D906074E55BB
F0A26F1C6B35164F62249A5837F6A26F1CEA6A17F697D8A0B93300FEEE101842
E7153CADD8F29B3384CE08A61114DF7A05A59EE2FEF321FC5DCBCBCB68F707F1
B8EB3516979652E63D3DA33850224155DB85B29631B0449A3950E6546F0ACFE4
CC7BE43AEBACAE691045B53D3864B021F46722E5E12B8A4FCD20969C4919AFFF
DD0E00088F25917BEE010A6A7C104CC390EBC4F90CAEF5F3B4061482D45978DD
BFC83504A1D4D34DE1E9D4DCF610576EB7AE5E0F47A6A1D45368EE0CE0E4CD5E
B0BC14DA10CE0A8E0C855E9A3AD336816C8303CE0D96FD63F2F5BC4681BE0A13
B1C975E3DEDE31280509A75B2350963A120AC19E971A3C5EF2A9EBFBA1AAED42
D115D7B6E18B8B4BD0FD7A137F3CF16D38CF193D28BADE01AE2108865883EBE0
5FABCC9FCA3871E1AC398A6C833D25ED5BD16F2DF771ADC19C763E3014074BAC
28B7C4C0123A9559DCF2D9AA817D5A31EFDB73AE08690EE390C1B66DF8F3AE3E
9C28BD8A78626AD3BAC3E54E700D41E454786272420DAB06E4843617D5BE4241
4D272A4D1DDB82CFCD2F40536E84EB99FFA3B5464B37F22F3F87AA2E009648D6
0F01D44BEDEAFA7EFC70D98B7B0FFBB6045E5A5A42FBF36EFC52DD8CEB8DE296
EE11DD21E45FF240DB18024B68CF8700123AA86D0CE1BB4A171CDE30466349B4
FB83884FA59EF1153D7477E0A8A602473515303BDD69EB923373707707313231
094FCF288E9E7F04C13402B9CE1A496B60249AC0E3AED78826A6D33EF841FBCB
5503C6A6F42B30393D8BC75DAF31341E4F6F40C14B6E757D3FF2AB9EAE6EC146
ED75AD16DEBEC5FDC72F70F31EC5514D05BCBEDEB4B54BCBCB0036DB029EDE2D
AA7D85E3D53E5CD8660801C0EBEBFDA809E07D08AB9E4155170043A8F421843A
E9BB6F7F754DE89A0677740CB76A62E5181EA9F4C419BDF4F387153865D92DE3
C485724B6CC78D68AD894432353B2B8DE8AC399ADA88DE07D15F7C7B00AA1B9D
38B98356FC3191DA2728BAF6125C43107242DFA47C0BE444CACA12EC89336D13
D85F6283B777EC5F83FB835164E9294EB74670D0E08CB182949F62E07D43EA2D
34762F6AEE0C40A9A7088F25FF313C129F45B6C186E2FAC0BB0EC8D3F05EBDF3
930D0D6472E63D324E5CE0EF0EA1A0C687DC730F301C49DF0B923373989C9EDD
149E7BEE010AAA3B20988621D38A730A42BFDA10BEA28306472143E86C59CB18
4EDEE884524FD36E87BBFBDD2FD9CA395F2B7F308A6C830D45D77D286B194396
609B3A50E22CDD14BE22054F2B585E9A174CC328BE3D00A52081AF7D8281E1F5
3F1A231393181A8FAF1B0B0CC5517AEB29B2F414AABA0004D330B24AEC732CB1
D66C09BEA203654EB54C2BCE9DBCD98BD3AD111CBFFA122CB122A7DC09A3A51B
A23B044FCF283C3DA310DD21182DDDC829778225561CBFF202A75B2350D50520
D38A735B7EF39495D08B7B595E0A294B1D09AE2188B3E628B88620F2AB9EE1D8
450F72CF3F42EEF9473876D183FCAA67585B73D0E08CB13C0DB3C4F6C58EE06B
B54F67FD8621D62043E8746EE59359555D00DAC61004D30804D308B48D21A8EA
02C8AD7C3ACF103A2D27F44DA6CE72386DDA77AACCE296CFF67116C212C9CA10
EA97EBACE3729D759C21D4CF102AEDE32C24A5C3FDD7F517CAA592C8B12E2C19
0000000049454E44AE426082
}
Transparent = True
end
object Image2: TImage
AnchorSideLeft.Control = Image1
AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = Bevel2
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Image1
AnchorSideRight.Side = asrBottom
Left = 14
Height = 24
Top = 115
Width = 24
Anchors = [akTop, akRight]
AutoSize = True
BorderSpacing.Top = 8
BorderSpacing.Bottom = 8
Picture.Data = {
1754506F727461626C654E6574776F726B477261706869633102000089504E47
0D0A1A0A0000000D4948445200000018000000180806000000E0773DF8000001
F8494441544889ED96CF6B134114C773C821070F3978E8C13FC5C3DCF266AB5E
0A2D7A152A147AE8C1533D2C041A8A1091122179B3597F507A50E8C5B6C9BCD6
A52548A93FA07521C628B4074B1A5B83B4104ADD3C0FBA524835B39A631F7C8F
F3F9CCBC99612616332CCF154952F21539726BC1B5064CC799C16D112FE7C1D6
08AC11983075CFB345BC3FE002DC21257743F86F89239B8490F172E2C23FC117
5C6B80947C494A763697463BFBD5690EBE3CE4CEC1636ED5B3ECEB31266505A4
AC778B282F459BB92B12E4581F968B5782FDEA34F3D72767A655CFF28B47D7BE
6B94BB9156420AD21A810FDEDFFD233CCCB74FF77FB64C41DA6CF6F9AB17B592
C75BA55B3DE1617C3DC65AC963CF15C99E82924A8146E03D7FCA58B0E74FB146
E0924A41EFF614E4B846E0A39D9CB1E06827C71A81CB0539DE53109E77537818
8DC0E53CD8E78273412C56C6D483B5D9A17654C1DAEC509B14E4FE0AF75C9124
4736DF3EBF1979059B8BA34C8E6C9E799B3D5724280F9735CAD72BC5C193563D
1B5970B83DC32BC5C1134278B384203C5724BAFA5E991B6E1F6ECF44869FBED1
95B9E176D77E8482DAEA047FACDCFEAFD45627BA37FCF473D8AF189DA8B09695
AC6DCCDFE0863FC90D7F9237E6AF77345A556340AF22848C4619AC3F1D09D69F
8DFC7AF821D33781678B3829489382CFA464831032A6BF8A1FDBA511CB562822
EB0000000049454E44AE426082
}
Transparent = True
end
object StartDatePicker: TDateTimePicker
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Image1
Left = 114
Height = 23
Top = 47
Width = 79
CenturyFrom = 1941
MaxDate = 2958465
MinDate = -53780
TabOrder = 1
BorderSpacing.Left = 8
TrailingSeparator = False
LeadingZeros = True
Kind = dtkDate
TimeFormat = tf24
TimeDisplay = tdHMS
DateMode = dmComboBox
Date = 36235
Time = 0.775961111103243
UseDefaultSeparators = True
HideDateTimeParts = []
MonthNames = 'Long'
CalAlignment = dtaLeft
end
object StartTimePicker: TDateTimePicker
AnchorSideLeft.Control = StartDatePicker
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = StartDatePicker
Left = 217
Height = 23
Top = 47
Width = 65
CenturyFrom = 1941
MaxDate = 2958465
MinDate = -53780
TabOrder = 2
BorderSpacing.Left = 24
BorderSpacing.Right = 6
TrailingSeparator = False
LeadingZeros = True
Kind = dtkTime
TimeFormat = tf24
TimeDisplay = tdHMS
DateMode = dmComboBox
Date = 36235
Time = 0.776266203698469
UseDefaultSeparators = True
HideDateTimeParts = []
MonthNames = 'Long'
CalAlignment = dtaLeft
end
object EndDatePicker: TDateTimePicker
AnchorSideLeft.Control = StartDatePicker
AnchorSideTop.Control = StartDatePicker
AnchorSideTop.Side = asrBottom
Left = 114
Height = 23
Top = 74
Width = 79
CenturyFrom = 1941
MaxDate = 2958465
MinDate = -53780
TabOrder = 3
BorderSpacing.Top = 4
TrailingSeparator = False
LeadingZeros = True
Kind = dtkDate
TimeFormat = tf24
TimeDisplay = tdHMS
DateMode = dmComboBox
Date = 36235
Time = 0.776392129599117
UseDefaultSeparators = True
HideDateTimeParts = []
MonthNames = 'Long'
CalAlignment = dtaLeft
end
object EndTimePicker: TDateTimePicker
AnchorSideLeft.Control = StartTimePicker
AnchorSideTop.Control = EndDatePicker
Left = 217
Height = 23
Top = 74
Width = 65
CenturyFrom = 1941
MaxDate = 2958465
MinDate = -53780
TabOrder = 4
BorderSpacing.Right = 6
TrailingSeparator = False
LeadingZeros = True
Kind = dtkTime
TimeFormat = tf24
TimeDisplay = tdHMS
DateMode = dmComboBox
Date = 36235
Time = 0.77642199069669
UseDefaultSeparators = True
HideDateTimeParts = []
MonthNames = 'Long'
CalAlignment = dtaLeft
end
object AlarmEnabledCheck: TCheckBox
AnchorSideLeft.Control = Label1
AnchorSideTop.Control = AlarmAdvanceEdit
AnchorSideTop.Side = asrCenter
Left = 50
Height = 19
Top = 117
Width = 74
Caption = '&Reminder:'
TabOrder = 5
end
object AlarmAdvanceEdit: TEdit
AnchorSideLeft.Control = AlarmEnabledCheck
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Image2
Left = 132
Height = 23
Top = 115
Width = 37
BorderSpacing.Left = 8
BorderSpacing.Bottom = 8
ReadOnly = True
TabOrder = 6
Text = '0'
end
object UpDown1: TUpDown
AnchorSideLeft.Control = AlarmAdvanceEdit
AnchorSideLeft.Side = asrBottom
Left = 169
Height = 23
Top = 115
Width = 15
Associate = AlarmAdvanceEdit
Max = 60
Min = 0
OnClick = UpDown1Click
Position = 0
TabOrder = 7
end
object Edit1: TEdit
AnchorSideLeft.Control = Label6
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Owner
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 54
Height = 23
Top = 6
Width = 290
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
BorderSpacing.Top = 6
BorderSpacing.Right = 6
Constraints.MinWidth = 280
TabOrder = 0
end
object ButtonPanel1: TButtonPanel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Image2
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 6
Height = 26
Top = 155
Width = 338
Align = alNone
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 10
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 8
ShowButtons = [pbOK, pbCancel]
ShowBevel = False
end
end

236
components/jvcllaz/examples/JvTimeFramework/tfapptedit.pas Normal file
View File

@ -0,0 +1,236 @@
{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
Contributor(s):
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.delphi-jedi.org
The contents of this file are used with permission, 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_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit tfApptEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls, JvTFManager, ExtCtrls, ButtonPanel,
DateTimePicker;
type
{ TApptEdit }
TApptEdit = class(TForm)
ButtonPanel1: TButtonPanel;
Label1: TLabel;
Label3: TLabel;
Label5: TLabel;
StartDatePicker: TDateTimePicker;
StartTimePicker: TDateTimePicker;
EndDatePicker: TDateTimePicker;
EndTimePicker: TDateTimePicker;
AlarmEnabledCheck: TCheckBox;
AlarmAdvanceEdit: TEdit;
UpDown1: TUpDown;
Edit1: TEdit;
Label6: TLabel;
Bevel1: TBevel;
Image1: TImage;
Bevel2: TBevel;
Image2: TImage;
procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var TheAction: TCloseAction);
private
{ Private declarations }
// This form will use this var to indicate whether the appt is being
// editing or whether is it being created. (This is important in the
// OnClose event.)
AddingAppt : Boolean;
public
{ Public declarations }
// the main form will set this var to the selected appt if the user
// wants to edit the appt OR the main form will set this var to nil
// if the user wants to add a new appointment.
Appt : TJvTFAppt;
end;
var
ApptEdit: TApptEdit;
implementation
Uses
tfMain, JvTFDays;
{$R *.lfm}
procedure TApptEdit.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
// Handles the Alarm Advance "spin"
AlarmAdvanceEdit.Text := IntToStr(UpDown1.Position);
end;
procedure TApptEdit.FormShow(Sender: TObject);
var
ApptStartDate,
ApptEndDate : TDate;
ApptStartTime,
ApptEndTime : TTime;
DaysGrid : TJvTFDays;
begin
// Just a short cut to save typing :)
DaysGrid := PhotoOpMain.JvTFDays1;
If Assigned(Appt) Then
Begin
// Assume we want to edit the selected appt
// Populate the window fields from the selected appt
StartDatePicker.Date := Appt.StartDate;
StartTimePicker.Time := Appt.StartTime;
EndDatePicker.Date := Appt.EndDate;
EndTimePicker.Time := Appt.EndTime;
AlarmEnabledCheck.Checked := Appt.AlarmEnabled;
AlarmAdvanceEdit.Text := IntToStr(Appt.AlarmAdvance);
UpDown1.Position := Appt.AlarmAdvance;
Edit1.Text := Appt.Description;
// Change the caption of the form to indicate that the appointment
// is being edited.
Caption := 'Edit Appointment';
// Set the AddingAppt var to false so that the form will recognize
// that the appt is being edited and not created.
AddingAppt := False;
End
Else
Begin
// Assume we are adding a new appt
// Request an appt from the server
Appt := PhotoOpMain.JvTFDays1.ScheduleManager.dbNewAppt('');
// Right now this appt object is in a state of flux. It is not
// assigned to any schedules and shouldn't be because we're unsure
// of its data. The caching system is programmed to automatically
// destroy any appt objects that are not assigned to any schedules.
// In this particular situation, this is bad.
// So...
// Make the Appt object persistent so the cache does not attempt to
// flush it while this window is open.
Appt.Persistent := True;
// Now populate the appt object with some default data which is
// retrieved from the JvTFDays grid.
With Appt do
Begin
If DaysGrid.ValidSelection Then
Begin
// Set the start/end dates according to the selection
ApptStartDate := DaysGrid.Cols[DaysGrid.SelStart.X].SchedDate;
ApptEndDate := DaysGrid.Cols[DaysGrid.SelEnd.X].SchedDate;
// Set the start/end times according to the selection
ApptStartTime := DaysGrid.RowToTime(DaysGrid.SelStart.Y);
ApptEndTime := DaysGrid.RowEndTime(DaysGrid.SelEnd.Y);
End
Else
Begin
// Set the start/end dates to today
ApptStartDate := Date;
ApptEndDate := Date;
// Set the start/end times to now and now + granularity
ApptStartTime := Time;
// Subtract one min from granularity, then add the minute back in.
// (Avoids minute overflow when granularity is 60)
ApptEndTime := ApptStartTime +
EncodeTime(0, DaysGrid.Granularity - 1, 0, 0) +
EncodeTime(0, 1, 0, 0);
End;
Appt.BeginUpdate;
// Call BeginUpdate so that the appt will NOT be posted when we
// set the following properties. Don't worry about calling
// EndUpdate here. It will be called if the user chooses 'OK' to
// save the new appt. See FormClose below.
SetStartEnd(ApptStartDate, ApptStartTime, ApptEndDate, ApptEndTime);
AlarmEnabled := True;
AlarmAdvance := 15;
End;
// Now call this proc again to populate the window fields
FormShow(nil); // Appt won't be nil now so this call will fill the
// window fields
// Set the caption of the form to indicate that the appt is being added
Caption := 'Add Appointment';
// Set the AddingAppt var to true so that the form will recognize that
// the appt is being added instead of edited.
AddingAppt := True;
End;
end;
procedure TApptEdit.FormClose(Sender: TObject; var TheAction: TCloseAction);
var
DaysGrid : TJvTFDays;
I : Integer;
begin
If (ModalResult = mrOK) and Assigned(Appt) Then
With Appt do
Begin
Appt.BeginUpdate;
// Call BeginUpdate so that the appt is not posted while we are
// setting its properties.
Try
// Copy the data from the window fields to the appt object
SetStartEnd(StartDatePicker.Date, StartTimePicker.Time,
EndDatePicker.Date, EndTimePicker.Time);
AlarmEnabled := AlarmEnabledCheck.Checked;
AlarmAdvance := StrToInt(AlarmAdvanceEdit.Text);
Description := Edit1.Text;
If AddingAppt Then
Begin
// Just a shortcut to save some typing :-)
DaysGrid := PhotoOpMain.JvTFDays1;
// Add the appt to selected schedule(s)
For I := 0 to DaysGrid.Cols.Count - 1 do
Appt.AddSchedule(DaysGrid.Cols[I].SchedName);
// Now that we're done working with the appointment and it is
// actually assigned to a schedule, we should set the Persistent
// property to false. This will ensure the the caching system
// will properly dispose of the appointment object when it is
// no longer needed.
Appt.Persistent := False;
End;
Finally
Appt.EndUpdate; // this causes the appt to be posted
End;
End
Else If AddingAppt Then
// The user canceled the window, but we have already created the appt
// object. We need to clean up the appt object we requested from the
// server. This can be done either by manually destroying the appt
// object (Appt.Free), or by setting Appt.Persistent to false.
Appt.Free;
// Set Appt to nil to prepare window for next opening
Appt := nil;
end;
end.

1500
components/jvcllaz/examples/JvTimeFramework/tfmain.lfm Normal file
View File

File diff suppressed because it is too large Load Diff

712
components/jvcllaz/examples/JvTimeFramework/tfmain.pas Normal file
View File

@ -0,0 +1,712 @@
{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
Contributor(s):
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.delphi-jedi.org
The contents of this file are used with permission, 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_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit tfMain;
interface
uses
LCLIntf,
//Windows, Messages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, sqldb, sqlite3conn, //DBTables,
ComCtrls, StdCtrls, Buttons, ExtCtrls, ImgList, DateTimePicker, JvTFManager,
JvTFDays, JvTFGlance, JvTFGlanceTextViewer, JvTFMonths, JvTFWeeks,
JvComponent, JvExControls;
type
{ TPhotoOpMain }
TPhotoOpMain = class(TForm)
ImageList: TImageList;
Label1: TLabel;
Label2: TLabel;
Panel2: TPanel;
utfScheduleManager1: TJvTFScheduleManager;
StateImageList: TImageList;
NeedApptsQuery: TSQLQuery;
ApptSchedulesQuery: TSQLQuery;
GetApptQuery: TSQLQuery;
DeleteApptLinkQuery: TSQLQuery;
DeleteApptQuery: TSQLQuery;
SchedulesQuery: TSQLQuery;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
JvTFDays1: TJvTFDays;
JvTFWeeks1: TJvTFWeeks;
JvTFMonths1: TJvTFMonths;
GlanceTextViewer1: TJvTFGlanceTextViewer;
GlanceTextViewer2: TJvTFGlanceTextViewer;
Panel1: TPanel;
ResourceCombo: TComboBox;
PrevDateButton: TBitBtn;
NextDateButton: TBitBtn;
NewApptButton: TBitBtn;
EditApptButton: TBitBtn;
DeleteApptButton: TBitBtn;
ViewSchedsButton: TBitBtn;
HideSchedButton: TBitBtn;
ShareButton: TBitBtn;
TimeIncCombo: TComboBox;
GotoDatePicker: TDateTimePicker;
ModeCombo: TComboBox;
DaysCombo: TComboBox;
PrintButton: TBitBtn;
dbUTF: TSQLite3Connection;
SQLTransaction: TSQLTransaction;
procedure Label2Click(Sender: TObject);
procedure Label2MouseEnter(Sender: TObject);
procedure Label2MouseLeave(Sender: TObject);
procedure utfScheduleManager1PostAppt(Sender: TObject; Appt: TJvTFAppt);
procedure utfScheduleManager1DeleteAppt(Sender: TObject; Appt: TJvTFAppt);
procedure utfScheduleManager1RefreshAppt(Sender: TObject; Appt: TJvTFAppt);
procedure ModeComboChange(Sender: TObject);
procedure ViewSchedsButtonClick(Sender: TObject);
procedure HideSchedButtonClick(Sender: TObject);
procedure ResourceComboChange(Sender: TObject);
procedure DaysComboChange(Sender: TObject);
procedure ShareButtonClick(Sender: TObject);
procedure PrevDateButtonClick(Sender: TObject);
procedure NextDateButtonClick(Sender: TObject);
procedure GotoDatePickerChange(Sender: TObject);
procedure GotoDatePickerUserInput(Sender: TObject;
const UserString: String; var DateAndTime: TDateTime;
var AllowChange: Boolean);
procedure TimeIncComboChange(Sender: TObject);
procedure NewApptButtonClick(Sender: TObject);
procedure EditApptButtonClick(Sender: TObject);
procedure DeleteApptButtonClick(Sender: TObject);
procedure JvTFDays1DateChanging(Sender: TObject; var NewDate: TDate);
procedure JvTFDays1DateChanged(Sender: TObject);
procedure JvTFDays1GranularityChanged(Sender: TObject);
procedure JvTFDays1DblClick(Sender: TObject);
procedure JvTFDaysPrinter1ApptProgress(Sender: TObject; Current,
Total: Integer);
procedure JvTFDaysPrinter1AssembleProgress(Sender: TObject; Current,
Total: Integer);
procedure JvTFDaysPrinter1PrintProgress(Sender: TObject; Current,
Total: Integer);
procedure utfScheduleManager1LoadBatch(Sender: TObject; BatchName: String;
BatchStartDate, BatchEndDate: TDate);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure PrintButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
PhotoOpMain: TPhotoOpMain;
implementation
uses
tfVisibleResources, tfShare, tfApptEdit, tfPrintProgress;
{$R *.lfm}
procedure TPhotoOpMain.utfScheduleManager1PostAppt(Sender: TObject;
Appt: TJvTFAppt);
var
I : Integer;
begin
With GetApptQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
Open;
If RecordCount > 0 Then // SQL RecordCount not reliable except on local tables
Edit
Else
Begin
Insert;
FieldByName('ApptID').AsString := Appt.ID;
End;
FieldByName('StartDate').AsDateTime := Appt.StartDate;
FieldByName('StartTime').AsDateTime := Appt.StartTime;
FieldByName('EndDate').AsDateTime := Appt.EndDate;
FieldByName('EndTime').AsDateTime := Appt.EndTime;
FieldByName('Description').AsString := Appt.Description;
FieldByName('AlarmEnabled').AsBoolean := Appt.AlarmEnabled;
FieldByName('AlarmAdvance').AsInteger := Appt.AlarmAdvance;
Post;
Close;
End;
// Now update the Appt --> Schedule relationship
// First delete all entries in the Link table
With DeleteApptLinkQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
ExecSQL;
End;
// Now "refresh" the link table by adding a record for each of the names
// in Appt.Schedules. We will use the ApptSchedulesQuery to update the table.
With ApptSchedulesQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
Open;
For I := 0 to Appt.ScheduleCount - 1 do
Begin
Insert;
FieldByName('ApptID').AsString := Appt.ID;
FieldByName('SchedName').AsString := Appt.Schedules[I];
Post;
End;
Close;
End;
end;
procedure TPhotoOpMain.utfScheduleManager1DeleteAppt(Sender: TObject;
Appt: TJvTFAppt);
begin
// First delete the appointment from the appointment table
With DeleteApptQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
ExecSQL;
End;
// Next, delete the related records from the link table
With DeleteApptLinkQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
ExecSQL;
End;
end;
procedure TPhotoOpMain.utfScheduleManager1RefreshAppt(Sender: TObject;
Appt: TJvTFAppt);
begin
With GetApptQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
Open;
If RecordCount = 1 Then
Begin
Appt.SetStartEnd(FieldByName('StartDate').AsDateTime,
FieldByName('StartTime').AsDateTime,
FieldByName('EndDate').AsDateTime,
FieldByName('EndTime').AsDateTime);
Appt.Description := FieldByName('Description').AsString;
Appt.AlarmEnabled := FieldByName('AlarmEnabled').AsBoolean;
Appt.AlarmAdvance := FieldByName('AlarmAdvance').AsInteger;
End;
Close;
End;
// Now update the Appt --> Schedule(s) relationship
Appt.ClearSchedules;
With ApptSchedulesQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
Open;
First;
While not EOF do
Begin
Appt.AddSchedule(FieldByName('SchedName').AsString);
Next;
End;
Close; // ApptSchedulesQuery
End;
end;
procedure TPhotoOpMain.ModeComboChange(Sender: TObject);
begin
If ModeCombo.ItemIndex = 0 Then
// Single mode
Begin
// display the appropriate tool bar controls
ViewSchedsButton.Visible := False;
HideSchedButton.Visible := False;
ShareButton.Visible := False;
ResourceCombo.Visible := True;
DaysCombo.Visible := True;
// synchronize the date
JvTFDays1.Template.LinearStartDate := GotoDatePicker.Date;
// "activate" the Linear template
JvTFDays1.Template.ActiveTemplate := agtLinear;
// set the column grouping
JvTFDays1.Grouping := grResource;
End
Else
// Group mode
Begin
// display the appropriate tool bar controls
ViewSchedsButton.Visible := True;
HideSchedButton.Visible := True;
ShareButton.Visible := True;
ResourceCombo.Visible := False;
DaysCombo.Visible := False;
// synchronize the date
JvTFDays1.Template.CompDate := GotoDatePicker.Date;
// "activate" the Comparative template
JvTFDays1.Template.ActiveTemplate := agtComparative;
// set the column grouping
JvTFDays1.Grouping := grDate;
End;
end;
procedure TPhotoOpMain.ViewSchedsButtonClick(Sender: TObject);
begin
VisibleResources.ShowModal;
end;
procedure TPhotoOpMain.HideSchedButtonClick(Sender: TObject);
var
I,
NameIndex : Integer;
NameList : TStringList;
begin
NameList := TStringList.Create;
Try
With JvTFDays1 do
Begin
If ValidSelection Then
Begin
For I := SelStart.X to SelEnd.X do
NameList.Add(Cols[I].SchedName);
For I := 0 to NameList.Count - 1 do
Begin
NameIndex := Template.CompNames.IndexOf(NameList[I]);
If NameIndex > -1 Then
Template.CompNames.Delete(NameIndex);
End;
End
Else
MessageDlg('Please select a schedule to hide.', mtInformation, [mbOK], 0);
End;
Finally
NameList.Free;
End;
end;
procedure TPhotoOpMain.ResourceComboChange(Sender: TObject);
begin
JvTFDays1.Template.LinearName := ResourceCombo.Text;
JvTFWeeks1.SchedNames.Clear;
JvTFWeeks1.SchedNames.Add(ResourceCombo.Text);
JvTFWeeks1.Refresh;
JvTFMonths1.SchedNames.Clear;
JvTFMonths1.SchedNames.Add(ResourceCombo.Text);
JvTFMonths1.Refresh;
end;
procedure TPhotoOpMain.DaysComboChange(Sender: TObject);
begin
Case DaysCombo.ItemIndex of
0 : JvTFDays1.Template.LinearDayCount := 31;
1 : JvTFDays1.Template.LinearDayCount := 14;
2 : JvTFDays1.Template.LinearDayCount := 7;
3 : JvTFDays1.Template.LinearDayCount := 5;
4 : JvTFDays1.Template.LinearDayCount := 3;
5 : JvTFDays1.Template.LinearDayCount := 2;
6 : JvTFDays1.Template.LinearDayCount := 1;
End;
end;
procedure TPhotoOpMain.ShareButtonClick(Sender: TObject);
begin
If JvTFDays1.SelAppt <> nil Then
Share.ShowModal
Else
MessageDlg('Please select an appointment.', mtInformation, [mbOK], 0);
end;
procedure TPhotoOpMain.PrevDateButtonClick(Sender: TObject);
begin
JvTFDays1.PrevDate;
end;
procedure TPhotoOpMain.NextDateButtonClick(Sender: TObject);
begin
JvTFDays1.NextDate;
end;
procedure TPhotoOpMain.GotoDatePickerChange(Sender: TObject);
begin
// GotoDatePicker.OnCloseUp should also point to this handler
JvTFDays1.GotoDate(GotoDatePicker.Date);
JvTFWeeks1.DisplayDate := GotoDatePicker.Date;
JvTFWeeks1.DisplayDate := GotoDatePicker.Date;
end;
procedure TPhotoOpMain.GotoDatePickerUserInput(Sender: TObject;
const UserString: String; var DateAndTime: TDateTime;
var AllowChange: Boolean);
begin
AllowChange := True;
GotoDatePicker.OnChange(nil);
end;
procedure TPhotoOpMain.TimeIncComboChange(Sender: TObject);
begin
Case TimeIncCombo.ItemIndex of
0 : JvTFDays1.Granularity := 60;
1 : JvTFDays1.Granularity := 30;
2 : JvTFDays1.Granularity := 20;
3 : JvTFDays1.Granularity := 15;
4 : JvTFDays1.Granularity := 12;
5 : JvTFDays1.Granularity := 10;
6 : JvTFDays1.Granularity := 6;
7 : JvTFDays1.Granularity := 5;
8 : JvTFDays1.Granularity := 4;
9 : JvTFDays1.Granularity := 3;
10 : JvTFDays1.Granularity := 2;
11 : JvTFDays1.Granularity := 1;
End;
end;
procedure TPhotoOpMain.NewApptButtonClick(Sender: TObject);
begin
// Simply open the EditAppt window. The Appt var of the
// EditAppt form will already be nil (which indicates
// that the appoinment is being created).
ApptEdit.ShowModal;
end;
procedure TPhotoOpMain.EditApptButtonClick(Sender: TObject);
begin
If Assigned(JvTFDays1.SelAppt) Then
Begin
// Set EditAppt's Appt var to the selected appointment to
// indicate that the appointment should be edited.
ApptEdit.Appt := JvTFDays1.SelAppt;
ApptEdit.ShowModal;
End
Else
MessageDlg('Please select an appointment to edit.', mtInformation,
[mbOK], 0);
end;
procedure TPhotoOpMain.DeleteApptButtonClick(Sender: TObject);
var
Appt : TJvTFAppt;
dbDel : Boolean;
SelSchedName : String;
begin
// This routine employs a simple business that asks the user what to
// do in the case where the user is attempting to delete a shared appt.
// NOTE: This is NOT required. You are completely free to implement
// any business rules you see fit.
// Another shortcut to save typing
Appt := JvTFDays1.SelAppt;
If Assigned(Appt) Then
Begin
dbDel := True;
If Appt.Shared Then
If MessageDlg('This appointment is shared with other schedules.' + #13#10 +
'Do you want to delete the appointment from ' +
'all schedules?' + #13#10#13#10 +
'Choose ''No'' to delete the appointment from the ' +
'selected schedule only.' + #13#10 +
'Choose ''All'' to delete the appointment from all schedules.',
mtConfirmation, [mbNo, mbAll], 0) = mrNo Then
Begin
// Don't delete the appointment, but remove it from the schedule
// of the selected resource.
dbDel := False;
With JvTFDays1 do
Begin
SelSchedName := '';
If ValidSelection and Cols[SelStart.X].Connected Then
SelSchedName := Cols[SelStart.X].Schedule.SchedName;
End;
If SelSchedName <> '' Then
Appt.RemoveSchedule(SelSchedName)
Else
MessageDlg('No schedule is selected.' + #13#10 +
'Could not remove appointment from schedule.',
mtInformation, [mbOK], 0);
End;
If dbDel Then
If MessageDlg('Are you sure you want to delete the selected appointment?',
mtConfirmation, [mbYes, mbNo], 0) = mrYes Then
// Delete the appointment (removes it from the db)
// Note: Could substitute Appt.Delete; for the line below
JvTFDays1.ScheduleManager.dbDeleteAppt(JvTFDays1.SelAppt);
End
Else
MessageDlg('Please select an appointment to delete.',
mtInformation, [mbOK], 0);
end;
procedure TPhotoOpMain.JvTFDays1DateChanging(Sender: TObject;
var NewDate: TDate);
begin
// Make sure all appts are posted before moving on.
JvTFDays1.ScheduleManager.PostAppts;
end;
procedure TPhotoOpMain.JvTFDays1DateChanged(Sender: TObject);
begin
// Synchronize the tool bar
With JvTFDays1.Template do
If ActiveTemplate = agtLinear Then
GotoDatePicker.Date := LinearStartDate
Else
GotoDatePicker.Date := CompDate;
end;
procedure TPhotoOpMain.JvTFDays1GranularityChanged(Sender: TObject);
begin
// Update the TimeIncCombo when the granularity is changed.
// (This can be done by <Ctrl> + <Insert> and <Ctrl> + <Delete>)
Case JvTFDays1.Granularity of
60 : TimeIncCombo.ItemIndex := 0;
30 : TimeIncCombo.ItemIndex := 1;
20 : TimeIncCombo.ItemIndex := 2;
15 : TimeIncCombo.ItemIndex := 3;
12 : TimeIncCombo.ItemIndex := 4;
10 : TimeIncCombo.ItemIndex := 5;
6 : TimeIncCombo.ItemIndex := 6;
5 : TimeIncCombo.ItemIndex := 7;
4 : TimeIncCombo.ItemIndex := 8;
3 : TimeIncCombo.ItemIndex := 9;
2 : TimeIncCombo.ItemIndex := 10;
Else
TimeIncCombo.ItemIndex := 11;
End;
end;
procedure TPhotoOpMain.JvTFDays1DblClick(Sender: TObject);
begin
With JvTFDays1 do
If ValidSelection Then
If Assigned(SelAppt) Then
EditApptButtonClick(nil)
Else
NewApptButtonClick(nil);
end;
procedure TPhotoOpMain.FormShow(Sender: TObject);
var
ResName : String;
begin
// Initialize the date
//GotoDatePicker.Date := Date;
GotoDatePicker.Date := EncodeDate(2002, 1, 1);
// Initialize the granularity
TimeIncCombo.ItemIndex := 1; // 30 mins
// Initialize the mode
ModeCombo.ItemIndex := 0; // Single mode
DaysCombo.ItemIndex := 6; // One day
// Populate the resource related controls
With SchedulesQuery do
try
Open;
First;
While not EOF do
Begin
ResName := SchedulesQuery.FieldByName('SchedName').AsString;
ResourceCombo.Items.Add(ResName);
VisibleResources.ResourcesCheckList.Items.Add(ResName);
Share.ResourcesCheckList.Items.Add(ResName);
Next;
End;
Close;
except
//on E:EDBEngineError do
on E: EDatabaseError do
begin
ShowMessageFmt('%s:'#13#10'Try moving the database to a shorter path.',[E.Message]);
Application.Terminate;
Exit;
end;
end;
// Initialize the resource related controls
ResourceCombo.ItemIndex := 0;
VisibleResources.ResourcesCheckList.Checked[0] := True;
// Initialize the comparative template
JvTFDays1.Template.CompNames.Add(VisibleResources.ResourcesCheckList.Items[0]);
// Now run the events to synchronize JvTFDays, etc.
ResourceComboChange(nil);
DaysComboChange(nil);
ModeComboChange(nil);
GotoDatePicker.Date := EncodeDate(2002, 1, 1);
GotoDatePickerChange(nil);
TimeIncComboChange(nil);
end;
procedure TPhotoOpMain.PrintButtonClick(Sender: TObject);
begin
(******************** wp: deactivated due to stack overflow ************
With JvTFDaysPrinter1 do
Begin
// "Copy" the display properties from the JvTFDays control
SetProperties(JvTFDays1);
// Set gridline color to black for sharp display on printed page
GridLineColor := clBlack;
// print 48 rows on each page
PageLayout.RowsPerPage := 48;
// fit all the columns onto one page wide
PageLayout.ColsPerPage := 0;
// "Copy" the schedules from the JvTFDays control
Cols.Assign(JvTFDays1.Cols);
PrintProgress.Show;
Application.ProcessMessages;
// print the document
PrintDirect;
PrintProgress.Close;
End;
************************)
end;
procedure TPhotoOpMain.JvTFDaysPrinter1ApptProgress(Sender: TObject;
Current, Total: Integer);
begin
If Current > Total Then
Total := Current;
PrintProgress.Label2.Caption := 'Processing appointment ' + IntToStr(Current) +
' of ' + IntToStr(Total) + ' (estimated)';
PrintProgress.ProgressBar1.Max := Total;
PrintProgress.ProgressBar1.Position := Current;
end;
procedure TPhotoOpMain.JvTFDaysPrinter1AssembleProgress(Sender: TObject;
Current, Total: Integer);
begin
PrintProgress.Label2.Caption := 'Assembling page ' + IntToStr(Current) +
' of ' + IntToStr(Total);
PrintProgress.ProgressBar1.Max := Total;
PrintProgress.ProgressBar1.Position := Current;
end;
procedure TPhotoOpMain.JvTFDaysPrinter1PrintProgress(Sender: TObject;
Current, Total: Integer);
begin
PrintProgress.Label2.Caption := 'Printing page ' + IntToStr(Current) +
' of ' + IntToStr(Total);
PrintProgress.ProgressBar1.Max := Total;
PrintProgress.ProgressBar1.Position := Current;
end;
procedure TPhotoOpMain.Label2Click(Sender: TObject);
begin
OpenURL('https://icons8.com');
end;
procedure TPhotoOpMain.Label2MouseEnter(Sender: TObject);
begin
Label2.Font.Style := Label2.Font.Style + [fsUnderline];
Screen.Cursor := crHandPoint;
end;
procedure TPhotoOpMain.Label2MouseLeave(Sender: TObject);
begin
Label2.Font.Style := Label2.Font.Style - [fsUnderline];
Screen.Cursor := crDefault;
end;
procedure TPhotoOpMain.utfScheduleManager1LoadBatch(Sender: TObject;
BatchName: String; BatchStartDate, BatchEndDate: TDate);
var
Appt : TJvTFAppt;
NewAppt : Boolean;
begin
With NeedApptsQuery do
Begin
// Set the query parameters so the query will return
// all appointments for the given resource that fall
// on the given date.
ParamByName('D1').AsDate := BatchStartDate;
ParamByName('D2').AsDate := BatchEndDate;
ParamByName('SchedName').AsString := BatchName;
// Next, loop through the returned records to add the data
Open;
First;
While not EOF do
Begin
// Request an appointment object from the server
utfScheduleManager1.RequestAppt(FieldByName('ApptID').AsString,
Appt, NewAppt);
// If it is a newly loaded appt we want to set its properties
If NewAppt Then
Begin
Appt.SetStartEnd(FieldByName('StartDate').AsDateTime,
FieldByName('StartTime').AsDateTime,
FieldByName('EndDate').AsDateTime,
FieldByName('EndTime').AsDateTime);
Appt.Description := FieldByName('Description').AsString;
Appt.AlarmEnabled := FieldByName('AlarmEnabled').AsBoolean;
Appt.AlarmAdvance := FieldByName('AlarmAdvance').AsInteger;
// Now manage the Appt --> Schedule(s) relationship
With ApptSchedulesQuery do
Begin
ParamByName('ApptID').AsString := Appt.ID;
Open;
First;
While not EOF do
Begin
Appt.AddSchedule(FieldByName('SchedName').AsString);
Next;
End;
Close; // ApptSchedulesQuery
End;
End;
Next; // NeedApptsQuery record
End;
Close; // NeedApptsQuery
End;
end;
procedure TPhotoOpMain.FormCreate(Sender: TObject);
var
fn: String;
begin
fn := Application.Location + 'data.sqlite';
dbUTF.DatabaseName := fn;
dbUTF.Connected := FileExists(fn);
end;
end.

78
components/jvcllaz/examples/JvTimeFramework/tfprintprogress.lfm Normal file
View File

@ -0,0 +1,78 @@
object PrintProgress: TPrintProgress
Left = 613
Height = 161
Top = 250
Width = 367
BorderIcons = []
BorderStyle = bsSingle
Caption = 'Print Progress'
ClientHeight = 161
ClientWidth = 367
Color = clBtnFace
Font.Color = clWindowText
FormStyle = fsStayOnTop
OnShow = FormShow
Position = poScreenCenter
LCLVersion = '2.1.0.0'
Scaled = False
object Label1: TLabel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 16
Height = 33
Top = 16
Width = 335
Anchors = [akTop, akLeft, akRight]
AutoSize = False
BorderSpacing.Left = 16
BorderSpacing.Top = 16
BorderSpacing.Right = 16
Caption = 'Generating Report. This may take a while. Please be patient.'
ParentColor = False
WordWrap = True
end
object Label2: TLabel
AnchorSideLeft.Control = Label1
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Label1
AnchorSideRight.Side = asrBottom
Left = 16
Height = 16
Top = 49
Width = 335
Alignment = taCenter
Anchors = [akTop, akLeft, akRight]
AutoSize = False
Caption = 'Processing...'
ParentColor = False
end
object ProgressBar1: TProgressBar
AnchorSideLeft.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Label1
AnchorSideRight.Side = asrBottom
Left = 16
Height = 20
Top = 80
Width = 335
Anchors = [akTop, akLeft, akRight]
Max = 200
TabOrder = 0
end
object CancelButton: TBitBtn
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
Left = 142
Height = 26
Top = 120
Width = 82
AutoSize = True
Caption = 'Cancel'
Kind = bkCancel
OnClick = CancelButtonClick
TabOrder = 1
end
end

69
components/jvcllaz/examples/JvTimeFramework/tfprintprogress.pas Normal file
View File

@ -0,0 +1,69 @@
{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
Contributor(s):
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.delphi-jedi.org
The contents of this file are used with permission, 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_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit tfPrintProgress;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls;
type
TPrintProgress = class(TForm)
Label1: TLabel;
Label2: TLabel;
ProgressBar1: TProgressBar;
CancelButton: TBitBtn;
procedure CancelButtonClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
PrintProgress: TPrintProgress;
implementation
uses tfMain;
{$R *.lfm}
procedure TPrintProgress.CancelButtonClick(Sender: TObject);
begin
// PhotoOpMain.JvTFDaysPrinter1.AbortPrint;
end;
procedure TPrintProgress.FormShow(Sender: TObject);
begin
ProgressBar1.Position := 0;
Label2.Caption := 'Processing...';
end;
end.

44
components/jvcllaz/examples/JvTimeFramework/tfshare.lfm Normal file
View File

@ -0,0 +1,44 @@
object Share: TShare
Left = 738
Top = 285
Width = 271
Height = 216
Caption = 'Share'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
Scaled = False
OnClose = FormClose
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 16
object ResourcesCheckList: TCheckListBox
Left = 16
Top = 8
Width = 225
Height = 129
ItemHeight = 16
TabOrder = 0
end
object OKButton: TBitBtn
Left = 40
Top = 152
Width = 75
Height = 25
TabOrder = 1
Kind = bkOK
end
object CancelButton: TBitBtn
Left = 152
Top = 152
Width = 75
Height = 25
TabOrder = 2
Kind = bkCancel
end
end

114
components/jvcllaz/examples/JvTimeFramework/tfshare.pas Normal file
View File

@ -0,0 +1,114 @@
{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
Contributor(s):
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.delphi-jedi.org
The contents of this file are used with permission, 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_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit tfShare;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, checklst;
type
TShare = class(TForm)
ResourcesCheckList: TCheckListBox;
OKButton: TBitBtn;
CancelButton: TBitBtn;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var TheAction: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Share: TShare;
implementation
uses
tfMain, JvTFManager;
{$R *.lfm}
procedure TShare.FormShow(Sender: TObject);
var
Appt : TJvTFAppt;
I : Integer;
begin
// First, get the selected appointment
Appt := PhotoOpMain.JvTFDays1.SelAppt;
// now roll through the resource list and check all resources
// that are found in the appointment's list of schedules.
With ResourcesCheckList do
For I := 0 to Items.Count - 1 do
Checked[I] := Appt.IndexOfSchedule(Items[I]) > -1;
end;
procedure TShare.FormClose(Sender: TObject; var TheAction: TCloseAction);
var
TempList : TStringList;
I : Integer;
begin
If ModalResult = mrOK Then
Begin
// create and populate a temporary list of the selected resources
// from the checklistbox.
TempList := TStringList.Create;
Try
With ResourcesCheckList do
For I := 0 to Items.Count - 1 do
If Checked[I] Then
TempList.Add(Items[I]);
// Enforce a business rule where removing all resources from an
// appointment causes the appointment to be deleted.
// NOTE: This is NOT a requirement. Feel free to implement any
// business rules as you see fit.
If TempList.Count > 0 Then
// If at least one resource then change the appointment's
// schedule list to match the temp list.
PhotoOpMain.JvTFDays1.SelAppt.AssignSchedules(TempList)
Else
If MessageDlg('You have removed this appointment from all schedules.' +
' This will cause the appointment to be deleted.' + #13#10 +
'Are you sure this is what you want to do?',
mtConfirmation, [mbYes, mbNo], 0) = mrYes Then
With PhotoOpMain.JvTFDays1 do
// Delete the appointment if that is what the user wants to do.
ScheduleManager.dbDeleteAppt(SelAppt)
Else
TheAction := caNone;
Finally
TempList.Free;
End;
End;
end;
end.

53
components/jvcllaz/examples/JvTimeFramework/tfvisibleresources.lfm Normal file
View File

@ -0,0 +1,53 @@
object VisibleResources: TVisibleResources
Left = 707
Height = 205
Top = 215
Width = 271
Caption = 'Visible Resources'
ClientHeight = 205
ClientWidth = 271
Font.Color = clWindowText
OnClose = FormClose
OnShow = FormShow
Position = poScreenCenter
LCLVersion = '2.1.0.0'
Scaled = False
object ResourcesCheckList: TCheckListBox
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 16
Height = 129
Top = 16
Width = 239
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 16
BorderSpacing.Top = 16
BorderSpacing.Right = 16
ItemHeight = 0
TabOrder = 0
end
object OKButton: TBitBtn
AnchorSideLeft.Control = ResourcesCheckList
Left = 40
Height = 25
Top = 160
Width = 75
BorderSpacing.Left = 24
Kind = bkOK
TabOrder = 1
end
object CancelButton: TBitBtn
AnchorSideRight.Control = ResourcesCheckList
AnchorSideRight.Side = asrBottom
Left = 156
Height = 25
Top = 160
Width = 75
Anchors = [akTop, akRight]
BorderSpacing.Right = 24
Kind = bkCancel
TabOrder = 2
end
end

94
components/jvcllaz/examples/JvTimeFramework/tfvisibleresources.pas Normal file
View File

@ -0,0 +1,94 @@
{******************************************************************
JEDI-VCL Demo
Copyright (C) 2002 Project JEDI
Original author:
Contributor(s):
You may retrieve the latest version of this file at the JEDI-JVCL
home page, located at http://jvcl.delphi-jedi.org
The contents of this file are used with permission, 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_1Final.html
Software distributed under the License is distributed on an
"AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
implied. See the License for the specific language governing
rights and limitations under the License.
******************************************************************}
unit tfVisibleResources;
{$mode objfpc}{$H+}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, checklst;
type
TVisibleResources = class(TForm)
ResourcesCheckList: TCheckListBox;
OKButton: TBitBtn;
CancelButton: TBitBtn;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var TheAction: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
VisibleResources: TVisibleResources;
implementation
Uses tfMain;
{$R *.lfm}
procedure TVisibleResources.FormShow(Sender: TObject);
var
I : Integer;
begin
// Check the template and check any resources currently
// visible in the grid
With PhotoOpMain.JvTFDays1.Template do
For I := 0 to ResourcesCheckList.Items.Count - 1 do
ResourcesCheckList.Checked[I] :=
CompNames.IndexOf(ResourcesCheckList.Items[I]) > -1;
end;
procedure TVisibleResources.FormClose(Sender: TObject;
var TheAction: TCloseAction);
var
I : Integer;
begin
If ModalResult = mrOK Then
begin
// First, clear the old resources from the template
PhotoOpMain.JvTFDays1.Template.CompNames.Clear;
PhotoOpMain.JvTFWeeks1.SchedNames.Clear;
PhotoOpMain.JvTFMonths1.SchedNames.Clear;
// Next, add the new resources to the template
For I := 0 to ResourcesCheckList.Items.Count - 1 do
If ResourcesCheckList.Checked[I] Then
begin
PhotoOpMain.JvTFDays1.Template.CompNames.Add(ResourcesCheckList.Items[I]);
PhotoOpMain.JvTFWeeks1.SchedNames.Add(ResourcesCheckList.Items[I]);
PhotoOpMain.JvTFMonths1.SchedNames.Add(ResourcesCheckList.Items[I]);
end;
end;
end;
end.

39
components/jvcllaz/packages/jvcl_all.lpk
View File

@ -11,55 +11,60 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<RequiredPkgs Count="16">
<Description Value="A meta package for simple installation of all JVCL designtime packages."/>
<Version Major="1" Release="6"/>
<RequiredPkgs Count="17">
<Item1>
<PackageName Value="JvXPCtrlsLazD"/>
<PackageName Value="JvTimeFrameworkLazD"/>
</Item1>
<Item2>
<PackageName Value="JvWizardLazD"/>
<PackageName Value="JvXPCtrlsLazD"/>
</Item2>
<Item3>
<PackageName Value="JvValidatorsLazD"/>
<PackageName Value="JvWizardLazD"/>
</Item3>
<Item4>
<PackageName Value="JvRuntimeDesignLazD"/>
<PackageName Value="JvValidatorsLazD"/>
</Item4>
<Item5>
<PackageName Value="JvPageCompsD"/>
<PackageName Value="JvRuntimeDesignLazD"/>
</Item5>
<Item6>
<PackageName Value="JvNetLazD"/>
<PackageName Value="JvPageCompsD"/>
</Item6>
<Item7>
<PackageName Value="JvMMLazD"/>
<PackageName Value="JvNetLazD"/>
</Item7>
<Item8>
<PackageName Value="JvJansLazD"/>
<PackageName Value="JvMMLazD"/>
</Item8>
<Item9>
<PackageName Value="JvStdCtrlsLazD"/>
<PackageName Value="JvJansLazD"/>
</Item9>
<Item10>
<PackageName Value="JvHMILazD"/>
<PackageName Value="JvStdCtrlsLazD"/>
</Item10>
<Item11>
<PackageName Value="JvDBLazD"/>
<PackageName Value="JvHMILazD"/>
</Item11>
<Item12>
<PackageName Value="JvCustomLazD"/>
<PackageName Value="JvDBLazD"/>
</Item12>
<Item13>
<PackageName Value="JvCtrlsLazD"/>
<PackageName Value="JvCustomLazD"/>
</Item13>
<Item14>
<PackageName Value="JvAppFrmLazD"/>
<PackageName Value="JvCtrlsLazD"/>
</Item14>
<Item15>
<PackageName Value="JvCmpD"/>
<PackageName Value="JvAppFrmLazD"/>
</Item15>
<Item16>
<PackageName Value="JvCoreLazD"/>
<PackageName Value="JvCmpD"/>
</Item16>
<Item17>
<PackageName Value="JvCoreLazD"/>
</Item17>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>

4
components/jvcllaz/packages/jvcllaz_all.lpg
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectGroup FileVersion="1">
<Targets Count="32">
<Targets Count="34">
<Target0 FileName="jvcorelazr.lpk"/>
<Target1 FileName="jvcorelazd.lpk"/>
<Target2 FileName="jvctrlslazr.lpk"/>
@ -34,6 +34,8 @@
<Target29 FileName="jvwizardlazd.lpk"/>
<Target30 FileName="jvxpctrlslazr.lpk"/>
<Target31 FileName="jvxpctrlslazd.lpk"/>
<Target32 FileName="jvtimeframeworklazr.lpk"/>
<Target33 FileName="jvtimeframeworklazd.lpk"/>
</Targets>
</ProjectGroup>
</CONFIG>

46
components/jvcllaz/packages/jvtimeframeworklazd.lpk Normal file
View File

@ -0,0 +1,46 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="JvTimeFrameworkLazD"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Original author: Mike Kolter, Lazarus port by W.Pamler"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\design\JvTimeFramework"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\design\JvTimeFramework"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Designtime package of the JVCL &quot;time framework&quot; components: Planners, calendars, Gantt"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="6"/>
<Files Count="1">
<Item1>
<Filename Value="..\design\JvTimeFramework\jvtimeframeworkreg.pas"/>
<HasRegisterProc Value="True"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="JvTimeFrameworkReg"/>
</Item1>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="JvCoreLazD"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
<Item3>
<PackageName Value="JvTimeFrameworkLazR"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>

73
components/jvcllaz/packages/jvtimeframeworklazr.lpk Normal file
View File

@ -0,0 +1,73 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="JvTimeFrameworkLazR"/>
<Author Value="Original author: Mike Kolter, Lazarus port by W.Pamler"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\run\JvTimeFramework"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\run\JvTimeFramework"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Runtime package of the JVCL &quot;time framework&quot; components: Planners, calendars, Gantt"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="6"/>
<Files Count="10">
<Item1>
<Filename Value="..\run\JvTimeFramework\jvtfsparsematrix.pas"/>
<UnitName Value="JvTFSparseMatrix"/>
</Item1>
<Item2>
<Filename Value="..\run\JvTimeFramework\jvtfutils.pas"/>
<UnitName Value="JvTFUtils"/>
</Item2>
<Item3>
<Filename Value="..\run\JvTimeFramework\jvtfglance.pas"/>
<UnitName Value="JvTFGlance"/>
</Item3>
<Item4>
<Filename Value="..\run\JvTimeFramework\jvtfmanager.pas"/>
<UnitName Value="JvTFManager"/>
</Item4>
<Item5>
<Filename Value="..\run\JvTimeFramework\jvtfmonths.pas"/>
<UnitName Value="JvTFMonths"/>
</Item5>
<Item6>
<Filename Value="..\run\JvTimeFramework\jvtfweeks.pas"/>
<UnitName Value="JvTFWeeks"/>
</Item6>
<Item7>
<Filename Value="..\run\JvTimeFramework\jvtfdays.pas"/>
<UnitName Value="JvTFDays"/>
</Item7>
<Item8>
<Filename Value="..\run\JvTimeFramework\jvtfalarm.pas"/>
<UnitName Value="JvTFAlarm"/>
</Item8>
<Item9>
<Filename Value="..\run\JvTimeFramework\jvtfgantt.pas"/>
<UnitName Value="JvTFGantt"/>
</Item9>
<Item10>
<Filename Value="..\run\JvTimeFramework\jvtfglancetextviewer.pas"/>
<UnitName Value="JvTFGlanceTextViewer"/>
</Item10>
</Files>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="JvCoreLazR"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>

BIN
components/jvcllaz/resource/jvtimeframeworkreg.res Normal file
View File

Binary file not shown.

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.