diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.bpr b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.bpr new file mode 100644 index 0000000..20d9482 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.bpr @@ -0,0 +1,211 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib Vcldb40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib frxDB4.lib \ + FSDB4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\Source -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\Source /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\InteractiveReport;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\InteractiveReport;$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.cpp b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.res b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.cpp new file mode 100644 index 0000000..5e2b480 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.cpp @@ -0,0 +1,33 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma link "frxDBSet" +#pragma resource "*.dfm" +TForm1 *Form1; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + MainReport->ShowReport(true); +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MainReportClickObject(TfrxView *Sender, + TMouseButton Button, TShiftState Shift, bool &Modified) +{ + if(strcmp(Sender->Name.c_str(),"Memo8\0") == 0) + { + DetailQuery->Close(); + DetailQuery->ParamByName("custno")->Value = StrToInt(Sender->TagStr); + DetailReport->ShowReport(true); + } +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.dfm new file mode 100644 index 0000000..fd7c1f8 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.h b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.h new file mode 100644 index 0000000..ed86e64 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/InteractiveReport/Unit1.h @@ -0,0 +1,80 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +#include "frxDBSet.hpp" +#include +#include +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TButton *Button1; + TTable *Customers; + TQuery *DetailQuery; + TfrxReport *MainReport; + TfrxDBDataset *CustomersDS; + TfrxDBDataset *DetailQueryDS; + TfrxReport *DetailReport; + TFloatField *DetailQueryCustNo2; + TStringField *DetailQueryCompany2; + TStringField *DetailQueryAddr12; + TStringField *DetailQueryAddr22; + TStringField *DetailQueryCity2; + TStringField *DetailQueryState2; + TStringField *DetailQueryZip2; + TStringField *DetailQueryCountry2; + TStringField *DetailQueryPhone2; + TStringField *DetailQueryFAX2; + TFloatField *DetailQueryTaxRate2; + TStringField *DetailQueryContact2; + TDateTimeField *DetailQueryLastInvoiceDate2; + TFloatField *DetailQueryOrderNo2; + TFloatField *DetailQueryCustNo_12; + TDateTimeField *DetailQuerySaleDate2; + TDateTimeField *DetailQueryShipDate2; + TIntegerField *DetailQueryEmpNo2; + TStringField *DetailQueryShipToContact2; + TStringField *DetailQueryShipToAddr12; + TStringField *DetailQueryShipToAddr22; + TStringField *DetailQueryShipToCity2; + TStringField *DetailQueryShipToState2; + TStringField *DetailQueryShipToZip2; + TStringField *DetailQueryShipToCountry2; + TStringField *DetailQueryShipToPhone2; + TStringField *DetailQueryShipVIA2; + TStringField *DetailQueryPO2; + TStringField *DetailQueryTerms2; + TStringField *DetailQueryPaymentMethod2; + TCurrencyField *DetailQueryItemsTotal2; + TFloatField *DetailQueryTaxRate_12; + TCurrencyField *DetailQueryFreight2; + TCurrencyField *DetailQueryAmountPaid2; + TFloatField *DetailQueryOrderNo_12; + TFloatField *DetailQueryItemNo2; + TFloatField *DetailQueryPartNo2; + TIntegerField *DetailQueryQty2; + TFloatField *DetailQueryDiscount2; + TFloatField *DetailQueryPartNo_12; + TFloatField *DetailQueryVendorNo2; + TStringField *DetailQueryDescription2; + TFloatField *DetailQueryOnHand2; + TFloatField *DetailQueryOnOrder2; + TCurrencyField *DetailQueryCost2; + TCurrencyField *DetailQueryListPrice2; + void __fastcall Button1Click(TObject *Sender); + void __fastcall MainReportClickObject(TfrxView *Sender, + TMouseButton Button, TShiftState Shift, bool &Modified); +private: // User declarations +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.bpr b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.bpr new file mode 100644 index 0000000..39bf733 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.bpr @@ -0,0 +1,210 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\Source -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\Source /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\MasterDetailUDS;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\MasterDetailUDS;$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.cpp b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.res b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.cpp new file mode 100644 index 0000000..f99d8e7 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.cpp @@ -0,0 +1,94 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma resource "*.dfm" +#define MAX_MASTER 3 +#define MAX_DETAIL 15 +TForm1 *Form1; + +String Master[MAX_MASTER][2] = { // master Id, master name + {"1", "master 1"}, + {"2", "master 2"}, + {"3", "master 3"}}; + +String Detail[MAX_DETAIL][2] = { // master Id, detail name + {"1", "detail 1.1"}, {"1", "detail 1.2"}, {"1", "detail 1.3"}, + {"1", "detail 1.4"}, {"1", "detail 1.5"}, {"2", "detail 2.1"}, + {"2", "detail 2.2"}, {"2", "detail 2.3"}, {"2", "detail 2.4"}, + {"2", "detail 2.5"}, {"3", "detail 3.1"}, {"3", "detail 3.2"}, + {"3", "detail 3.3"}, {"3", "detail 3.4"}, {"3", "detail 3.5"}}; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::PrintClick(TObject *Sender) +{ + frxReport1->ShowReport(true); +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MasterDSFirst(TObject *Sender) +{ + MasterNo = 0; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MasterDSNext(TObject *Sender) +{ + MasterNo++; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MasterDSCheckEOF(TObject *Sender, bool &Eof) +{ + Eof = MasterNo > MAX_MASTER - 1; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MasterDSGetValue(const AnsiString VarName, + Variant &Value) +{ + Value = Master[MasterNo][1]; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::MasterDSPrior(TObject *Sender) +{ + if(MasterNo > 0) MasterNo--; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::DetailDSCheckEOF(TObject *Sender, bool &Eof) +{ + Eof = DetailNo > MAX_DETAIL - 1; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::DetailDSFirst(TObject *Sender) +{ + DetailNo = 0; + while((!DetailDS->Eof()) && (Detail[DetailNo][0] != Master[MasterNo][0])) + DetailNo++; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::DetailDSGetValue(const AnsiString VarName, + Variant &Value) +{ + Value = Detail[DetailNo][1]; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::DetailDSNext(TObject *Sender) +{ + DetailNo++; + while ((!DetailDS->Eof()) && (Detail[DetailNo][0] != Master[MasterNo][0])) + DetailNo++; + +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::DetailDSPrior(TObject *Sender) +{ + DetailNo--; + while ((DetailNo > 0) && (Detail[DetailNo][0] != Master[MasterNo][0])) + DetailNo--; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.dfm new file mode 100644 index 0000000..ed49044 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.h b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.h new file mode 100644 index 0000000..829f63a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/MasterDetailUDS/Unit1.h @@ -0,0 +1,40 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TfrxReport *frxReport1; + TfrxUserDataSet *MasterDS; + TfrxUserDataSet *DetailDS; + TButton *Print; + void __fastcall PrintClick(TObject *Sender); + void __fastcall MasterDSFirst(TObject *Sender); + void __fastcall MasterDSNext(TObject *Sender); + void __fastcall MasterDSCheckEOF(TObject *Sender, bool &Eof); + void __fastcall MasterDSGetValue(const AnsiString VarName, + Variant &Value); + void __fastcall MasterDSPrior(TObject *Sender); + void __fastcall DetailDSCheckEOF(TObject *Sender, bool &Eof); + void __fastcall DetailDSFirst(TObject *Sender); + void __fastcall DetailDSGetValue(const AnsiString VarName, + Variant &Value); + void __fastcall DetailDSNext(TObject *Sender); + void __fastcall DetailDSPrior(TObject *Sender); +private: // User declarations + int MasterNo; + int DetailNo; +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.bpr b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.bpr new file mode 100644 index 0000000..9d18969 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.bpr @@ -0,0 +1,210 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\Source -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\Source /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=$(BCB)\include;$(BCB)\include\vcl;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintArray;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintArray;$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.cpp b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.res b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintArray/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.cpp new file mode 100644 index 0000000..0bab399 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.cpp @@ -0,0 +1,33 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma resource "*.dfm" +TForm1 *Form1; +int ar[10] = {0,1,2,3,4,5,6,7,8,9}; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + ArrayDS->RangeEnd = reCount; + ArrayDS->RangeEndCount = 10; + frxReport1->ShowReport(true); +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::frxReport1GetValue(const AnsiString VarName, + Variant &Value) +{ + if(CompareText(VarName, "element") == 0) + Value = ar[ArrayDS->RecNo]; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.dfm new file mode 100644 index 0000000..e62b08d Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.h b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.h new file mode 100644 index 0000000..e14f57a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintArray/Unit1.h @@ -0,0 +1,27 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TButton *Button1; + TfrxReport *frxReport1; + TfrxUserDataSet *ArrayDS; + void __fastcall Button1Click(TObject *Sender); + void __fastcall frxReport1GetValue(const AnsiString VarName, + Variant &Value); +private: // User declarations +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.bpr b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.bpr new file mode 100644 index 0000000..439737b --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.bpr @@ -0,0 +1,210 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I..\..\..\Source -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i..\..\..\Source /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintFile;C:\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintFile;$(BCB)\Projects\Lib;C:\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.cpp b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.res b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintFile/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.cpp new file mode 100644 index 0000000..a9bfda8 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.cpp @@ -0,0 +1,35 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma resource "*.dfm" +TForm1 *Form1; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::frxReport1GetValue(const AnsiString VarName, + Variant &Value) +{ + + if(CompareText(VarName, "file") == 0) + { + TStringList * sl = new TStringList; + sl->LoadFromFile("Unit1.cpp"); + Value = sl->Text; + delete sl; + } +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + frxReport1->ShowReport(true); +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.dfm new file mode 100644 index 0000000..d72d66a Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.h b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.h new file mode 100644 index 0000000..59c0f58 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintFile/Unit1.h @@ -0,0 +1,26 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TButton *Button1; + TfrxReport *frxReport1; + void __fastcall frxReport1GetValue(const AnsiString VarName, + Variant &Value); + void __fastcall Button1Click(TObject *Sender); +private: // User declarations +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.bpr b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.bpr new file mode 100644 index 0000000..8004f44 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.bpr @@ -0,0 +1,210 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I..\..\..\Source -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U..\..\..\Source;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i..\..\..\Source /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L..\..\..\Source;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\Source;..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringGrid;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fr4\Source;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=..\..\..\Source;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\Source;..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringGrid;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fr4\Source;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.cpp b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.res b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.cpp new file mode 100644 index 0000000..0f89597 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.cpp @@ -0,0 +1,53 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma link "frxCross" +#pragma resource "*.dfm" +TForm1 *Form1; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::FormCreate(TObject *Sender) +{ + int idx1,idx2; + + for(idx1 = 1; idx1 < 17; idx1++) + for(idx2 = 1; idx2 < 17; idx2++) + StringGrid1->Cells[idx1 - 1][idx2 - 1] = IntToStr(idx1 * idx2); + +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::frxReport1BeforePrint(TfrxReportComponent *Sender) +{ + TfrxCrossView * Cross = NULL; + int idx1,idx2; + Variant Row,Col,Text; + if(strcmp(Sender->Name.c_str(),"Cross1\0") == 0) + if(Cross = dynamic_cast (Sender)) + { + for(idx1 = 0; idx1 < StringGrid1->RowCount; idx1++) + for(idx2 = 0; idx2 < StringGrid1->ColCount; idx2++) + { + Row = idx1; + Col = idx2; + Text = StringGrid1->Cells[idx1][idx2]; + Cross->AddValue(&Row,1,&Col,1,&Text,1); + } + } +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + frxReport1->ShowReport(true); +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.dfm new file mode 100644 index 0000000..cf57a4d Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.h b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.h new file mode 100644 index 0000000..2d72107 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringGrid/Unit1.h @@ -0,0 +1,30 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include +#include "frxClass.hpp" +#include "frxCross.hpp" +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TButton *Button1; + TStringGrid *StringGrid1; + TfrxReport *frxReport1; + TfrxCrossObject *frxCrossObject1; + void __fastcall FormCreate(TObject *Sender); + void __fastcall frxReport1BeforePrint(TfrxReportComponent *Sender); + void __fastcall Button1Click(TObject *Sender); +private: // User declarations +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.bpr b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.bpr new file mode 100644 index 0000000..79e2e13 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.bpr @@ -0,0 +1,214 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I..\..\..\Source -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i..\..\..\Source /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=4 +Item0=..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringList;C:\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\..\Work\Fast Report\fs\Source;..\..\..\Source;C:\Work\Fast Report\fs\Source +Item2=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringList;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\..\Work\Fast Report\fs\Source;C:\Work\Fast Report\fr4\Source +Item3=..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlLibraryPath] +Count=4 +Item0=$(BCB)\Projects\Lib;..\..\..\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringList;$(BCB)\Projects\Lib;C:\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\..\Work\Fast Report\fs\Source;C:\Work\Fast Report\fs\Source +Item2=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintStringList;$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\..\Work\Fast Report\fs\Source +Item3=$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.cpp b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.res b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintStringList/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.cpp new file mode 100644 index 0000000..2e59ec5 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.cpp @@ -0,0 +1,38 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma resource "*.dfm" +TForm1 *Form1; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ + sl = new TStringList; + for(int idx = 0; idx < 10; idx++, sl->Add(IntToStr(idx))); +} +//--------------------------------------------------------------------------- +__fastcall TForm1::~TForm1() +{ + delete sl; +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + StringDS->RangeEnd = reCount; + StringDS->RangeEndCount = sl->Count; + frxReport1->ShowReport(true); +} +//--------------------------------------------------------------------------- +void __fastcall TForm1::frxReport1GetValue(const AnsiString VarName, + Variant &Value) +{ + + if(CompareText(VarName, "element") == 0) + Value = sl->Strings[StringDS->RecNo]; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.dfm new file mode 100644 index 0000000..11acae2 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.h b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.h new file mode 100644 index 0000000..272ee12 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintStringList/Unit1.h @@ -0,0 +1,29 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TfrxReport *frxReport1; + TfrxUserDataSet *StringDS; + TButton *Button1; + void __fastcall Button1Click(TObject *Sender); + void __fastcall frxReport1GetValue(const AnsiString VarName, + Variant &Value); +private: // User declarations + TStringList * sl; +public: // User declarations + __fastcall TForm1(TComponent* Owner); + __fastcall ~TForm1(); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.bpr b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.bpr new file mode 100644 index 0000000..368a59e --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.bpr @@ -0,0 +1,210 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = Project1.exe +OBJFILES = Project1.obj Unit1.obj +RESFILES = Project1.res +RESDEPEN = $(RESFILES) Unit1.dfm +LIBFILES = +IDLGENFILES = +IDLFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib Vcldb40.lib frx4.lib VCLX40.lib VCLJPG40.lib FS4.lib +PACKAGES = Vcl40.bpi Vclx40.bpi vcljpg40.bpi Vclmid40.bpi Vcldb40.bpi bcbsmp40.bpi \ + ibsmp40.bpi vcldbx40.bpi Qrpt40.bpi TeeUI40.bpi teedb40.bpi tee40.bpi Dss40.bpi \ + NMFast40.bpi Inetdb40.bpi Inet40.bpi dclocx40.bpi frx4.bpi fs4.bpi frxe4.bpi \ + frxDB4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par \ + -w-inl -Vx -tW -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I..\..\..\Source -I$(BCB)\include -I$(BCB)\include\vcl -I..\..\..\LibBCB4 \ + -I..\..\..\LibBCB5 -I..\..\..\LibBCB6 -src_suffixcpp +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -I..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 \ + -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +AFLAGS = /i..\..\..\Source /i$(BCB)\include /i$(BCB)\include\vcl /i..\..\..\LibBCB4 \ + /i..\..\..\LibBCB5 /i..\..\..\LibBCB6 /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6;$(RELEASELIBPATH) \ + -aa -Tpe -x -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=..\..\..\Source;$(BCB)\include;$(BCB)\include\vcl;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintTable;C:\Work\Fast Report\fr4\Source;$(BCB)\include;$(BCB)\include\vcl;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;..\..\..\Source;..\..\..\LibBCB4;..\..\..\LibBCB5;..\..\..\LibBCB6 +Item1=..\..\..\..\Work\Fast Report\fr4\Demos\BCB Demos\PrintTable;$(BCB)\Projects\Lib;..\..\..\..\Work\Fast Report\fr4\Source;$(BCB)\lib\obj;$(BCB)\lib;C:\Work\Fast Report\fr4\Source;C:\Work\Fast Report\fs\Source + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.cpp b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.cpp new file mode 100644 index 0000000..8e18b9a --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("Project1.res"); +USEFORM("Unit1.cpp", Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.res b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.res new file mode 100644 index 0000000..b369156 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintTable/Project1.res differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.cpp b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.cpp new file mode 100644 index 0000000..6886305 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.cpp @@ -0,0 +1,53 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop + +#include "Unit1.h" +//--------------------------------------------------------------------------- +#pragma package(smart_init) +#pragma link "frxClass" +#pragma link "frxCross" +#pragma resource "*.dfm" +TForm1 *Form1; +//--------------------------------------------------------------------------- +__fastcall TForm1::TForm1(TComponent* Owner) + : TForm(Owner) +{ +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::Button1Click(TObject *Sender) +{ + frxReport1->ShowReport(true); + +} +//--------------------------------------------------------------------------- + +void __fastcall TForm1::frxReport1BeforePrint(TfrxReportComponent *Sender) +{ + TfrxCrossView * Cross; + int i, j; + Variant Row,Col,Text; + + Cross = dynamic_cast (Sender); + + if(Cross != NULL) + { + Table1->First(); + i = 0; + while (!Table1->Eof) + { + for(j = 0; j < Table1->Fields->Count; j++) + { + Row = i; + Col = Table1->Fields->Fields[j]->DisplayLabel; + Text = Table1->Fields->Fields[j]->AsString; + Cross->AddValue(&Row, 1, &Col, 1, &Text, 1); + } + Table1->Next(); + i++; + } + } +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.dfm b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.dfm new file mode 100644 index 0000000..60bf957 Binary files /dev/null and b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.dfm differ diff --git a/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.h b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.h new file mode 100644 index 0000000..f0b9cb3 --- /dev/null +++ b/official/4.8.11/Demos/BCB Demos/PrintTable/Unit1.h @@ -0,0 +1,30 @@ +//--------------------------------------------------------------------------- +#ifndef Unit1H +#define Unit1H +//--------------------------------------------------------------------------- +#include +#include +#include +#include +#include "frxClass.hpp" +#include "frxCross.hpp" +#include +#include +//--------------------------------------------------------------------------- +class TForm1 : public TForm +{ +__published: // IDE-managed Components + TButton *Button1; + TfrxReport *frxReport1; + TfrxCrossObject *frxCrossObject1; + TTable *Table1; + void __fastcall Button1Click(TObject *Sender); + void __fastcall frxReport1BeforePrint(TfrxReportComponent *Sender); +private: // User declarations +public: // User declarations + __fastcall TForm1(TComponent* Owner); +}; +//--------------------------------------------------------------------------- +extern PACKAGE TForm1 *Form1; +//--------------------------------------------------------------------------- +#endif diff --git a/official/4.8.11/Demos/ClientServer/CGI/fastreport.dpr b/official/4.8.11/Demos/ClientServer/CGI/fastreport.dpr new file mode 100644 index 0000000..db0b457 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/CGI/fastreport.dpr @@ -0,0 +1,71 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport CGI wrapper demo } +{ Copyright (c) 1998-2006 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +program fastreport; + +{$APPTYPE CONSOLE} + +uses + Windows, SysUtils, Classes, frxCGIClient, IniFiles, frxServerUtils; + +const + CONFIG_FILENAME = 'fastreport.ini'; + DEFAULT_CONFIG_PATH = ''; + DEFAULT_PORT = 8097; + DEFAULT_HOST = '127.0.0.1'; + +var + FHost: String; + FPort: Integer; + FIni: TIniFile; + c: TfrxCGIClient; + s: String; + PostData: String; + PostLength: Integer; + i: Integer; +begin + if DEFAULT_CONFIG_PATH = '' then + s := ExtractFilePath(ParamStr(0)) + CONFIG_FILENAME + else + s := DEFAULT_CONFIG_PATH + CONFIG_FILENAME; + if FileExists(s) then + begin + FIni := TIniFile.Create(s); + FHost := FIni.ReadString('REPORTSERVER', 'Host', DEFAULT_HOST); + FPort := FIni.ReadInteger('REPORTSERVER', 'Port', DEFAULT_PORT); + FIni.Free; + end + else begin + FHost := DEFAULT_HOST; + FPort := DEFAULT_PORT; + end; + + if (GetEnvVar('REQUEST_METHOD') = 'POST') then + begin + Postlength := StrToInt(GetEnvVar('CONTENT_LENGTH')); + if Postlength > 0 then + begin + SetLength(PostData, PostLength); + for i := 1 to PostLength do + read(PostData[i]); + end; + end; + + c := TfrxCGIClient.Create; + c.PostData := PostData; + c.Host := FHost; + c.Port := FPort; + try + c.Open; + finally + c.Free; + end; +end. diff --git a/official/4.8.11/Demos/ClientServer/CGI/fastreport.ini b/official/4.8.11/Demos/ClientServer/CGI/fastreport.ini new file mode 100644 index 0000000..e0494d4 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/CGI/fastreport.ini @@ -0,0 +1,3 @@ +[REPORTSERVER] +Host=127.0.0.1 +Port=8097 diff --git a/official/4.8.11/Demos/ClientServer/CGI/index.html b/official/4.8.11/Demos/ClientServer/CGI/index.html new file mode 100644 index 0000000..0c049e7 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/CGI/index.html @@ -0,0 +1,6 @@ + + +1. Connect to the FastReport Server through the Apache Web Server
+2. Direct connect to the FastReport Server + + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.dpr b/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.dpr new file mode 100644 index 0000000..3bed53c --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.dpr @@ -0,0 +1,14 @@ +program FRClient; + +uses + Forms, + main in 'main.pas' {main}; + +{$R *.res} + +begin + Application.Initialize; + Application.Title := 'FastReport Client Demo'; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.res b/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.res new file mode 100644 index 0000000..06b79d7 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Client/Advanced/FRClient.res differ diff --git a/official/4.8.11/Demos/ClientServer/Client/Advanced/main.dfm b/official/4.8.11/Demos/ClientServer/Client/Advanced/main.dfm new file mode 100644 index 0000000..fa6f99e Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Client/Advanced/main.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/Client/Advanced/main.pas b/official/4.8.11/Demos/ClientServer/Client/Advanced/main.pas new file mode 100644 index 0000000..cfa6cc2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Client/Advanced/main.pas @@ -0,0 +1,463 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport client demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit main; + +{$I frx.inc} + +interface + +uses + Windows, SysUtils, Classes, Controls, Forms, + Dialogs, StdCtrls, ShellApi, frxClass, frxServerClient, + frxGZip, frxDCtrl, frxChBox, frxCross, frxRich, frxChart, + frxOLE, frxBarcode, ExtCtrls, frxExportPDF, frxExportImage, + frxExportRTF, frxExportXML, frxExportXLS, frxExportHTML, + frxExportTXT, frxGradient, Graphics, ComCtrls, Menus, ImgList +{$IFDEF Delphi6} +, Variants +{$ENDIF} +, frxExportMail, frxExportText, frxExportCSV; + +type + TMainForm = class(TForm) + frxServerConnection1: TfrxServerConnection; + TestBtn: TButton; + Log: TMemo; + Rep: TEdit; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + ShowBtn: TButton; + CloseBtn: TButton; + Label4: TLabel; + Label5: TLabel; + Port: TEdit; + Threads: TEdit; + Label6: TLabel; + frxBarCodeObject1: TfrxBarCodeObject; + frxOLEObject1: TfrxOLEObject; + frxChartObject1: TfrxChartObject; + frxRichObject1: TfrxRichObject; + frxCrossObject1: TfrxCrossObject; + frxCheckBoxObject1: TfrxCheckBoxObject; + frxDialogControls1: TfrxDialogControls; + Label7: TLabel; + Login: TEdit; + Label8: TLabel; + Password: TEdit; + StopBtn: TButton; + Label9: TLabel; + Label10: TLabel; + Label11: TLabel; + Image1: TImage; + frxGradientObject1: TfrxGradientObject; + frxHTMLExport1: TfrxHTMLExport; + frxXLSExport1: TfrxXLSExport; + frxXMLExport1: TfrxXMLExport; + frxRTFExport1: TfrxRTFExport; + frxBMPExport1: TfrxBMPExport; + frxJPEGExport1: TfrxJPEGExport; + frxTIFFExport1: TfrxTIFFExport; + frxPDFExport1: TfrxPDFExport; + ProxyHost: TEdit; + Label12: TLabel; + Label13: TLabel; + ProxyPort: TEdit; + Label14: TLabel; + Label15: TLabel; + Panel2: TPanel; + Panel4: TPanel; + Host: TEdit; + ReportsTree: TTreeView; + Description: TMemo; + Label16: TLabel; + Panel5: TPanel; + ExportBtn: TButton; + Label17: TLabel; + Panel10: TPanel; + ConnectBtn: TButton; + Panel11: TPanel; + Panel9: TPanel; + Panel12: TPanel; + Panel13: TPanel; + Panel14: TPanel; + Label18: TLabel; + PopupMenu1: TPopupMenu; + Clear1: TMenuItem; + frxReportClient1: TfrxReportClient; + ImageList1: TImageList; + frxCSVExport1: TfrxCSVExport; + frxSimpleTextExport1: TfrxSimpleTextExport; + frxMailExport1: TfrxMailExport; + procedure TestBtnClick(Sender: TObject); + procedure CloseBtnClick(Sender: TObject); + procedure ShowBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure StopBtnClick(Sender: TObject); + procedure ListBox1DblClick(Sender: TObject); + procedure ListBox1KeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure Label11Click(Sender: TObject); + procedure ConnectBtnClick(Sender: TObject); + procedure Clear1Click(Sender: TObject); + procedure ReportsTreeChange(Sender: TObject; Node: TTreeNode); + procedure ReportsTreeCustomDrawItem(Sender: TCustomTreeView; + Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); + procedure ExportBtnClick(Sender: TObject); + private + ThreadList: TList; + ReportsList: TStringList; + procedure ClearThreads; + end; + + TfrxClientTestThread = class (TThread) + protected + procedure Execute; override; + private + CountRep: Integer; + ErrorsCount: Integer; + Log: TMemo; + ThreadID: Integer; + FConnection: TfrxServerConnection; + FRepName: String; + procedure AppendLog; + procedure FinishLog; + public + Report: TfrxReportClient; + Done: Boolean; + constructor Create(C: TfrxServerConnection; RepName: String; + Id: Integer; Rep: Integer; L: TMemo); + end; + +var + MainForm: TMainForm; + +implementation + +{$IFDEF Delphi7} +uses XPMan; +{$ENDIF} + +{$R *.dfm} + +procedure TMainForm.TestBtnClick(Sender: TObject); +var + i, j, k: Integer; + Thread: TfrxClientTestThread; + s: String; +begin + frxServerConnection1.Host := Host.Text; + frxServerConnection1.Port := StrToInt(Port.Text); + frxServerConnection1.Login := Login.Text; + frxServerConnection1.Password := Password.Text; + if (Length(ProxyHost.Text) > 0) then + begin + frxServerConnection1.ProxyHost := ProxyHost.Text; + frxServerConnection1.ProxyPort := StrToInt(ProxyPort.Text); + end; + ClearThreads; + j := StrToInt(Threads.Text); + k := StrToInt(Rep.Text); + i := Integer(ReportsTree.Selected.Data); + if i <> -1 then + begin + Log.Lines.Add('Start test'); + s := ReportsList[i + 1]; + for i := 1 to j do + begin + Thread := TfrxClientTestThread.Create(frxServerConnection1, s, i, k, Log); + ThreadList.Add(Thread); + end; + end; +end; + +procedure TMainForm.CloseBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.ShowBtnClick(Sender: TObject); +var + t: Cardinal; + tf: Double; + i: Integer; +begin + frxServerConnection1.Host := Host.Text; + frxServerConnection1.Port := StrToInt(Port.Text); + frxServerConnection1.Login := Login.Text; + frxServerConnection1.Password := Password.Text; + if (Length(ProxyHost.Text) > 0) then + begin + frxServerConnection1.ProxyHost := ProxyHost.Text; + frxServerConnection1.ProxyPort := StrToInt(ProxyPort.Text); + end; + i := Integer(ReportsTree.Selected.Data); + if i <> -1 then + begin + frxReportClient1.LoadFromFile(ReportsList[i + 1]); + t := GetTickCount; + if frxReportClient1.PrepareReport then + begin + tf := (GetTickCount - t) / 1000; + Log.Lines.Add(frxReportClient1.ReportName + + ' Time=' + FloatToStr(tf) + ' Size=' + IntToStr(frxReportClient1.Client.StreamSize)); + frxReportClient1.ShowPreparedReport; + end; + Log.Lines.AddStrings(frxReportClient1.Errors); + end; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + Label14.Caption := #174; + Label15.Caption := #169 + Label15.Caption; + ThreadList := TList.Create; + ReportsList := TStringList.Create; +end; + +procedure TMainForm.ClearThreads; +var + i: Integer; +begin + for i := 0 to ThreadList.Count - 1 do + if Assigned(TfrxClientTestThread(ThreadList[i])) then + begin + TfrxClientTestThread(ThreadList[i]).Terminate; + TfrxClientTestThread(ThreadList[i]).Free; + end; + ThreadList.Clear; +end; + +procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + ReportsList.Free; + ClearThreads; + ThreadList.Free; +end; + +procedure TMainForm.StopBtnClick(Sender: TObject); +begin + ClearThreads; +end; + +procedure TMainForm.ListBox1DblClick(Sender: TObject); +begin + ShowBtnClick(Sender); +end; + +procedure TMainForm.ListBox1KeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = 13 then + ShowBtnClick(Sender); +end; + +procedure TMainForm.Label11Click(Sender: TObject); +begin + ShellExecute(GetDesktopWindow, 'open', PChar(Label11.Caption), nil, nil, SW_SHOW); +end; + +procedure TMainForm.ConnectBtnClick(Sender: TObject); +var + t: Cardinal; + tf: Double; + s, s1: String; + AccessFlag: Boolean; + i: Integer; + Node: TTreeNode; + TopNode: TTreeNode; + OldName: String; + +begin + ReportsTree.Items.Clear; + ReportsList.Clear; + Log.Clear; + + frxServerConnection1.Host := Host.Text; + frxServerConnection1.Port := StrToInt(Port.Text); + frxServerConnection1.Login := Login.Text; + frxServerConnection1.Password := Password.Text; + if (Length(ProxyHost.Text) > 0) then + begin + frxServerConnection1.ProxyHost := ProxyHost.Text; + frxServerConnection1.ProxyPort := StrToInt(ProxyPort.Text); + end; + t := GetTickCount; + Log.Lines.Text := Log.Lines.Text + + frxReportClient1.GetServerVariable('SERVER_NAME'); + tf := (GetTickCount - t) / 1000; + if frxReportClient1.Errors.Count = 0 then + begin + Log.Lines.Text := Log.Lines.Text + + 'Version: ' + frxReportClient1.GetServerVariable('SERVER_SOFTWARE'); + Log.Lines.Text := Log.Lines.Text + + 'From: ' + frxReportClient1.GetServerVariable('SERVER_LAST_UPDATE'); + Log.Lines.Text := Log.Lines.Text + + 'Uptime: ' + frxReportClient1.GetServerVariable('SERVER_UPTIME'); + Log.Lines.Add('Ping:' + FloatToStr(tf) + 'ms.'); + end; + Log.Lines.AddStrings(frxReportClient1.Errors); + + AccessFlag := frxReportClient1.Errors.Count = 0; + + if AccessFlag then + begin + ReportsList.Text := frxReportClient1.GetServerVariable('SERVER_REPORTS_LIST'); + if ReportsList.Count > 0 then + begin + ReportsTree.Items.BeginUpdate; + TopNode := nil; + Oldname := ''; + for i := 0 to (ReportsList.Count div 3) - 1 do + begin + s := ReportsList[(i * 3) + 1]; + s := StringReplace(StringReplace(s, ExtractFileName(s), '', []), '\', ' ', [rfReplaceAll]); + if s <> OldName then + begin + if s = '' then + s1 := 'Reports' + else + s1 := s; + Node := ReportsTree.Items.AddChild(nil, s1); + Node.Data := Pointer(-1); + Node.ImageIndex := 0; + TopNode := Node; + OldName := s; + end; + Node := ReportsTree.Items.AddChild(TopNode, ReportsList[i * 3]); + Node.Data := Pointer((i * 3)); + Node.ImageIndex := 1; + end; + ReportsTree.Items.EndUpdate; + ReportsTree.TopItem := ReportsTree.Items[0]; + ReportsTree.Selected := ReportsTree.Items[0]; + ReportsTree.SetFocus; + end else + Log.Lines.Add('Nothing reports is available or information restricted.'); + end; +end; + +procedure TMainForm.Clear1Click(Sender: TObject); +begin + Log.Clear; +end; + +procedure TMainForm.ReportsTreeChange(Sender: TObject; Node: TTreeNode); +var + i: Integer; +begin + i := Integer(Node.Data); + if i <> -1 then + Description.Text := ReportsList[i + 2] + else + Description.Text := Node.Text; + ShowBtn.Enabled := i <> -1; + ExportBtn.Enabled := ShowBtn.Enabled; + TestBtn.Enabled := ShowBtn.Enabled; +end; + +procedure TMainForm.ReportsTreeCustomDrawItem(Sender: TCustomTreeView; + Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); +begin + if Node.Count <> 0 then + ReportsTree.Canvas.Font.Style := [fsBold]; +end; + +procedure TMainForm.ExportBtnClick(Sender: TObject); +var + t: Cardinal; + tf: Double; + i: Integer; +begin + frxServerConnection1.Host := Host.Text; + frxServerConnection1.Port := StrToInt(Port.Text); + frxServerConnection1.Login := Login.Text; + frxServerConnection1.Password := Password.Text; + if (Length(ProxyHost.Text) > 0) then + begin + frxServerConnection1.ProxyHost := ProxyHost.Text; + frxServerConnection1.ProxyPort := StrToInt(ProxyPort.Text); + end; + i := Integer(ReportsTree.Selected.Data); + if i <> -1 then + begin + frxReportClient1.LoadFromFile(ReportsList[i + 1]); + t := GetTickCount; + if frxReportClient1.PrepareReport then + begin + tf := (GetTickCount - t) / 1000; + Log.Lines.Add(frxReportClient1.ReportName + + ' Time=' + FloatToStr(tf) + ' Size=' + IntToStr(frxReportClient1.Client.StreamSize)); + frxReportClient1.Export(frxPDFExport1); + end; + Log.Lines.AddStrings(frxReportClient1.Errors); + end; +end; + +{ TfrxClientTestThread } + +constructor TfrxClientTestThread.Create(C: TfrxServerConnection; RepName: String; + Id: Integer; Rep: Integer; L: TMemo); +begin + inherited Create(True); + ErrorsCount := 0; + ThreadId := Id; + CountRep := Rep; + FConnection := C; + FRepName := RepName; + Log := L; + Done := False; + Resume; +end; + +procedure TfrxClientTestThread.Execute; +var + i: Integer; +begin + Done := False; + Report := TfrxReportClient.Create(nil); + Report.EngineOptions.EnableThreadSafe := True; + Report.ShowProgress := False; + Report.EngineOptions.SilentMode := True; + Report.Connection := FConnection; + Report.ReportName := FRepName; + i := 0; + while (i < CountRep) and (not Terminated) do + begin + Report.Clear; + Report.PrepareReport; + Synchronize(AppendLog); + ErrorsCount := ErrorsCount + Report.Errors.Count; + Inc(i); + end; + Synchronize(FinishLog); + Report.Free; + Done := True; +end; + +procedure TfrxClientTestThread.AppendLog; +begin + if Assigned(Log) and (Report.Errors.Count > 0) then + begin + Log.Lines.Add('Thread#' + IntToStr(ThreadID)); + Log.Lines.AddStrings(Report.Errors); + end; +end; + +procedure TfrxClientTestThread.FinishLog; +begin + if Assigned(Log) and (not Terminated) then + Log.Lines.Add('Thread#' + IntToStr(ThreadID) + ' finished. Errors:' + IntToStr(ErrorsCount)); +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.dpr b/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.dpr new file mode 100644 index 0000000..330bd0c --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.dpr @@ -0,0 +1,14 @@ +program FRClientSimple; + +uses + Forms, + main in 'main.pas' {main}; + +{$R *.res} + +begin + Application.Initialize; + Application.Title := 'FastReport Simple Client Demo'; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.res b/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.res new file mode 100644 index 0000000..06b79d7 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Client/Simple/FRClientSimple.res differ diff --git a/official/4.8.11/Demos/ClientServer/Client/Simple/main.dfm b/official/4.8.11/Demos/ClientServer/Client/Simple/main.dfm new file mode 100644 index 0000000..eb38516 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Client/Simple/main.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/Client/Simple/main.pas b/official/4.8.11/Demos/ClientServer/Client/Simple/main.pas new file mode 100644 index 0000000..14cbfd2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Client/Simple/main.pas @@ -0,0 +1,124 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport simple client demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit main; + +{$I frx.inc} + +interface + +uses + Windows, SysUtils, Classes, Controls, Forms, + Dialogs, StdCtrls, ShellApi, frxClass, frxServerClient, + frxGZip, frxDCtrl, frxChBox, frxCross, frxRich, frxChart, + frxOLE, frxBarcode, ExtCtrls, frxExportPDF, frxExportImage, + frxExportRTF, frxExportXML, frxExportXLS, frxExportHTML, + frxExportTXT, frxGradient, Graphics +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TMainForm = class(TForm) + frxServerConnection1: TfrxServerConnection; + frxReportClient1: TfrxReportClient; + Memo1: TMemo; + Label3: TLabel; + ShowBtn: TButton; + CloseBtn: TButton; + Label4: TLabel; + Label5: TLabel; + Port: TEdit; + frxBarCodeObject1: TfrxBarCodeObject; + frxOLEObject1: TfrxOLEObject; + frxChartObject1: TfrxChartObject; + frxRichObject1: TfrxRichObject; + frxCrossObject1: TfrxCrossObject; + frxCheckBoxObject1: TfrxCheckBoxObject; + frxDialogControls1: TfrxDialogControls; + Label7: TLabel; + Login: TEdit; + Label8: TLabel; + Password: TEdit; + Label9: TLabel; + Label10: TLabel; + Label11: TLabel; + Image1: TImage; + Panel1: TPanel; + frxHTMLExport1: TfrxHTMLExport; + frxXLSExport1: TfrxXLSExport; + frxRTFExport1: TfrxRTFExport; + frxPDFExport1: TfrxPDFExport; + Label14: TLabel; + Label15: TLabel; + Panel2: TPanel; + Host: TEdit; + Label1: TLabel; + RepName: TEdit; + Label2: TLabel; + Label6: TLabel; + Param1: TEdit; + Param1Value: TEdit; + Label12: TLabel; + Label13: TLabel; + Param2: TEdit; + Param2Value: TEdit; + procedure CloseBtnClick(Sender: TObject); + procedure ShowBtnClick(Sender: TObject); + procedure Label11Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + end; + +var + MainForm: TMainForm; + +implementation + +{$R *.dfm} + +{$IFDEF Delphi7} +uses XPMan; +{$ENDIF} + +procedure TMainForm.CloseBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.ShowBtnClick(Sender: TObject); +begin + frxServerConnection1.Host := Host.Text; + frxServerConnection1.Port := StrToInt(Port.Text); + frxServerConnection1.Login := Login.Text; + frxServerConnection1.Password := Password.Text; + frxReportClient1.LoadFromFile(RepName.Text); + frxReportClient1.Variables.Clear; + if Length(Param1Value.Text) > 0 then + frxReportClient1.Variables[Param1.Text] := Param1Value.Text; + if Length(Param2Value.Text) > 0 then + frxReportClient1.Variables[Param2.Text] := Param2Value.Text; + if frxReportClient1.PrepareReport then + frxReportClient1.ShowPreparedReport; + Memo1.Lines.AddStrings(frxReportClient1.Errors); +end; + +procedure TMainForm.Label11Click(Sender: TObject); +begin + ShellExecute(GetDesktopWindow, 'open', PChar(Label11.Caption), nil, nil, SW_SHOW); +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + Label14.Caption := #174; + Label15.Caption := #169 + label15.Caption; +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/CustomForm/index.html b/official/4.8.11/Demos/ClientServer/CustomForm/index.html new file mode 100644 index 0000000..7af32d4 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/CustomForm/index.html @@ -0,0 +1,17 @@ + + + + + Test of POST form + + + +
+ + + Enter the value of "param1"
+ Enter the value of "param2"
+ +
+ + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.dpr b/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.dpr new file mode 100644 index 0000000..51eb561 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.dpr @@ -0,0 +1,24 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ ISAPI extension library } +{ Copyright (c) 2006-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +library fastreport; + +uses + frxISAPI; + +exports + GetExtensionVersion, + HttpExtensionProc, + TerminateExtension; + +begin + +end. diff --git a/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.res b/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.res new file mode 100644 index 0000000..1228533 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/ISAPI/fastreport.res differ diff --git a/official/4.8.11/Demos/ClientServer/Server/FRServer.dpr b/official/4.8.11/Demos/ClientServer/Server/FRServer.dpr new file mode 100644 index 0000000..70a5bea --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/FRServer.dpr @@ -0,0 +1,15 @@ +program FRServer; + +uses + Windows, + Forms, + Main in 'Main.pas' {main}; + +{$R *.RES} + +begin + Application.Initialize; + Application.Title := 'FastReport Server Demo'; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/official/4.8.11/Demos/ClientServer/Server/FRServer.res b/official/4.8.11/Demos/ClientServer/Server/FRServer.res new file mode 100644 index 0000000..06b79d7 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/FRServer.res differ diff --git a/official/4.8.11/Demos/ClientServer/Server/Main.dfm b/official/4.8.11/Demos/ClientServer/Server/Main.dfm new file mode 100644 index 0000000..d8180e8 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/Main.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/Server/Main.pas b/official/4.8.11/Demos/ClientServer/Server/Main.pas new file mode 100644 index 0000000..91968a1 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/Main.pas @@ -0,0 +1,288 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport Server demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit Main; + +{$I frx.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + StdCtrls, Db, DBTables, frxDesgn, frxClass, frxDCtrl, + frxChart, frxRich, frxBarcode, ImgList, ComCtrls, ExtCtrls, frxOLE, + frxCross, frxServer, frxGradient, frxChBox, Menus, ShellApi, + frxADOComponents, ADODB, frxGZip, Dialogs, frxMD5, frxServerUtils, IniFiles, + frxServerStat, frxServerConfig, frxVariables; + +type + TMainForm = class(TForm) + frBarCodeObject1: TfrxBarCodeObject; + frRichObject1: TfrxRichObject; + frChartObject1: TfrxChartObject; + frDialogControls1: TfrxDialogControls; + ImageList1: TImageList; + Image1: TImage; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + frOLEObject1: TfrxOLEObject; + frCrossObject1: TfrxCrossObject; + frxCheckBoxObject1: TfrxCheckBoxObject; + PopupMenu1: TPopupMenu; + Close1: TMenuItem; + ShowWin: TMenuItem; + N1: TMenuItem; + MinimizeBtn: TButton; + CloseBtn: TButton; + GroupBox1: TGroupBox; + Label4: TLabel; + LBActive: TLabel; + LBInactive: TLabel; + GroupBox2: TGroupBox; + Label5: TLabel; + ETotalSessions: TEdit; + Label6: TLabel; + ETotalReports: TEdit; + Timer1: TTimer; + Label7: TLabel; + Label8: TLabel; + EMaxReports: TEdit; + EMaxSessions: TEdit; + Label9: TLabel; + Label10: TLabel; + ECurrentReports: TEdit; + ECurrentSessions: TEdit; + Label11: TLabel; + EErrors: TEdit; + N2: TMenuItem; + Start1: TMenuItem; + Stop1: TMenuItem; + StartBtn: TButton; + StopBtn: TButton; + DesignBtn: TButton; + frxDesigner1: TfrxDesigner; + OpenDialog1: TOpenDialog; + Label12: TLabel; + Uptime: TLabel; + frxADOComponents1: TfrxADOComponents; + Serv: TfrxReportServer; + Label13: TLabel; + DemoDatabase: TADOConnection; + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure MinimizeBtnClick(Sender: TObject); + procedure ShutBtnClick(Sender: TObject); + procedure ShowWinClick(Sender: TObject); + procedure StartBtnClick(Sender: TObject); + procedure StopBtnClick(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + procedure DesignBtnClick(Sender: TObject); + procedure Label3Click(Sender: TObject); + procedure ServGetVariables(const ReportName: String; + Variables: TfrxVariables; User: String); + protected + procedure ControlWindow(var Msg:TMessage); message WM_SYSCOMMAND; + procedure IconMouse(var Msg : TMessage); message WM_USER + 1; + private + Icon: TIcon; + frReport1: TfrxReport; + procedure TrayIcon(n: Integer; Icon: TIcon); + end; + +var + MainForm: TMainForm; + dbMd: String; + +implementation + +{$R *.DFM} + +{$IFDEF Delphi7} +uses XPMan; +{$ENDIF} + +var + DATABASE_FILE: String; + DBConnStr: String = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='; + +procedure TMainForm.TrayIcon(n:Integer;Icon:TIcon); +var + Nim: TNotifyIconData; +begin + with Nim do + begin + cbSize:=SizeOf(Nim); + Wnd:=Self.Handle; + uID:=1; + uFlags:=NIF_ICON or NIF_MESSAGE or NIF_TIP; + hicon:=Icon.Handle; + uCallbackMessage:=WM_USER + 1; + szTip:='FastReport Server'; + end; + case n of + 1: Shell_NotifyIcon(Nim_Add,@Nim); + 2: Shell_NotifyIcon(Nim_Delete,@Nim); + 3: Shell_NotifyIcon(Nim_Modify,@Nim); + end; +end; + +procedure TMainForm.ControlWindow(var Msg: TMessage); +begin + if Msg.WParam = SC_MINIMIZE then + begin + TrayIcon(1, Icon); + ShowWindow(Application.Handle, SW_HIDE); + ShowWindow(Handle, SW_HIDE); + end else + inherited; +end; + +procedure TMainForm.IconMouse(var Msg: TMessage); +var + p:tpoint; +begin + GetCursorPos(p); + case Msg.LParam of + WM_LBUTTONUP, WM_LBUTTONDBLCLK: + ShowWinClick(nil); + WM_RBUTTONUP: + begin + SetForegroundWindow(Handle); + PopupMenu1.Popup(p.X, p.Y); + PostMessage(Handle,WM_NULL,0,0) + end; + End; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + Label13.Caption := #174; + Icon := TIcon.Create; + ImageList1.GetIcon(0, Icon); + DemoDatabase.ConnectionString := DBConnStr + frxGetAbsPath(ServerConfig.GetValue('server.database.pathtodatabase')); + try + DemoDatabase.Open; + except + ShowMessage('Error database connection!'); + end; + StartBtnClick(Sender); + MinimizeBtnClick(Sender); +end; + +procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + if Serv <> nil then + StopBtnClick(Sender); + TrayIcon(2, Icon); + Icon.Free; + if DemoDatabase.Connected then + DemoDatabase.Close; +end; + +procedure TMainForm.MinimizeBtnClick(Sender: TObject); +begin + PostMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0); +end; + +procedure TMainForm.ShutBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.ShowWinClick(Sender: TObject); +begin + ShowWindow(Application.Handle, SW_SHOWNORMAL); + ShowWindow(Handle, SW_SHOWNORMAL); +end; + +procedure TMainForm.StartBtnClick(Sender: TObject); +begin + if DemoDatabase.Connected then + begin + Screen.Cursor := crHourGlass; + try + Serv.Open; + if Serv.Active then + begin + StartBtn.Enabled := False; + StopBtn.Enabled := True; + LBActive.Visible := True; + LBInactive.Visible := False; + Timer1.Enabled := True; + ImageList1.GetIcon(0, Icon); + TrayIcon(3, Icon); + Start1.Enabled := False; + Stop1.Enabled := True; + end; + finally + Screen.Cursor := crDefault; + end; + end; +end; + +procedure TMainForm.StopBtnClick(Sender: TObject); +begin + Screen.Cursor := crHourGlass; + try + Timer1.Enabled := False; + Serv.Close; + StartBtn.Enabled := True; + StopBtn.Enabled := False; + LBActive.Visible := False; + LBInactive.Visible := True; + ImageList1.GetIcon(1, Icon); + TrayIcon(3, Icon); + Start1.Enabled := True; + Stop1.Enabled := False; + finally + Screen.Cursor := crDefault; + end; +end; + +procedure TMainForm.Timer1Timer(Sender: TObject); +begin + ETotalSessions.Text := IntToStr(ServerStatistic.TotalSessionsCount); + ETotalReports.Text := IntToStr(ServerStatistic.TotalReportsCount); + EMaxSessions.Text := IntToStr(ServerStatistic.MaxSessionsCount); + EMaxReports.Text := IntToStr(ServerStatistic.MaxReportsCount); + EErrors.Text := IntToStr(ServerStatistic.TotalErrors); + ECurrentSessions.Text := IntToStr(ServerStatistic.CurrentSessionsCount); + ECurrentReports.Text := IntToStr(ServerStatistic.CurrentReportsCount); + Uptime.Caption := ServerStatistic.FormatUpTime; + Label2.Caption := 'Version: ' + String(Serv.Variables.GetValue('SERVER_SOFTWARE')); +end; + +procedure TMainForm.DesignBtnClick(Sender: TObject); +begin + OpenDialog1.InitialDir := Serv.Configuration.ReportPath; + if OpenDialog1.Execute then + begin + frReport1 := TfrxReport.Create(nil); + frReport1.LoadFromFile(OpenDialog1.FileName); + frReport1.Variables['PathToDataBase'] := '''' + DATABASE_FILE + ''''; + frReport1.DesignReport; + frReport1.Free; + end; +end; + +procedure TMainForm.Label3Click(Sender: TObject); +begin + ShellExecute(GetDesktopWindow, 'open', PChar(Label3.Caption), nil, nil, SW_SHOW); +end; + +procedure TMainForm.ServGetVariables(const ReportName: String; + Variables: TfrxVariables; User: String); +begin + Variables['param1'] := QuotedStr('add new variable'); +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/Server/allow.conf b/official/4.8.11/Demos/ClientServer/Server/allow.conf new file mode 100644 index 0000000..e69de29 diff --git a/official/4.8.11/Demos/ClientServer/Server/config.xml b/official/4.8.11/Demos/ClientServer/Server/config.xml new file mode 100644 index 0000000..7ec28b2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/config.xml @@ -0,0 +1,157 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/deny.conf b/official/4.8.11/Demos/ClientServer/Server/deny.conf new file mode 100644 index 0000000..e69de29 diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/about.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/about.html new file mode 100644 index 0000000..e697743 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/about.html @@ -0,0 +1,35 @@ + || Short description + +Back to main page
 +
+Short description
+

1. Introduction

+

+FastReport server provides many features for server side reporting in +internet/intranet networks. FastReport 3 is the kernel of the +reporting engine. Fast and poweful server engine use +Hypertext Transfer Protocol (HTTP, RFC 2068). The FastReport Server +completely autonomous and does not require using other HTTP server (Apache, IIS etc). +Detailed expected features list you will to read here.

+

2. FastReport Server Purpose

+

+

    +
  • Internet/intranet reporting +
  • Web-development +
  • End-user solutions providing functionality for business analytics, financials, human capital management, operations, corporate services +
  • Industrial client-server application +
+

+

3. Requirements

+

Operation system: Microsoft Windows NT4/2000/2003 + Server.
+ Network: based on TCP/IP protocol.
+

+

4. Feedback

+

All wishes, bug-reports and opinions send to e-mail.

+
+Back to main page
+ + + + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/bottom.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/bottom.html new file mode 100644 index 0000000..d3f5a12 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/bottom.html @@ -0,0 +1 @@ + diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/changes.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/changes.html new file mode 100644 index 0000000..02c8545 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/changes.html @@ -0,0 +1,32 @@ + || Changes + +Back to the main page +

Changes in version 2.1.0

+ +
    +
  • Added Windows Authentification mode +
  • Improved CGI for IIS/Apache server +
  • Advanced log information on errors +
  • Stability improvements +
  • Speed improvements +
  • Bug fixes +
+ +

Changes in version 2.0

+ +
    +
  • FastReport 4 kernel for reports execution +
  • Additional formats support: ODS, ODT - Open Document Format (OpenOffice, OASIS spec.) +
  • Print on network printers from web interface +
  • Templates for customization in web interface +
  • Reports shedule - cache, e-mail (smtp) sending +
  • Database connection, configuration, users auto-refresh without server restart +
  • Speed improvements +
  • Bug fixes +
+ +
Back to the main page
+ + + + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/default.css b/official/4.8.11/Demos/ClientServer/Server/htdocs/default.css new file mode 100644 index 0000000..13b390b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/default.css @@ -0,0 +1,137 @@ +BODY { + font-family: Tahoma; font-size: 9pt; color: #000; margin: 10px; padding: 0px; background-color: #FFF; text-align: left } + +TABLE, TR, TD { + font-family: Tahoma; font-size: 8pt; color: #000; padding: 2px;} + +.copyright { + font : 8pt Tahoma; +} + +.topcopyright { + font : 8pt Tahoma; + COLOR : #ffffff; +} + +a { + font : 8pt Tahoma; + COLOR : #89161C; + FONT-WEIGHT : bold; + TEXT-DECORATION : none; +} + +a:hover { + font : 8pt Tahoma; + COLOR : #49161C; + FONT-WEIGHT : bold; + TEXT-DECORATION : underline; +} + +.nav { + font : 8pt Tahoma; + COLOR : white; + FONT-WEIGHT : bold; + TEXT-DECORATION : none; +} + +.nav:hover { + font : 8pt Tahoma; + COLOR : black; + FONT-WEIGHT : bold; + TEXT-DECORATION : underline; +} + +.bottomnav { + font : 8pt Tahoma; + COLOR : black; + FONT-WEIGHT : bold; + TEXT-DECORATION : none; +} + +.bottomnav:hover { + font : 8pt Tahoma; + COLOR : black; + FONT-WEIGHT : bold; + TEXT-DECORATION : underline; +} + +.txtbody +{ + font : 8pt Tahoma; + vertical-align: top ; + height:100%; + width :100%; +} + +.right { + font : 8pt Tahoma; + COLOR : black; + FONT-WEIGHT : bold; + padding-left : 8px; + padding-right : 6px; + text-align : center; +} + +.tit { + font : 10pt Tahoma; + COLOR : black; + FONT-WEIGHT : bold; + padding-left : 8px; + padding-right : 6px; + margin-left : 6px; + margin-right : 4px; + height : 20; + background-color : #e2e2e2; +} + + +td.title { + font : 8pt Tahoma; + COLOR : white; + FONT-WEIGHT : bold; + TEXT-DECORATION : none; + text-align : center; + height : 18; + background-color : #2b4a7f; +} + +td.down{ + font : 8pt Tahoma; + } + +th.down{ + font : 8pt Tahoma; + FONT-WEIGHT : bold; + } + + +a.copyright { + font : 8pt Tahoma; + COLOR : black; + TEXT-DECORATION : none; +} + +a.copyright:hover { + font : 8pt Tahoma; + COLOR : black; + TEXT-DECORATION : underline; +} + +PRE{ + font : 8pt Curier; + } + +.pagetitle { + font : 12pt Verdana; + color : #ffffff; + FONT-WEIGHT : bold; + FONT-style: italic; + +} + +.pageheader +{ + background-color : #2b4a7f; + background-repeat: no-repeat; + background-position:top left +} \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/favicon.ico b/official/4.8.11/Demos/ClientServer/Server/htdocs/favicon.ico new file mode 100644 index 0000000..1cb40d2 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/htdocs/favicon.ico differ diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/features.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/features.html new file mode 100644 index 0000000..ac49759 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/features.html @@ -0,0 +1,33 @@ + || Expected features list + +Back to main page
 +

+Expected features list
+

+

    +
  • Full FastReport 3 compatibility +
  • Hypertext transport protocol (HTTP) compatibility (RFC 2616) +
  • Standalone web-server mode +
  • Advanced security for multiple user groups and access permissions +
  • Gzip compressing support (RFC 1952) for client-server files transfer +
  • Server Side Includes (SSI) allow a webmaster to include dynamic content from the other servers +
  • Multiplatform client module +
  • Access to server from client application (with FastReport client module) +
  • Access to server from any web-browser +
  • PDF, XML, Jpeg, RTF, HTML output format support +
  • Remote administrator access to server control panel +
  • Full access and errors logging +
  • Web-forms support +
  • FastReport forms on the fly converting to web-forms +
  • Multiple database types support +
  • Multiple database connections support +
  • Network printing support (dot-matrix printers supported) +
  • Multiprocessor hardware platform support +
+

+
+Back to main page
+ + + + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/header.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/header.html new file mode 100644 index 0000000..e148196 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/header.html @@ -0,0 +1,3 @@ + + +<!--#echo var="SERVER_NAME"--> \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/index.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/index.html new file mode 100644 index 0000000..bf55da4 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/index.html @@ -0,0 +1,63 @@ +<!--#include virtual="header.html" --> || Test page +<!--#include virtual="top.html" --> +<p><font face="Tahoma" size="4"> +<b>List of available reports at the server</b><br></font></p> +<font face="Tahoma" size="2"> +<!--#echo var="SERVER_REPORTS_HTML"--> +</font> +<p><font face="Tahoma" size="4"> +<b>Parameters testing</b> +</font></p> + +<table width="750" border="0" cellspacing="2" cellpadding="2"> +<tr><td class=tit> +<b>1.Page navigator</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&multipage=0&pagenav=0" target=_blank>01.Simple list on single page without page navigator</a> +<br>  +</td></tr> +<tr><td class=tit> +<b>2.Pages view</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&multipage=0" target=_blank>01.Simple list on single page</a> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&multipage=1" target=_blank>02.Simple list on multi page</a> +<br>  +</td></tr> +<tr><td class=tit> +<b>3.Page range</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\03.Nested groups.fr3&pagerange=1-2&multipage=0&pagenav=0" target=_blank>01.Nested groups pages 1-2 on single page without pagenavigator</a> +<br>  +</td></tr> +<tr><td class=tit> +<b>4.Custom variables</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&multipage=0¶m1=Test param1¶m2=Test param2" target=_blank>01.Simple list with Param1='Test param1' and Param2='Test param2'</a> +<br>  +</td></tr> +<tr><td class=tit> +<b>5.Export to any formats</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&format=PDF">01.Simple list in PDF</a> +<br><a href="result?report=1.Basic reports\03.Nested groups.fr3&format=PDF">02.Nested groups in PDF</a> +<br><a href="result?report=2.Cross-tabs\05.Two rows, one column.fr3&format=PDF">03.Two rows, one column in PDF</a> +<br><a href="result?report=4.Misc\04.Preview outline.fr3&format=PDF">04.Outline in PDF</a> +<br><a href="result?report=3.Charts\01.Countries.fr3&format=PDF">05.Countries in PDF</a> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&format=RTF">06.Simple list in RTF</a> +<br><a href="result?report=1.Basic reports\07.Multi-column bands.fr3&format=XML">07.Multi-column bands in XML</a> +<br><a href="result?report=1.Basic reports\07.Multi-column bands.fr3&format=XLS">08.Multi-column bands in XLS</a> +<br><a href="result?report=1.Basic reports\02.Simple group.fr3&format=TXT">09.Simple group in TXT</a> +<br><a href="result?report=1.Basic reports\02.Simple group.fr3&format=FRP">10.Simple group in FP3</a> +<br><a href="result?report=1.Basic reports\02.Simple group.fr3&format=JPG">11.Simple group in JPG</a> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3&format=ODS">12.Simple list in ODS (Open Document Spreadsheet)</a> +<br>  +</td></tr> +</table> +<!--#include virtual="bottom.html" --> +</body> +</html> \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/index2.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/index2.html new file mode 100644 index 0000000..b4b0243 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/index2.html @@ -0,0 +1,19 @@ +<!--#include virtual="header.html" --> || Test page +<!--#include virtual="top.html" --> +<font face="Tahoma" size="3"> +<font face="Tahoma" size="3"> +<h3><b>Test index file for group</b></h3> +</font> + +<table width="80%" border="0" cellspacing="2" cellpadding="2"> +<tr><td class=tit> +<b>Reports</b> +</td></tr> +<tr><td class=txtbody> +<br><a href="result?report=1.Basic reports\01.Simple list.fr3" target=_blank>01.Simple list</a> - Demonstrates how to create simple list report. +<br>  +</td></tr> +</table> +<!--#include virtual="bottom.html" --> +</body> +</html> \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/logo.gif b/official/4.8.11/Demos/ClientServer/Server/htdocs/logo.gif new file mode 100644 index 0000000..9216e70 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/htdocs/logo.gif differ diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/reports.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/reports.html new file mode 100644 index 0000000..ead3d56 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/reports.html @@ -0,0 +1,19 @@ +<!--#include virtual="header.html" --> || Reports +<!--#include virtual="top.html" --> +<font face="Tahoma" size="3"><a href="index.html"><b>Back to main page</b></a><br></font> +<hr> +<font face="Tahoma" size="4"> +<b>List of available reports at the server</b><br><br></font> +<font face="Tahoma" size="3"> + + +<!--#echo var="SERVER_REPORTS_HTML"--> + +</font> + +<hr> +<font face="Tahoma" size="3"><a href="index.html"><b>Back to main page</b></a><br> +</font> +<!--#include virtual="bottom.html" --> +</body> +</html> \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/server-bw.gif b/official/4.8.11/Demos/ClientServer/Server/htdocs/server-bw.gif new file mode 100644 index 0000000..8fd49e0 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/htdocs/server-bw.gif differ diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/server-colour.gif b/official/4.8.11/Demos/ClientServer/Server/htdocs/server-colour.gif new file mode 100644 index 0000000..e711191 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Server/htdocs/server-colour.gif differ diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/statistic.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/statistic.html new file mode 100644 index 0000000..14c4bf4 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/statistic.html @@ -0,0 +1,18 @@ +<!--#include virtual="header.html" --> || Statistic +<!--#include virtual="top.html" --> +<b><a href="index.html">Back to the main page</a></b> +<p><font face="Tahoma" size="4"><b>On-line statistic</b></p> +<font face="Tahoma" size="3"> +<table width="500" border="1" cellspacing="2" cellpadding="2"> +<tr><td align="right" width="200"><b>Uptime:</b></td><td width="300"><!--#echo var="SERVER_UPTIME"--></td></tr> +<tr><td align="right"><b>Total sessions:</b></td><td><!--#echo var="SERVER_TOTAL_SESSIONS"--></td></tr> +<tr><td align="right"><b>Total reports:</b></td><td><!--#echo var="SERVER_TOTAL_REPORTS"--></td></tr> +<tr><td align="right"><b>Max sessions:</b></td><td><!--#echo var="SERVER_MAX_SESSIONS"--></td></tr> +<tr><td align="right"><b>Max reports:</b></td><td><!--#echo var="SERVER_MAX_REPORTS"--></td></tr> +</table> +</font> +<br><font face="Tahoma" size="3"><a href="index.html"><b>Back to the main page</b></a><br> +</font> +<!--#include virtual="bottom.html" --> +</body> +</html> \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/htdocs/top.html b/official/4.8.11/Demos/ClientServer/Server/htdocs/top.html new file mode 100644 index 0000000..60f08e8 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/htdocs/top.html @@ -0,0 +1,19 @@ + + + + + + + +
Reporting must be fast +
+ Version:
+ + 		+ Changes in version 2.0
+ On-line statistic
+ + Contact e-mail
+ FastReport home site + +
\ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/readme.txt b/official/4.8.11/Demos/ClientServer/Server/readme.txt new file mode 100644 index 0000000..5217cd9 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/readme.txt @@ -0,0 +1,4 @@ +IMPORTANT: + +This demo can be compiled only in the version Delphi/C++Builder 5 and higher. +(ADO components used in database connection). \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/01.Simple list.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/01.Simple list.fr3 new file mode 100644 index 0000000..05d0d29 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/01.Simple list.fr3 @@ -0,0 +1,31 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/02.Simple group.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/02.Simple group.fr3 new file mode 100644 index 0000000..eff74a2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/02.Simple group.fr3 @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/03.Nested groups.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/03.Nested groups.fr3 new file mode 100644 index 0000000..a417d51 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/03.Nested groups.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/04.Master-Detail-Subdetail.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/04.Master-Detail-Subdetail.fr3 new file mode 100644 index 0000000..53bd3d0 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/04.Master-Detail-Subdetail.fr3 @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/05.Master-Detail-Detail.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/05.Master-Detail-Detail.fr3 new file mode 100644 index 0000000..7646b81 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/05.Master-Detail-Detail.fr3 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/06.Multi-column list.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/06.Multi-column list.fr3 new file mode 100644 index 0000000..8389f6d --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/06.Multi-column list.fr3 @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/07.Multi-column bands.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/07.Multi-column bands.fr3 new file mode 100644 index 0000000..2cb3c69 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/07.Multi-column bands.fr3 @@ -0,0 +1,13 @@ + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/08.Memos and pictures.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/08.Memos and pictures.fr3 new file mode 100644 index 0000000..122b173 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/08.Memos and pictures.fr3 @@ -0,0 +1,21 @@ + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/09.Split bands.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/09.Split bands.fr3 new file mode 100644 index 0000000..7389a53 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/09.Split bands.fr3 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/10.Subreports.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/10.Subreports.fr3 new file mode 100644 index 0000000..ee6c186 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/10.Subreports.fr3 @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/11.Side-by-Side subreports.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/11.Side-by-Side subreports.fr3 new file mode 100644 index 0000000..306ca6b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/11.Side-by-Side subreports.fr3 @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/12.Report with title page.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/12.Report with title page.fr3 new file mode 100644 index 0000000..d110cbb --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/12.Report with title page.fr3 @@ -0,0 +1,30 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/13.URLs, anchors.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/13.URLs, anchors.fr3 new file mode 100644 index 0000000..568f769 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/13.URLs, anchors.fr3 @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/14.Keep group together.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/14.Keep group together.fr3 new file mode 100644 index 0000000..e0365f7 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/14.Keep group together.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/15.Totals in group header.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/15.Totals in group header.fr3 new file mode 100644 index 0000000..0ff0117 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/1.Basic reports/15.Totals in group header.fr3 @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/01.One row.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/01.One row.fr3 new file mode 100644 index 0000000..12d145a --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/01.One row.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/02.One column.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/02.One column.fr3 new file mode 100644 index 0000000..78b414b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/02.One column.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/03.One row, one column.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/03.One row, one column.fr3 new file mode 100644 index 0000000..6ed1d02 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/03.One row, one column.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/04.Two rows.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/04.Two rows.fr3 new file mode 100644 index 0000000..c5cfeda --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/04.Two rows.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/05.Two rows, one column.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/05.Two rows, one column.fr3 new file mode 100644 index 0000000..59d12cd --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/05.Two rows, one column.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/06.Two columns, one row.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/06.Two columns, one row.fr3 new file mode 100644 index 0000000..87b6039 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/06.Two columns, one row.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/07.Two cell values.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/07.Two cell values.fr3 new file mode 100644 index 0000000..bd6b821 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/07.Two cell values.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/08.Highlight.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/08.Highlight.fr3 new file mode 100644 index 0000000..5c342ac --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/08.Highlight.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/09.Two cross-tabs.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/09.Two cross-tabs.fr3 new file mode 100644 index 0000000..fd03681 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/09.Two cross-tabs.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/10.Cross from non-DB data.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/10.Cross from non-DB data.fr3 new file mode 100644 index 0000000..f841d46 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/10.Cross from non-DB data.fr3 @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/11.Cross-bands.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/11.Cross-bands.fr3 new file mode 100644 index 0000000..c34a18e --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/11.Cross-bands.fr3 @@ -0,0 +1,21 @@ + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/12.Calendar.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/12.Calendar.fr3 new file mode 100644 index 0000000..2ad9583 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/2.Cross-tabs/12.Calendar.fr3 @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/01.Countries.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/01.Countries.fr3 new file mode 100644 index 0000000..c9d0a3f --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/01.Countries.fr3 @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/02.Exchange rates.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/02.Exchange rates.fr3 new file mode 100644 index 0000000..8ebc608 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/3.Charts/02.Exchange rates.fr3 @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/01.Rotation, fills and shapes.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/01.Rotation, fills and shapes.fr3 new file mode 100644 index 0000000..d3fa56f --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/01.Rotation, fills and shapes.fr3 @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/02.Barcode.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/02.Barcode.fr3 new file mode 100644 index 0000000..a7d8344 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/02.Barcode.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/03.HTML and text.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/03.HTML and text.fr3 new file mode 100644 index 0000000..9bc8c8c --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/03.HTML and text.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/04.Preview outline.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/04.Preview outline.fr3 new file mode 100644 index 0000000..ea907c2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/04.Preview outline.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/05.Unicode.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/05.Unicode.fr3 new file mode 100644 index 0000000..a70c764 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/4.Misc/05.Unicode.fr3 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/01.Ask for parameters.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/01.Ask for parameters.fr3 new file mode 100644 index 0000000..27a5604 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/01.Ask for parameters.fr3 @@ -0,0 +1,13 @@ + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/02.Client-server dialogs.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/02.Client-server dialogs.fr3 new file mode 100644 index 0000000..ffb46f6 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/02.Client-server dialogs.fr3 @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/03.Dialog query.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/03.Dialog query.fr3 new file mode 100644 index 0000000..62448a8 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/03.Dialog query.fr3 @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/04.Dialog and script.fr3 b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/04.Dialog and script.fr3 new file mode 100644 index 0000000..0c6d402 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/reports/5.Dialogs and script/04.Dialog and script.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/error403.html b/official/4.8.11/Demos/ClientServer/Server/templates/error403.html new file mode 100644 index 0000000..3820e0d --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/error403.html @@ -0,0 +1 @@ +Forbidden

ERROR 403
Forbidden

diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/error404.html b/official/4.8.11/Demos/ClientServer/Server/templates/error404.html new file mode 100644 index 0000000..601e238 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/error404.html @@ -0,0 +1 @@ +Not found

ERROR 404
Not found

diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/error500.html b/official/4.8.11/Demos/ClientServer/Server/templates/error500.html new file mode 100644 index 0000000..8cf0801 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/error500.html @@ -0,0 +1 @@ +Internal error

ERROR 500
Internal error

diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_begin.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_begin.html new file mode 100644 index 0000000..15d2532 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_begin.html @@ -0,0 +1,16 @@ + + + +<!--#echo var="TITLE"--> +> + + + +
+
+"> + + +"> +" align="center" style="border: solid 1px #000000"> + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_button.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_button.html new file mode 100644 index 0000000..6195d75 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_button.html @@ -0,0 +1 @@ +" value=""> diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_checkbox.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_checkbox.html new file mode 100644 index 0000000..c89b333 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_checkbox.html @@ -0,0 +1,3 @@ +" value="" > +; font-size: px; +color: ; background-color: ;"> diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_date.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_date.html new file mode 100644 index 0000000..eba65d2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_date.html @@ -0,0 +1 @@ +" name="" value="" id="" size="" maxlength="" > diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_end.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_end.html new file mode 100644 index 0000000..9118bdf --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_end.html @@ -0,0 +1,6 @@ + + +
">
">  +
+
+ diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_label.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_label.html new file mode 100644 index 0000000..f6c7ec2 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_label.html @@ -0,0 +1,4 @@ +; + font-size: px; + color: ; + background-color: ;"> diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_memo.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_memo.html new file mode 100644 index 0000000..170e237 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_memo.html @@ -0,0 +1 @@ + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_radio.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_radio.html new file mode 100644 index 0000000..5417771 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_radio.html @@ -0,0 +1 @@ +" value="" >; font-size: px; color: ; background-color: ;"> diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/form_select.html b/official/4.8.11/Demos/ClientServer/Server/templates/form_select.html new file mode 100644 index 0000000..c8d54d9 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/form_select.html @@ -0,0 +1 @@ +" name="" value="" id="" size="" maxlength="" > diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/list_begin.html b/official/4.8.11/Demos/ClientServer/Server/templates/list_begin.html new file mode 100644 index 0000000..e36b5c5 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/list_begin.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/list_end.html b/official/4.8.11/Demos/ClientServer/Server/templates/list_end.html new file mode 100644 index 0000000..94eb82e --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/list_end.html @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/list_header.html b/official/4.8.11/Demos/ClientServer/Server/templates/list_header.html new file mode 100644 index 0000000..a06ae43 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/list_header.html @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/list_line.html b/official/4.8.11/Demos/ClientServer/Server/templates/list_line.html new file mode 100644 index 0000000..ef3a499 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/list_line.html @@ -0,0 +1 @@ +" target=_blank> diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/main.html b/official/4.8.11/Demos/ClientServer/Server/templates/main.html new file mode 100644 index 0000000..b4accbf --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/main.html @@ -0,0 +1,10 @@ + + +<!--#echo var="TITLE"--> + + + +" noresize scrolling="no"> +"> + + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/nav_print.html b/official/4.8.11/Demos/ClientServer/Server/templates/nav_print.html new file mode 100644 index 0000000..b530378 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/nav_print.html @@ -0,0 +1,5 @@ + + \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/navigator.html b/official/4.8.11/Demos/ClientServer/Server/templates/navigator.html new file mode 100644 index 0000000..c89588c --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/navigator.html @@ -0,0 +1,42 @@ + + + + + + +
+ + + + + + + + + + + + + + + +
  :  
diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/outline.html b/official/4.8.11/Demos/ClientServer/Server/templates/outline.html new file mode 100644 index 0000000..ef9648b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/outline.html @@ -0,0 +1 @@ +// under construction \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/print.html b/official/4.8.11/Demos/ClientServer/Server/templates/print.html new file mode 100644 index 0000000..a20bb5d --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/print.html @@ -0,0 +1,67 @@ + + + + +Print dialog + + + + + + +
+
+ "> + "> + + + + + + + + + + + + + + + + + + + + + + +
+ Print +
+   +
+   + +

Printer name  

+

Pages (enter page numbers and/or page ranges, example: 1,3,5-7)   +

+

Number of copies  

+

Collate pages  

+

Reverse order  

+ 		+   +
+   +
+
+        + +
+   +
+
+
+ + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/progress.html b/official/4.8.11/Demos/ClientServer/Server/templates/progress.html new file mode 100644 index 0000000..6a098d4 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/progress.html @@ -0,0 +1,54 @@ + + + +Report in progress + + + + + + +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + +
+ Progress +
+   +
+   +
+   +
+ +
+   +
+
+
+ + diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/readme.txt b/official/4.8.11/Demos/ClientServer/Server/templates/readme.txt new file mode 100644 index 0000000..cb63461 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/readme.txt @@ -0,0 +1,23 @@ +error403.html - error 403 template +error404.html - error 404 template +error500.html - error 500 template +form_begin.html - form begin +form_button.html - form button +form_checkbox.html - form checkbox +form_date.html - form date editor +form_end.html - form end +form_label.html - form label +form_memo.html - form memo +form_radio.html - form radio button +form_select.html - form select +form_text.html - form text memo +list_begin.html - reports list begin +list_end.html - reports list end +list_header.html - reports list header +list_line.html - reports list line +main.html - main report file +nav_pront.html - print button in report navigator +navigator.html - report navigator +outline.html - report outline (not implemented) +print.html - printer dialog +report.html - report frame (not implemented) diff --git a/official/4.8.11/Demos/ClientServer/Server/templates/report.html b/official/4.8.11/Demos/ClientServer/Server/templates/report.html new file mode 100644 index 0000000..ef9648b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/templates/report.html @@ -0,0 +1 @@ +// under construction \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Server/users.xml b/official/4.8.11/Demos/ClientServer/Server/users.xml new file mode 100644 index 0000000..91bd552 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Server/users.xml @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Service/allow.conf b/official/4.8.11/Demos/ClientServer/Service/allow.conf new file mode 100644 index 0000000..e69de29 diff --git a/official/4.8.11/Demos/ClientServer/Service/config.xml b/official/4.8.11/Demos/ClientServer/Service/config.xml new file mode 100644 index 0000000..1ba535b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/config.xml @@ -0,0 +1,157 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/ClientServer/Service/deny.conf b/official/4.8.11/Demos/ClientServer/Service/deny.conf new file mode 100644 index 0000000..e69de29 diff --git a/official/4.8.11/Demos/ClientServer/Service/frxserv.dpr b/official/4.8.11/Demos/ClientServer/Service/frxserv.dpr new file mode 100644 index 0000000..3acb388 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/frxserv.dpr @@ -0,0 +1,13 @@ +program frxserv; + +uses + SvcMgr, + main in 'main.pas' {FastReport: TService}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TFastReport, FastReport); + Application.Run; +end. diff --git a/official/4.8.11/Demos/ClientServer/Service/frxserv.res b/official/4.8.11/Demos/ClientServer/Service/frxserv.res new file mode 100644 index 0000000..06b79d7 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Service/frxserv.res differ diff --git a/official/4.8.11/Demos/ClientServer/Service/install.bat b/official/4.8.11/Demos/ClientServer/Service/install.bat new file mode 100644 index 0000000..a48b678 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/install.bat @@ -0,0 +1 @@ +frxserv.exe /install \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Service/main.dfm b/official/4.8.11/Demos/ClientServer/Service/main.dfm new file mode 100644 index 0000000..c737699 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Service/main.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/Service/main.pas b/official/4.8.11/Demos/ClientServer/Service/main.pas new file mode 100644 index 0000000..9f6461b --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/main.pas @@ -0,0 +1,138 @@ +unit main; + +{$I frx.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, + frxServer, DB, ADODB, frxClass, frxADOComponents, frxDBSet, frxGZip, + frxDCtrl, frxDMPExport, frxGradient, frxChBox, frxCross, frxRich, + frxChart, frxBarcode, frxServerUtils, ActiveX, Registry, IniFiles, frxUtils, + frxServerConfig; + +type + TFastReport = class(TService) + ADOConnection: TADOConnection; + Serv: TfrxReportServer; + frxBarCodeObject1: TfrxBarCodeObject; + frxChartObject1: TfrxChartObject; + frxRichObject1: TfrxRichObject; + frxCrossObject1: TfrxCrossObject; + frxCheckBoxObject1: TfrxCheckBoxObject; + frxGradientObject1: TfrxGradientObject; + frxDotMatrixExport1: TfrxDotMatrixExport; + frxDialogControls1: TfrxDialogControls; + frxGZipCompressor1: TfrxGZipCompressor; + frxADOComponents1: TfrxADOComponents; + procedure ServiceStop(Sender: TService; var Stopped: Boolean); + procedure ServiceStart(Sender: TService; var Started: Boolean); + procedure ServicePause(Sender: TService; var Paused: Boolean); + procedure ServiceExecute(Sender: TService); + procedure ServiceContinue(Sender: TService; var Continued: Boolean); + procedure ServiceAfterInstall(Sender: TService); + private + { Private declarations } + public + function GetServiceController: TServiceController; override; + { Public declarations } + end; + +var + FastReport: TFastReport; + dbMd: String; + +implementation + +uses ComObj; + +{$R *.DFM} + +var + DBConnStr: String = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='; + + +procedure ServiceController(CtrlCode: DWord); stdcall; +begin + FastReport.Controller(CtrlCode); +end; + +function TFastReport.GetServiceController: TServiceController; +begin + Result := ServiceController; +end; + +procedure TFastReport.ServiceStart(Sender: TService; var Started: Boolean); +begin + ADOConnection.ConnectionString := DBConnStr + frxGetAbsPath(ServerConfig.GetValue('server.database.pathtodatabase')); + CoInitialize(nil); + try + ADOConnection.Open; + except + LogMessage('Database connection error'); + end; + + if ADOConnection.Connected then + begin + Serv.Open; + end else + LogMessage('Database not connected'); + Started := True; +end; + +procedure TFastReport.ServiceStop(Sender: TService; var Stopped: Boolean); +begin + if ADOConnection.Connected then + ADOConnection.Close; + Serv.Close; + Stopped := True; +end; + +procedure TFastReport.ServicePause(Sender: TService; var Paused: Boolean); +begin + Serv.Close; + Paused := True; +end; + +procedure TFastReport.ServiceExecute(Sender: TService); +begin + while not Terminated do + begin + ServiceThread.ProcessRequests(True); + Sleep(100); + end; +end; + +procedure TFastReport.ServiceContinue(Sender: TService; var Continued: Boolean); +begin + Serv.Open; + Continued := True; +end; + +procedure TFastReport.ServiceAfterInstall(Sender: TService); +var + Registry: TRegistry; + key: String; +begin + Registry := TRegistry.Create; + try +{$IFNDEF Delphi4} + Registry.Access := KEY_READ; +{$ENDIF} + Registry.RootKey := HKEY_LOCAL_MACHINE; + key := 'System\CurrentControlSet\Services\' + Name; + if Registry.KeyExists(key) then + begin +{$IFNDEF Delphi4} + Registry.Access := KEY_WRITE; +{$ENDIF} + Registry.OpenKey(key, True); + Registry.WriteString('Description', 'FastReport Server service. http://www.fast-report.com'); + Registry.CloseKey; + end; + finally + Registry.Free; + end; +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/Service/service.txt b/official/4.8.11/Demos/ClientServer/Service/service.txt new file mode 100644 index 0000000..23cab08 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/service.txt @@ -0,0 +1,8 @@ +FastReport Server NT service demo. + +Install: frxserv.exe /install +Uninstall: frxserv.exe /uninstall + +Star service: net start fastreport +Stop service: net stop fastreport + diff --git a/official/4.8.11/Demos/ClientServer/Service/servmain.dfm b/official/4.8.11/Demos/ClientServer/Service/servmain.dfm new file mode 100644 index 0000000..00d631a Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/Service/servmain.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/Service/servmain.pas b/official/4.8.11/Demos/ClientServer/Service/servmain.pas new file mode 100644 index 0000000..0f0be51 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/servmain.pas @@ -0,0 +1,176 @@ +unit servmain; + +{$I frx.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, + frxServer, DB, ADODB, frxClass, frxADOComponents, frxDBSet, frxGZip, + frxDCtrl, frxDMPExport, frxGradient, frxChBox, frxCross, frxRich, + frxChart, frxBarcode, frxServerUtils, ActiveX, Registry, IniFiles, frxUtils, + frxUsers, frxConfig; + +type + TFastReport = class(TService) + ADOConnection: TADOConnection; + Serv: TfrxReportServer; + frxBarCodeObject1: TfrxBarCodeObject; + frxChartObject1: TfrxChartObject; + frxRichObject1: TfrxRichObject; + frxCrossObject1: TfrxCrossObject; + frxCheckBoxObject1: TfrxCheckBoxObject; + frxGradientObject1: TfrxGradientObject; + frxDotMatrixExport1: TfrxDotMatrixExport; + frxDialogControls1: TfrxDialogControls; + frxGZipCompressor1: TfrxGZipCompressor; + frxADOComponents1: TfrxADOComponents; + procedure ServiceStop(Sender: TService; var Stopped: Boolean); + procedure ServiceStart(Sender: TService; var Started: Boolean); + procedure ServicePause(Sender: TService; var Paused: Boolean); + procedure ServiceExecute(Sender: TService); + procedure ServiceContinue(Sender: TService; var Continued: Boolean); + procedure ServiceAfterInstall(Sender: TService); + private + { Private declarations } + AppPath: String; + ConfFile: String; + AllowFile: String; + DenyFile: String; + public + function GetServiceController: TServiceController; override; + { Public declarations } + end; + +const + CONFIG_FILE = 'config.xml'; +// ALLOW_FILE = 'allow.conf'; +// DENY_FILE = 'deny.conf'; + +var + FastReport: TFastReport; + dbMd: String; + +implementation + +uses ComObj; + +{$R *.DFM} + +var + DATABASE_FILE: String; + DBConnStr: String = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='; + + +procedure ServiceController(CtrlCode: DWord); stdcall; +begin + FastReport.Controller(CtrlCode); +end; + +function TFastReport.GetServiceController: TServiceController; +begin + Result := ServiceController; +end; + +procedure TFastReport.ServiceStart(Sender: TService; var Started: Boolean); +var + ini: TIniFile; +begin + AppPath := GetAppPath; + ConfFile := AppPath + CONFIG_FILE; +// AllowFile := AppPath + ALLOW_FILE; +// DenyFile := AppPath + DENY_FILE; + +// ini := TIniFile.Create(ConfFile); +// try + DATABASE_FILE := AppPath + 'database\server.mdb'; //AppPath + ini.ReadString('Database', 'Connection', 'database\server.mdb'); +// finally +// ini.Free; +// end; + + ADOConnection.ConnectionString := DBConnStr + DATABASE_FILE; + CoInitialize(nil); + try + ADOConnection.Open; + except + LogMessage('Database connection error'); + end; + + if ADOConnection.Connected then + begin + if FileExists(ConfFile) then + Serv.Configuration.LoadFromFile(ConfFile); +///!!!! + ServerUsers.LoadFromFile(AppPath + ServerConfig.GetValue('server.security.usersfile')); + if FileExists(AllowFile) then + begin + Serv.AllowIP.Clear; + Serv.AllowIP.LoadFromFile(AllowFile); + end; + if FileExists(DenyFile) then + begin + Serv.DenyIP.Clear; + Serv.DenyIP.LoadFromFile(DenyFile); + end; + Serv.Open; + end else + LogMessage('Database not connected'); + Started := True; +end; + +procedure TFastReport.ServiceStop(Sender: TService; var Stopped: Boolean); +begin + if ADOConnection.Connected then + ADOConnection.Close; + Serv.Close; + Stopped := True; +end; + +procedure TFastReport.ServicePause(Sender: TService; var Paused: Boolean); +begin + Serv.Close; + Paused := True; +end; + +procedure TFastReport.ServiceExecute(Sender: TService); +begin + while not Terminated do + begin + ServiceThread.ProcessRequests(True); + Sleep(100); + end; +end; + +procedure TFastReport.ServiceContinue(Sender: TService; var Continued: Boolean); +begin + Serv.Open; + Continued := True; +end; + +procedure TFastReport.ServiceAfterInstall(Sender: TService); +var + Registry: TRegistry; + key: String; +begin + Registry := TRegistry.Create; + try +{$IFNDEF Delphi4} + Registry.Access := KEY_READ; +{$ENDIF} + Registry.RootKey := HKEY_LOCAL_MACHINE; + key := 'System\CurrentControlSet\Services\' + Name; + if Registry.KeyExists(key) then + begin +{$IFNDEF Delphi4} + Registry.Access := KEY_WRITE; +{$ENDIF} + Registry.OpenKey(key, True); + Registry.WriteString('Description', 'FastReport Server service. http://www.fast-report.com'); + Registry.CloseKey; + end; + finally + Registry.Free; + end; +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/Service/start.bat b/official/4.8.11/Demos/ClientServer/Service/start.bat new file mode 100644 index 0000000..4690300 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/start.bat @@ -0,0 +1 @@ +net start fastreport \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Service/stop.bat b/official/4.8.11/Demos/ClientServer/Service/stop.bat new file mode 100644 index 0000000..dce9889 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/stop.bat @@ -0,0 +1 @@ +net stop fastreport \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/Service/uninstall.bat b/official/4.8.11/Demos/ClientServer/Service/uninstall.bat new file mode 100644 index 0000000..e35b3be --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/Service/uninstall.bat @@ -0,0 +1 @@ +frxserv.exe /uninstall \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.dfm b/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.dfm new file mode 100644 index 0000000..1bfcfa0 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.pas b/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.pas new file mode 100644 index 0000000..0830857 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/GroupEditor.pas @@ -0,0 +1,46 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport User/Group editor demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit GroupEditor; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TGroupEditorForm = class(TForm) + Panel1: TPanel; + UserEditForm: TButton; + Button2: TButton; + Panel2: TPanel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + EFullName: TEdit; + ELogin: TEdit; + CBActive: TCheckBox; + EIndex: TEdit; + private + { Private declarations } + public + { Public declarations } + end; + +var + GroupEditorForm: TGroupEditorForm; + +implementation + +{$R *.dfm} + +end. diff --git a/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.dfm b/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.dfm new file mode 100644 index 0000000..35ac53e Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.pas b/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.pas new file mode 100644 index 0000000..5b23e7a --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/UserEditor.pas @@ -0,0 +1,109 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport User/Group editor demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit UserEditor; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TEditUserForm = class(TForm) + Panel1: TPanel; + UserEditForm: TButton; + Button2: TButton; + Panel2: TPanel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label5: TLabel; + Label7: TLabel; + EFullName: TEdit; + CBActive: TCheckBox; + ELogin: TEdit; + EPassword: TEdit; + EEmail: TEdit; + MemberBox: TListBox; + AvailBox: TListBox; + LeftBtn: TButton; + RightBtn: TButton; + procedure MemberBoxDragOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); + procedure AvailBoxDragOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); + procedure MemberBoxDragDrop(Sender, Source: TObject; X, Y: Integer); + procedure LeftBtnClick(Sender: TObject); + procedure RightBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + EditUserForm: TEditUserForm; + +implementation + +{$R *.dfm} + +procedure TEditUserForm.MemberBoxDragOver(Sender, Source: TObject; X, + Y: Integer; State: TDragState; var Accept: Boolean); +begin + Accept := Source = AvailBox; +end; + +procedure TEditUserForm.AvailBoxDragOver(Sender, Source: TObject; X, + Y: Integer; State: TDragState; var Accept: Boolean); +begin + Accept := Source = MemberBox; +end; + +procedure TEditUserForm.MemberBoxDragDrop(Sender, Source: TObject; X, + Y: Integer); +var + s: String; + i: Integer; +begin + i := (Source as TListBox).ItemIndex; + s := (Source as TListBox).Items[i]; + (Sender as TListBox).Items.Add(s); + (Source as TListBox).Items.Delete(i); +end; + +procedure TEditUserForm.LeftBtnClick(Sender: TObject); +var + i: Integer; +begin + i := AvailBox.ItemIndex; + if i <> -1 then + begin + MemberBox.Items.Add(AvailBox.Items[i]); + AvailBox.Items.Delete(i); + end; +end; + +procedure TEditUserForm.RightBtnClick(Sender: TObject); +var + i: Integer; +begin + i := AvailBox.ItemIndex; + if i <> -1 then + begin + MemberBox.Items.Add(AvailBox.Items[i]); + AvailBox.Items.Delete(i); + end; +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.dpr b/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.dpr new file mode 100644 index 0000000..0543896 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.dpr @@ -0,0 +1,26 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport User/Group editor demo } +{ Copyright (c) 1998-2006 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +program frxUserManager; + +uses + Forms, + main in 'main.pas' {MainForm}, + UserEditor in 'UserEditor.pas' {EditUserForm}, + GroupEditor in 'GroupEditor.pas' {GroupEditorForm}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.res b/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.res new file mode 100644 index 0000000..062079f Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/UserManager/frxUserManager.res differ diff --git a/official/4.8.11/Demos/ClientServer/UserManager/main.dfm b/official/4.8.11/Demos/ClientServer/UserManager/main.dfm new file mode 100644 index 0000000..a82e5f1 Binary files /dev/null and b/official/4.8.11/Demos/ClientServer/UserManager/main.dfm differ diff --git a/official/4.8.11/Demos/ClientServer/UserManager/main.pas b/official/4.8.11/Demos/ClientServer/UserManager/main.pas new file mode 100644 index 0000000..832f102 --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/main.pas @@ -0,0 +1,314 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FastReport User/Group editor demo } +{ Copyright (c) 1998-2007 } +{ by Alexander Fediachov, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit main; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ComCtrls, ExtCtrls, frxUsers; + + +type + TMainForm = class(TForm) + Panel1: TPanel; + NewBtn: TButton; + EditBtn: TButton; + DeleteBtn: TButton; + Panel3: TPanel; + PageControl: TPageControl; + UserTab: TTabSheet; + UserList: TListView; + Panel2: TPanel; + Label1: TLabel; + CBox_Group: TComboBox; + GroupTab: TTabSheet; + GroupList: TListView; + procedure FormDestroy(Sender: TObject); + procedure CBox_GroupChange(Sender: TObject); + procedure EditBtnClick(Sender: TObject); + procedure NewBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + ServerUsers: TfrxUsers; + procedure Clear; + procedure LoadLists; + procedure LoadUserList(const Group: String); + procedure LoadGroupList; + procedure SaveUsers; + end; + +var + MainForm: TMainForm; + +implementation + +uses Math, frxServerConfig, UserEditor, GroupEditor +{$IFDEF Delphi7} +, XPMan +{$ENDIF}; + +{$R *.dfm} + +procedure TMainForm.Clear; +begin + UserList.Items.Clear; + GroupList.Items.Clear; + CBox_Group.Clear; +end; + +procedure TMainForm.LoadGroupList; +var + i: Integer; + ListItem: TListItem; + s: String; +begin + GroupList.Items.BeginUpdate; + GroupList.Items.Clear; + for i := 0 to ServerUsers.GroupList.Count - 1 do + begin + ListItem := GroupList.Items.Add; + ListItem.Caption := ServerUsers.GroupList[i]; + ListItem.Data := ServerUsers.GroupList.Objects[i]; + ListItem.SubItems.Add(TfrxUserGroupItem(ServerUsers.GroupList.Objects[i]).FullName); + end; + GroupList.Items.EndUpdate; + s := CBox_Group.Text; + CBox_Group.Clear; + CBox_Group.Items.AddObject('All groups', nil); + for i := 0 to ServerUsers.GroupList.Count - 1 do + CBox_Group.Items.AddObject(ServerUsers.GroupList[i], ServerUsers.GroupList.Objects[i]); + if CBox_Group.Items.Count > 0 then + begin + i := CBox_Group.Items.IndexOf(s); + if i = -1 then + CBox_Group.ItemIndex := 0 + else + CBox_Group.ItemIndex := i; + end; +end; + +procedure TMainForm.LoadLists; +begin + LoadUserList(CBox_Group.Text); + LoadGroupList; +end; + +procedure TMainForm.LoadUserList(const Group: String); +var + i, j: Integer; + s: String; + ListItem: TListItem; +begin + UserList.Items.BeginUpdate; + UserList.Items.Clear; + for i := 0 to ServerUsers.UserList.Count - 1 do + begin + if (Group = 'All groups') or ServerUsers.MemberOfGroup(ServerUsers.UserList[i], Group) then + begin + ListItem := UserList.Items.Add; + ListItem.Caption := ServerUsers.UserList[i]; + ListItem.Data := ServerUsers.UserList.Objects[i]; + ListItem.SubItems.Add(TfrxUserGroupItem(ServerUsers.UserList.Objects[i]).FullName); + s := ''; + for j := 0 to TfrxUserGroupItem(ServerUsers.UserList.Objects[i]).Members.Count - 1 do + s := s + TfrxUserGroupItem(ServerUsers.UserList.Objects[i]).Members[j] + ','; + if (Length(s) > 0) and (s[Length(s)] = ',') then + SetLength(s, Length(s) - 1); + ListItem.SubItems.Add(s); + end; + end; + UserList.Items.EndUpdate; +end; + +procedure TMainForm.SaveUsers; +begin + ServerUsers.SaveToFile('users.xml'); +end; + +procedure TMainForm.FormDestroy(Sender: TObject); +begin + Clear; + ServerUsers.Free; +end; + +procedure TMainForm.CBox_GroupChange(Sender: TObject); +begin + LoadUserList(CBox_Group.Text); +end; + +procedure TMainForm.EditBtnClick(Sender: TObject); +var + Item: TfrxUserGroupItem; + i: Integer; + FakePass: String; +begin + if (PageControl.ActivePage = UserTab) and (UserList.Items.Count > 0) + and (UserList.Selected <> nil) then + begin + EditUserForm := TEditUserForm.Create(Self); + try + Item := TfrxUserGroupItem(UserList.Selected.Data); + EditUserForm.ELogin.Text := Item.Name; + EditUserForm.ELogin.Enabled := False; + EditUserForm.EFullName.Text := Item.FullName; + EditUserForm.EEmail.Text := Item.Email; + EditUserForm.CBActive.Checked := Item.Active; + FakePass := '---------'; + EditUserForm.EPassword.Text := FakePass; + for i := 0 to Item.Members.Count - 1 do + EditUserForm.MemberBox.Items.Add(Item.Members[i]); + for i := 0 to ServerUsers.GroupList.Count - 1 do + if Item.Members.IndexOf(ServerUsers.GroupList[i]) = -1 then + EditUserForm.AvailBox.Items.Add(ServerUsers.GroupList[i]); + if EditUserForm.ShowModal = mrOk then + begin + if EditUserForm.EPassword.Text <> FakePass then + ServerUsers.ChPasswd(Item.Name, EditUserForm.EPassword.Text); + Item.Active := EditUserForm.CBActive.Checked; + Item.FullName := EditUserForm.EFullName.Text; + Item.Email := EditUserForm.EEmail.Text; + + for i := 0 to EditUserForm.AvailBox.Items.Count - 1 do + begin + ServerUsers.RemoveGroupFromUser(EditUserForm.AvailBox.Items[i], Item.Name); + ServerUsers.RemoveUserFromGroup(Item.Name, EditUserForm.AvailBox.Items[i]); + end; + for i := 0 to EditUserForm.MemberBox.Items.Count - 1 do + ServerUsers.AddUserToGroup(Item.Name, EditUserForm.MemberBox.Items[i]); + SaveUsers; + LoadLists; + end; + finally + EditUserForm.Free; + end; + end else + if (PageControl.ActivePage = GroupTab) and (GroupList.Items.Count > 0) + and (GroupList.Selected <> nil) then + begin + GroupEditorForm := TGroupEditorForm.Create(Self); + try + Item := TfrxUserGroupItem(GroupList.Selected.Data); + GroupEditorForm.ELogin.Text := Item.Name; + GroupEditorForm.ELogin.Enabled := False; + GroupEditorForm.EFullName.Text := Item.FullName; + GroupEditorForm.CBActive.Checked := Item.Active; + GroupEditorForm.EIndex.Text := Item.IndexFile; + if GroupEditorForm.ShowModal = mrOk then + begin + Item.Active := GroupEditorForm.CBActive.Checked; + Item.FullName := GroupEditorForm.EFullName.Text; + Item.IndexFile := GroupEditorForm.EIndex.Text; + SaveUsers; + LoadLists; + end; + finally + GroupEditorForm.Free; + end; + end; +end; + +procedure TMainForm.NewBtnClick(Sender: TObject); +var + Item: TfrxUserGroupItem; + i: Integer; +begin + if (PageControl.ActivePage = UserTab) then + begin + EditUserForm := TEditUserForm.Create(Self); + try + for i := 0 to ServerUsers.GroupList.Count - 1 do + EditUserForm.AvailBox.Items.Add(ServerUsers.GroupList[i]); + if EditUserForm.ShowModal = mrOk then + begin + Item := ServerUsers.AddUser(EditUserForm.ELogin.Text); + if Item <> nil then + begin + ServerUsers.ChPasswd(Item.Name, EditUserForm.EPassword.Text); + Item.Active := EditUserForm.CBActive.Checked; + Item.FullName := EditUserForm.EFullName.Text; + Item.Email := EditUserForm.EEmail.Text; + for i := 0 to EditUserForm.MemberBox.Items.Count - 1 do + ServerUsers.AddUserToGroup(Item.Name, EditUserForm.MemberBox.Items[i]); + SaveUsers; + LoadLists; + end else + MessageDlg('User name already exists!', mtError, [mbOk], 0); + end; + finally + EditUserForm.Free; + end; + end else + if PageControl.ActivePage = GroupTab then + begin + GroupEditorForm := TGroupEditorForm.Create(Self); + try + if GroupEditorForm.ShowModal = mrOk then + begin + Item := ServerUsers.AddGroup(GroupEditorForm.ELogin.Text); + if Item <> nil then + begin + Item.Active := GroupEditorForm.CBActive.Checked; + Item.FullName := GroupEditorForm.EFullName.Text; + SaveUsers; + LoadLists; + end else + MessageDlg('Group name already exists!', mtError, [mbOk], 0); + end; + finally + GroupEditorForm.Free; + end; + end; +end; + +procedure TMainForm.DeleteBtnClick(Sender: TObject); +var + s: String; +begin + if (PageControl.ActivePage = UserTab) and (UserList.Items.Count > 0) + and (UserList.Selected <> nil) then + begin + s := TfrxUserGroupItem(UserList.Selected.Data).Name; + if MessageDlg('Delete user "' + s + '"?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then + begin + ServerUsers.DeleteUser(s); + SaveUsers; + LoadLists; + end; + end else + if (PageControl.ActivePage = GroupTab) and (GroupList.Items.Count > 0) + and (GroupList.Selected <> nil) then + begin + s := TfrxUserGroupItem(GroupList.Selected.Data).Name; + if MessageDlg('Delete group "' + s + '"?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then + begin + ServerUsers.DeleteGroup(s); + SaveUsers; + LoadLists; + end; + end; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + ServerUsers := TfrxUsers.Create; + ServerUsers.LoadFromFile('users.xml'); + LoadLists; +end; + +end. diff --git a/official/4.8.11/Demos/ClientServer/UserManager/readme.txt b/official/4.8.11/Demos/ClientServer/UserManager/readme.txt new file mode 100644 index 0000000..5bb481d --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/readme.txt @@ -0,0 +1 @@ +Please copy compiled application in Server folder for access to user.xml file. \ No newline at end of file diff --git a/official/4.8.11/Demos/ClientServer/UserManager/users.xml b/official/4.8.11/Demos/ClientServer/UserManager/users.xml new file mode 100644 index 0000000..413d8ca --- /dev/null +++ b/official/4.8.11/Demos/ClientServer/UserManager/users.xml @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Dll/CALLDLL.DPR b/official/4.8.11/Demos/Dll/CALLDLL.DPR new file mode 100644 index 0000000..9531170 --- /dev/null +++ b/official/4.8.11/Demos/Dll/CALLDLL.DPR @@ -0,0 +1,13 @@ +program CallDLL; + +uses + Forms, + TestDLL in 'TestDLL.pas' {frmCallDLL}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TfrmCallDLL, frmCallDLL); + Application.Run; +end. diff --git a/official/4.8.11/Demos/Dll/CALLDLL.RES b/official/4.8.11/Demos/Dll/CALLDLL.RES new file mode 100644 index 0000000..f1bda73 Binary files /dev/null and b/official/4.8.11/Demos/Dll/CALLDLL.RES differ diff --git a/official/4.8.11/Demos/Dll/FormDLL.dfm b/official/4.8.11/Demos/Dll/FormDLL.dfm new file mode 100644 index 0000000..5c2b2ed Binary files /dev/null and b/official/4.8.11/Demos/Dll/FormDLL.dfm differ diff --git a/official/4.8.11/Demos/Dll/FormDLL.pas b/official/4.8.11/Demos/Dll/FormDLL.pas new file mode 100644 index 0000000..6187279 --- /dev/null +++ b/official/4.8.11/Demos/Dll/FormDLL.pas @@ -0,0 +1,62 @@ +unit FormDLL; + +interface + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, + Forms, Dialogs, StdCtrls, DBTables, DB, frxDBSet, frxClass; + +type + TfrmDLL = class(TForm) + btnBioLifePrintPreview: TButton; + Table1: TTable; + frxDBDataset1: TfrxDBDataset; + frxReport1: TfrxReport; + procedure btnBioLifePrintPreviewClick(Sender: TObject); + procedure FormActivate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + { Private declarations } + public + { Public declarations } + end; + + +function ShowForm(A: TApplication): Bool; StdCall; + + +implementation + +{$R *.DFM} + +{------------------------------------------------------------------------} + +function ShowForm(A: TApplication): Bool; +var + Form1: TfrmDLL; +begin + Application.Handle := A.Handle; + Form1 := TfrmDLL.Create(A); + try + Result := (Form1.ShowModal = mrOK); + finally + Form1.Free; + end; +end; + +procedure TfrmDLL.btnBioLifePrintPreviewClick(Sender: TObject); +begin + frxReport1.ShowReport; +end; + +procedure TfrmDLL.FormActivate(Sender: TObject); +begin + Session.Active := True; +end; + +procedure TfrmDLL.FormClose(Sender: TObject; var Action: TCloseAction); +begin + Session.Active := False; +end; + +end. diff --git a/official/4.8.11/Demos/Dll/RPTDLL.RES b/official/4.8.11/Demos/Dll/RPTDLL.RES new file mode 100644 index 0000000..f1bda73 Binary files /dev/null and b/official/4.8.11/Demos/Dll/RPTDLL.RES differ diff --git a/official/4.8.11/Demos/Dll/Rptdll.dpr b/official/4.8.11/Demos/Dll/Rptdll.dpr new file mode 100644 index 0000000..e037fd5 --- /dev/null +++ b/official/4.8.11/Demos/Dll/Rptdll.dpr @@ -0,0 +1,11 @@ +library RptDLL; + +uses + Forms, + FormDLL in 'FormDLL.pas' {frmDLL}; + +exports + ShowForm; + +begin +end. diff --git a/official/4.8.11/Demos/Dll/TestDLL.dfm b/official/4.8.11/Demos/Dll/TestDLL.dfm new file mode 100644 index 0000000..58b89b8 Binary files /dev/null and b/official/4.8.11/Demos/Dll/TestDLL.dfm differ diff --git a/official/4.8.11/Demos/Dll/TestDLL.pas b/official/4.8.11/Demos/Dll/TestDLL.pas new file mode 100644 index 0000000..88343aa --- /dev/null +++ b/official/4.8.11/Demos/Dll/TestDLL.pas @@ -0,0 +1,53 @@ +unit TestDLL; + +interface + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, + Forms, Dialogs, StdCtrls, DB, ExtCtrls, DBTables; + +type + TShowForm = function(A: TApplication): Bool; StdCall; + + EDLLLoadError = class(Exception); + + TfrmCallDLL = class(TForm) + Database1: TDatabase; + btnCallDLL: TButton; + btnClose: TButton; + procedure btnCallDLLClick(Sender: TObject); + procedure btnCloseClick(Sender: TObject); + end; + +var + frmCallDLL: TfrmCallDLL; + +implementation + + +{$R *.DFM} + +procedure TfrmCallDLL.btnCallDLLClick(Sender: TObject); +var + LibHandle: THandle; + ShowForm: TShowForm; +begin + LibHandle := LoadLibrary('RptDLL.DLL'); + try + if LibHandle = HINSTANCE_ERROR then + raise EDLLLoadError.Create('Unable to Load DLL'); + @ShowForm := GetProcAddress(LibHandle, 'ShowForm'); + if not (@ShowForm = nil) then + ShowForm(Application); + finally + FreeLibrary(LibHandle); + end; +end; + +procedure TfrmCallDLL.btnCloseClick(Sender: TObject); +begin + Close; +end; + + +end. diff --git a/official/4.8.11/Demos/EmbedDesigner/Project1.dpr b/official/4.8.11/Demos/EmbedDesigner/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/EmbedDesigner/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/EmbedDesigner/Project1.res b/official/4.8.11/Demos/EmbedDesigner/Project1.res new file mode 100644 index 0000000..08ba56e Binary files /dev/null and b/official/4.8.11/Demos/EmbedDesigner/Project1.res differ diff --git a/official/4.8.11/Demos/EmbedDesigner/Unit1.dfm b/official/4.8.11/Demos/EmbedDesigner/Unit1.dfm new file mode 100644 index 0000000..026ceca Binary files /dev/null and b/official/4.8.11/Demos/EmbedDesigner/Unit1.dfm differ diff --git a/official/4.8.11/Demos/EmbedDesigner/Unit1.pas b/official/4.8.11/Demos/EmbedDesigner/Unit1.pas new file mode 100644 index 0000000..5a1360d --- /dev/null +++ b/official/4.8.11/Demos/EmbedDesigner/Unit1.pas @@ -0,0 +1,178 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxDesgn, frxClass, frxPreview, ComCtrls, Menus; + +type + TForm1 = class(TForm) + PageControl1: TPageControl; + DesignerSheet: TTabSheet; + PreviewSheet: TTabSheet; + frxPreview1: TfrxPreview; + frxReport1: TfrxReport; + frxDesigner1: TfrxDesigner; + MainMenu1: TMainMenu; + File1: TMenuItem; + NewMI: TMenuItem; + OpenMI: TMenuItem; + SaveMI: TMenuItem; + SaveasMI: TMenuItem; + N1: TMenuItem; + PreviewMI: TMenuItem; + PagesettingsMI: TMenuItem; + N2: TMenuItem; + ExitMI: TMenuItem; + Edit1: TMenuItem; + UndoMI: TMenuItem; + RedoMI: TMenuItem; + N3: TMenuItem; + CutMI: TMenuItem; + CopyMI: TMenuItem; + PasteMI: TMenuItem; + N4: TMenuItem; + DeleteMI: TMenuItem; + DeletePageMI: TMenuItem; + SelectAllMI: TMenuItem; + GroupMI: TMenuItem; + UngroupMI: TMenuItem; + EditMI: TMenuItem; + N5: TMenuItem; + BringtoFrontMI: TMenuItem; + SendtoBackMI: TMenuItem; + N6: TMenuItem; + FindMI: TMenuItem; + ReplaceMI: TMenuItem; + FindNextMI: TMenuItem; + Report1: TMenuItem; + DataMI: TMenuItem; + VariablesMI: TMenuItem; + StylesMI: TMenuItem; + ReportOptionsMI: TMenuItem; + View1: TMenuItem; + ToolbarsMI: TMenuItem; + N7: TMenuItem; + RulersMI: TMenuItem; + GuidesMI: TMenuItem; + DeleteGuidesMI: TMenuItem; + N8: TMenuItem; + OptionsMI: TMenuItem; + StandardMI: TMenuItem; + TextMI: TMenuItem; + FrameMI: TMenuItem; + AlignmentPaletteMI: TMenuItem; + ObjectInspectorMI: TMenuItem; + DataTreeMI: TMenuItem; + ReportTreeMI: TMenuItem; + Help1: TMenuItem; + HelpContentsMI: TMenuItem; + AboutFastReportMI: TMenuItem; + N9: TMenuItem; + NewReportMI: TMenuItem; + NewPageMI: TMenuItem; + NewDialogMI: TMenuItem; + procedure FormShow(Sender: TObject); + procedure PageControl1Change(Sender: TObject); + procedure ExitMIClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +uses frxRes; + +procedure TForm1.FormShow(Sender: TObject); +var + Designer: TfrxDesignerForm; +begin + // prevent saving/restoring a report when previewing. This will destroy + // objects that are loaded in the designer and will lead to AV. + frxReport1.EngineOptions.DestroyForms := False; + // set the custom preview + frxReport1.Preview := frxPreview1; + // display the designer + frxReport1.DesignReportInPanel(DesignerSheet); + + // set FR images for our menu + MainMenu1.Images := frxResources.MainButtonImages; + // get the reference to the Designer + Designer := TfrxDesignerForm(frxReport1.Designer); + + // assign FR actions to our menu items + NewMI.Action := Designer.NewItemCmd; + NewReportMI.Action := Designer.NewReportCmd; + NewPageMI.Action := Designer.NewPageCmd; + NewDialogMI.Action := Designer.NewDialogCmd; + OpenMI.Action := Designer.OpenCmd; + SaveMI.Action := Designer.SaveCmd; + SaveasMI.Action := Designer.SaveAsCmd; + PreviewMI.Action := Designer.PreviewCmd; + PageSettingsMI.Action := Designer.PageSettingsCmd; + + UndoMI.Action := Designer.UndoCmd; + RedoMI.Action := Designer.RedoCmd; + CutMI.Action := Designer.CutCmd; + CopyMI.Action := Designer.CopyCmd; + PasteMI.Action := Designer.PasteCmd; + DeleteMI.Action := Designer.DeleteCmd; + DeletePageMI.Action := Designer.DeletePageCmd; + SelectAllMI.Action := Designer.SelectAllCmd; + GroupMI.Action := Designer.GroupCmd; + UngroupMI.Action := Designer.UngroupCmd; + EditMI.Action := Designer.EditCmd; + FindMI.Action := Designer.FindCmd; + ReplaceMI.Action := Designer.ReplaceCmd; + FindNextMI.Action := Designer.FindNextCmd; + BringtoFrontMI.Action := Designer.BringToFrontCmd; + SendtoBackMI.Action := Designer.SendToBackCmd; + + DataMI.Action := Designer.ReportDataCmd; + VariablesMI.Action := Designer.VariablesCmd; + StylesMI.Action := Designer.ReportStylesCmd; + ReportOptionsMI.Action := Designer.ReportOptionsCmd; + + ToolbarsMI.Action := Designer.ToolbarsCmd; + StandardMI.Action := Designer.StandardTBCmd; + TextMI.Action := Designer.TextTBCmd; + FrameMI.Action := Designer.FrameTBCmd; + AlignmentPaletteMI.Action := Designer.AlignTBCmd; + ObjectInspectorMI.Action := Designer.InspectorTBCmd; + DataTreeMI.Action := Designer.DataTreeTBCmd; + ReportTreeMI.Action := Designer.ReportTreeTBCmd; + RulersMI.Action := Designer.ShowRulersCmd; + GuidesMI.Action := Designer.ShowGuidesCmd; + DeleteGuidesMI.Action := Designer.DeleteGuidesCmd; + OptionsMI.Action := Designer.OptionsCmd; + + HelpContentsMI.Action := Designer.HelpContentsCmd; + AboutFastReportMI.Action := Designer.AboutCmd; +end; + +procedure TForm1.PageControl1Change(Sender: TObject); +begin + if PageControl1.ActivePage = PreviewSheet then + frxReport1.PrepareReport +end; + +procedure TForm1.ExitMIClick(Sender: TObject); +begin + Close; +end; + +procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); +begin + frxReport1.Designer.Close; +end; + +end. diff --git a/official/4.8.11/Demos/InteractiveReport/Project1.dpr b/official/4.8.11/Demos/InteractiveReport/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/InteractiveReport/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/InteractiveReport/Project1.res b/official/4.8.11/Demos/InteractiveReport/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/InteractiveReport/Project1.res differ diff --git a/official/4.8.11/Demos/InteractiveReport/Unit1.dfm b/official/4.8.11/Demos/InteractiveReport/Unit1.dfm new file mode 100644 index 0000000..e39e451 Binary files /dev/null and b/official/4.8.11/Demos/InteractiveReport/Unit1.dfm differ diff --git a/official/4.8.11/Demos/InteractiveReport/Unit1.pas b/official/4.8.11/Demos/InteractiveReport/Unit1.pas new file mode 100644 index 0000000..3f448b1 --- /dev/null +++ b/official/4.8.11/Demos/InteractiveReport/Unit1.pas @@ -0,0 +1,109 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls, frxDBSet, Db, DBTables; + +type + TForm1 = class(TForm) + Button1: TButton; + Customers: TTable; + CustomersCustNo: TFloatField; + CustomersCompany: TStringField; + CustomersAddr1: TStringField; + CustomersAddr2: TStringField; + CustomersCity: TStringField; + CustomersState: TStringField; + CustomersZip: TStringField; + CustomersCountry: TStringField; + CustomersPhone: TStringField; + CustomersFAX: TStringField; + CustomersTaxRate: TFloatField; + CustomersContact: TStringField; + CustomersLastInvoiceDate: TDateTimeField; + DetailQuery: TQuery; + DetailQueryCustNo: TFloatField; + DetailQueryCompany: TStringField; + DetailQueryAddr1: TStringField; + DetailQueryAddr2: TStringField; + DetailQueryCity: TStringField; + DetailQueryState: TStringField; + DetailQueryZip: TStringField; + DetailQueryCountry: TStringField; + DetailQueryPhone: TStringField; + DetailQueryFAX: TStringField; + DetailQueryTaxRate: TFloatField; + DetailQueryContact: TStringField; + DetailQueryLastInvoiceDate: TDateTimeField; + DetailQueryOrderNo: TFloatField; + DetailQueryCustNo_1: TFloatField; + DetailQuerySaleDate: TDateTimeField; + DetailQueryShipDate: TDateTimeField; + DetailQueryEmpNo: TIntegerField; + DetailQueryShipToContact: TStringField; + DetailQueryShipToAddr1: TStringField; + DetailQueryShipToAddr2: TStringField; + DetailQueryShipToCity: TStringField; + DetailQueryShipToState: TStringField; + DetailQueryShipToZip: TStringField; + DetailQueryShipToCountry: TStringField; + DetailQueryShipToPhone: TStringField; + DetailQueryShipVIA: TStringField; + DetailQueryPO: TStringField; + DetailQueryTerms: TStringField; + DetailQueryPaymentMethod: TStringField; + DetailQueryItemsTotal: TCurrencyField; + DetailQueryTaxRate_1: TFloatField; + DetailQueryFreight: TCurrencyField; + DetailQueryAmountPaid: TCurrencyField; + DetailQueryOrderNo_1: TFloatField; + DetailQueryItemNo: TFloatField; + DetailQueryPartNo: TFloatField; + DetailQueryQty: TIntegerField; + DetailQueryDiscount: TFloatField; + DetailQueryPartNo_1: TFloatField; + DetailQueryVendorNo: TFloatField; + DetailQueryDescription: TStringField; + DetailQueryOnHand: TFloatField; + DetailQueryOnOrder: TFloatField; + DetailQueryCost: TCurrencyField; + DetailQueryListPrice: TCurrencyField; + CustomersDS: TfrxDBDataset; + DetailQueryDS: TfrxDBDataset; + MainReport: TfrxReport; + DetailReport: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure MainReportClickObject(View: TfrxView; + Button: TMouseButton; Shift: TShiftState; var Modified: Boolean); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +procedure TForm1.Button1Click(Sender: TObject); +begin + MainReport.ShowReport; +end; + +procedure TForm1.MainReportClickObject(View: TfrxView; + Button: TMouseButton; Shift: TShiftState; var Modified: Boolean); +begin + if View.Name = 'Memo8' then + begin + DetailQuery.Close; + DetailQuery.ParamByName('custno').Text := View.TagStr; + DetailReport.ShowReport; + end; +end; + +end. diff --git a/official/4.8.11/Demos/MDI Designer/DataUnit.dfm b/official/4.8.11/Demos/MDI Designer/DataUnit.dfm new file mode 100644 index 0000000..12ee238 --- /dev/null +++ b/official/4.8.11/Demos/MDI Designer/DataUnit.dfm @@ -0,0 +1,55 @@ +object ReportData: TReportData + OldCreateOrder = False + Left = 278 + Top = 149 + Height = 138 + Width = 208 + object animals: TTable + DatabaseName = 'DBDEMOS' + TableName = 'animals.dbf' + Left = 8 + end + object biolife: TTable + DatabaseName = 'DBDEMOS' + TableName = 'biolife.db' + Left = 56 + end + object clients: TTable + DatabaseName = 'DBDEMOS' + TableName = 'clients.dbf' + Left = 104 + end + object customer: TTable + DatabaseName = 'DBDEMOS' + TableName = 'customer.db' + Left = 152 + end + object animalsDB: TfrxDBDataset + UserName = 'animals' + CloseDataSource = False + DataSet = animals + Left = 8 + Top = 56 + end + object biolifeDB: TfrxDBDataset + UserName = 'biolifeDB' + CloseDataSource = False + DataSet = biolife + Left = 56 + Top = 56 + end + object clientsBD: TfrxDBDataset + UserName = 'clients' + CloseDataSource = False + DataSet = clients + Left = 104 + Top = 56 + end + object customerDB: TfrxDBDataset + UserName = 'customer' + CloseDataSource = False + DataSet = customer + Left = 152 + Top = 56 + end +end diff --git a/official/4.8.11/Demos/MDI Designer/DataUnit.pas b/official/4.8.11/Demos/MDI Designer/DataUnit.pas new file mode 100644 index 0000000..5cb82cd --- /dev/null +++ b/official/4.8.11/Demos/MDI Designer/DataUnit.pas @@ -0,0 +1,31 @@ +unit DataUnit; + +interface + +uses + SysUtils, Classes, frxClass, frxDBSet, DB, DBTables; + +type + TReportData = class(TDataModule) + animals: TTable; + biolife: TTable; + clients: TTable; + customer: TTable; + animalsDB: TfrxDBDataset; + biolifeDB: TfrxDBDataset; + clientsBD: TfrxDBDataset; + customerDB: TfrxDBDataset; + private + { Private declarations } + public + { Public declarations } + end; + +var + ReportData: TReportData; + +implementation + +{$R *.dfm} + +end. diff --git a/official/4.8.11/Demos/MDI Designer/MAIN.PAS b/official/4.8.11/Demos/MDI Designer/MAIN.PAS new file mode 100644 index 0000000..0e09e69 --- /dev/null +++ b/official/4.8.11/Demos/MDI Designer/MAIN.PAS @@ -0,0 +1,194 @@ +unit MAIN; + +interface + +uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus, + StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, StdActns, + ActnList, ToolWin, ImgList, frxClass, frxDesgn; + +type + TfrxReportList = class(TObject) + private + FReportList: TList; + function GetReport(Index: Integer): TfrxReport; + function GetCount: Integer; + public + constructor Create; + destructor Destroy; override; + procedure ClearList; + procedure Delete(Index: Integer); + function CreateNewReport: TfrxReport; + function IndexOf(Report: TfrxReport): Integer; + property Report [Index: Integer]: TfrxReport read GetReport; + property Count: Integer read GetCount; + end; + + TMainForm = class(TForm) + StatusBar: TStatusBar; + ActionList1: TActionList; + FileNew1: TAction; + FileSave1: TAction; + FileExit1: TAction; + WindowCascade1: TWindowCascade; + WindowTileHorizontal1: TWindowTileHorizontal; + WindowArrangeAll1: TWindowArrange; + WindowMinimizeAll1: TWindowMinimizeAll; + WindowTileVertical1: TWindowTileVertical; + ToolBar2: TToolBar; + ToolButton2: TToolButton; + ToolButton3: TToolButton; + ToolButton9: TToolButton; + ToolButton8: TToolButton; + ToolButton10: TToolButton; + ToolButton11: TToolButton; + ImageList1: TImageList; + ToolButton1: TToolButton; + ToolButton5: TToolButton; + PreviewReport: TAction; + MainMenu1: TMainMenu; + procedure FileNew1Execute(Sender: TObject); + procedure FileExit1Execute(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure DestroyDesigner(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure FileSave1Execute(Sender: TObject); + procedure PreviewReportExecute(Sender: TObject); + private + { Private declarations } + FReportList: TfrxReportList; + public + { Public declarations } + end; + +var + MainForm: TMainForm; + +implementation + +{$R *.dfm} + +{ TfrxReportList } + +procedure TfrxReportList.ClearList; +begin + while FReportList.Count > 0 do + begin + TfrxReport(FReportList[0]).Free; + FReportList.Delete(0); + end; +end; + +constructor TfrxReportList.Create; +begin + inherited; + FReportList := TList.Create; +end; + +function TfrxReportList.CreateNewReport: TfrxReport; +begin + Result := TfrxReport.Create(nil); + Result.CreateUniqueName; + Result.PreviewOptions.MDIChild := True; + Result.PreviewOptions.Modal := False; + Result.EngineOptions.DestroyForms := False; + FReportList.Add(Result); +end; + +procedure TfrxReportList.Delete(Index: Integer); +begin + if (Index < 0) or (Index >= FReportList.Count) then + exit; + TfrxReport(FReportList[Index]).Free; + FReportList.Delete(Index); +end; + +destructor TfrxReportList.Destroy; +begin + ClearList; + FReportList.Free; + inherited; +end; + +function TfrxReportList.GetCount: Integer; +begin + Result := FReportList.Count; +end; + +function TfrxReportList.GetReport(Index: Integer): TfrxReport; +begin + if (Index < 0) or (Index >= FReportList.Count) then + Result := nil + else + Result := TfrxReport(FReportList[Index]); +end; + +function TfrxReportList.IndexOf(Report: TfrxReport): Integer; +begin + Result := FReportList.IndexOf(Report); +end; + + +{Main Form} + +procedure TMainForm.FileNew1Execute(Sender: TObject); +begin + with FReportList.CreateNewReport do + begin + DesignReport(False, True); + TfrxDesignerForm(Designer).OnDestroy := DestroyDesigner; + TfrxDesignerForm(Designer).Caption := 'Designer-' + IntToStr(FReportList.Count); + end; +end; + +procedure TMainForm.FileExit1Execute(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + FReportList := TfrxReportList.Create; +end; + +procedure TMainForm.FormDestroy(Sender: TObject); +begin + FReportList.Free; +end; + +procedure TMainForm.DestroyDesigner(Sender: TObject); +var + idx: Integer; +begin + idx := FReportList.IndexOf(TfrxDesignerForm(Sender).Report); + if FReportList.Report[idx].PreviewForm <> nil then + FReportList.Report[idx].PreviewForm.Close; + FReportList.Delete(idx); +end; + +procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); +var + idx: Integer; +begin + for idx := 0 to FReportList.Count - 1 do + TfrxDesignerForm(FReportList.Report[idx].Designer).Close; + Action := caFree; +end; + +procedure TMainForm.FileSave1Execute(Sender: TObject); +var + idx: Integer; +begin + for idx := 0 to FReportList.Count - 1 do + TfrxDesignerForm(FReportList.Report[idx].Designer).SaveCmd.Execute; +end; + +procedure TMainForm.PreviewReportExecute(Sender: TObject); +var + idx: Integer; +begin + for idx := 0 to FReportList.Count - 1 do + FReportList.Report[idx].ShowReport; +end; + +end. diff --git a/official/4.8.11/Demos/MDI Designer/MAIN.dfm b/official/4.8.11/Demos/MDI Designer/MAIN.dfm new file mode 100644 index 0000000..d6d49ae --- /dev/null +++ b/official/4.8.11/Demos/MDI Designer/MAIN.dfm @@ -0,0 +1,569 @@ +object MainForm: TMainForm + Left = 268 + Top = 128 + Width = 439 + Height = 373 + Caption = 'MDI Designer application' + Color = clAppWorkSpace + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlack + Font.Height = -11 + Font.Name = 'Default' + Font.Style = [] + FormStyle = fsMDIForm + Menu = MainMenu1 + OldCreateOrder = False + Position = poDefault + OnClose = FormClose + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 96 + TextHeight = 13 + object StatusBar: TStatusBar + Left = 0 + Top = 320 + Width = 431 + Height = 19 + AutoHint = True + Panels = <> + SimplePanel = True + end + object ToolBar2: TToolBar + Left = 0 + Top = 0 + Width = 431 + Height = 30 + BorderWidth = 1 + Color = clBtnFace + Images = ImageList1 + Indent = 5 + ParentColor = False + ParentShowHint = False + ShowHint = True + TabOrder = 1 + Wrapable = False + object ToolButton9: TToolButton + Left = 5 + Top = 2 + Action = FileNew1 + ImageIndex = 0 + end + object ToolButton2: TToolButton + Left = 28 + Top = 2 + Action = FileSave1 + ImageIndex = 1 + end + object ToolButton3: TToolButton + Left = 51 + Top = 2 + Width = 8 + Caption = 'ToolButton3' + ImageIndex = 2 + Style = tbsSeparator + end + object ToolButton8: TToolButton + Left = 59 + Top = 2 + Action = WindowCascade1 + ImageIndex = 5 + end + object ToolButton10: TToolButton + Left = 82 + Top = 2 + Action = WindowTileHorizontal1 + ImageIndex = 3 + end + object ToolButton11: TToolButton + Left = 105 + Top = 2 + Action = WindowTileVertical1 + ImageIndex = 4 + end + object ToolButton5: TToolButton + Left = 128 + Top = 2 + Width = 8 + Caption = 'ToolButton5' + ImageIndex = 7 + Style = tbsSeparator + end + object ToolButton1: TToolButton + Left = 136 + Top = 2 + Action = PreviewReport + Caption = 'Preview Report current report' + end + end + object ActionList1: TActionList + Images = ImageList1 + Left = 32 + Top = 32 + object FileNew1: TAction + Category = 'File' + Caption = '&New' + Hint = 'New|Create a new designer window' + ImageIndex = 6 + ShortCut = 16462 + OnExecute = FileNew1Execute + end + object FileSave1: TAction + Category = 'File' + Caption = '&Save' + Hint = 'Save|Save all reports' + ImageIndex = 8 + ShortCut = 16467 + OnExecute = FileSave1Execute + end + object FileExit1: TAction + Category = 'File' + Caption = 'E&xit' + Hint = 'Exit|Exit application' + OnExecute = FileExit1Execute + end + object WindowCascade1: TWindowCascade + Category = 'Window' + Caption = '&Cascade' + Hint = 'Cascade' + ImageIndex = 17 + end + object WindowTileHorizontal1: TWindowTileHorizontal + Category = 'Window' + Caption = 'Tile &Horizontally' + Hint = 'Tile Horizontally' + ImageIndex = 15 + end + object WindowTileVertical1: TWindowTileVertical + Category = 'Window' + Caption = 'Tile &Vertically' + Hint = 'Tile Vertically' + ImageIndex = 16 + end + object WindowMinimizeAll1: TWindowMinimizeAll + Category = 'Window' + Caption = '&Minimize All' + Hint = 'Minimize All' + end + object WindowArrangeAll1: TWindowArrange + Category = 'Window' + Caption = '&Arrange All' + Hint = 'Arrange All' + end + object PreviewReport: TAction + Category = 'File' + Caption = 'Preview' + Hint = 'Preview| Preview all report' + ImageIndex = 2 + OnExecute = PreviewReportExecute + end + end + object ImageList1: TImageList + Top = 32 + Bitmap = { + 494C010107000900040010001000FFFFFFFFFF00FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000003000000001002000000000000030 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000080000000800000008000000080000000800000008000 + 0000800000008000000080000000800000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000800000008000000000000000000000000000000000000000000000000000 + 0000000000000000000080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00800000000000000000000000000000000000 + 0000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000000000 + 0000000000000000000080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00800000000000000000000000000000000000 + 000000000000FFFFFF0000000000FFFFFF000000000000000000000000000000 + 0000FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000000000 + 0000000000000000000080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000000000000000000000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 00008000000080000000800000008000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF000000000000000000000000000000 + 00000000000000000000FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000008000 + 0000FFFFFF00FFFFFF0080000000800000008000000080000000800000008000 + 00008000000080000000FFFFFF008000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000008000 + 0000FFFFFF00FFFFFF0080000000800000008000000080000000800000008000 + 00008000000080000000800000008000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF000000000000000000000000000000 + 00000000000000000000FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000000000000000000008000 + 0000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF008000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 00008000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000080000000FFFFFF008000 + 000080000000800000008000000080000000800000008000000080000000FFFF + FF008000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF0080000000FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF008000000000000000000000000000000080000000FFFFFF008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 00008000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF000000000000000000FFFFFF00FFFF + FF0000000000FFFFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000800000008000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00800000000000 + 00000000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 00008000000080000000FFFFFF00800000008000000080000000800000008000 + 0000FFFFFF008000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000000000 + 00000000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF0000000000FFFFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000800000008000000000000000000000000000000080000000800000008000 + 00008000000080000000800000008000000080000000FFFFFF00800000000000 + 00000000000000000000000000000000000000000000FFFFFF0000000000FFFF + FF00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000000000 + 00000000000000000000000000000000000000000000FFFFFF00000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000800000008000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000008080000080 + 8000000000000000000000000000000000000000000000000000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000080 + 8000000000000000000000000000000000000000000000000000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000080 + 8000000000000000000000000000000000000000000000000000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000000080808000C0C0C000C0C0C0008080 + 8000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000080 + 8000000000000000000000000000000000000000000000000000000000000000 + 00000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000000080808000C0C0C000C0C0C000FFFF00008080 + 8000808080000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 000080000000800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000080 + 8000008080000080800000808000008080000080800000808000008080000080 + 80000080800000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0000000000C0C0C000C0C0C000C0C0C000C0C0C0008080 + 8000C0C0C0000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000080 + 8000000000000000000000000000000000000000000000000000000000000000 + 00000080800000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0000000000C0C0C000FFFF0000C0C0C000C0C0C0008080 + 8000C0C0C0000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 000080000000800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000000080808000FFFF0000FFFF0000C0C0C0008080 + 8000808080000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000000080808000C0C0C000C0C0C0008080 + 8000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000000000000000 + 0000000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C0000000000000808000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 000080000000800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000FFFFFF000000 + 0000000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C0000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000FFFFFF00800000000000000000000000000000000000000000000000FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000000000000000 + 0000000000000000000000000000000000000000000000000000008080000000 + 0000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C000C0C0 + C00000000000C0C0C000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000C0C0C000000000000000 + 0000000000000000000000000000000000000000000080000000800000008000 + 0000800000008000000080000000800000008000000080000000800000008000 + 0000800000008000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000424D3E000000000000003E000000 + 2800000040000000300000000100010000000000800100000000000000000000 + 000000000000000000000000FFFFFF0000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000FFFFFC00FC0000008003FC00F0000000 + 8003FC00C00000008003FC00000000008003E000000000008003E00000000000 + 8003E000000000008003E0070000000080038007000000008003800700000000 + 80038007000100008003801F000300008003801F000700008003801F001F0000 + FFFF801F007F0000FFFFFFFF01FF0000FFFFFFFFFFFFFFFFFFFFC001000C8003 + C007800100088003C007800100018003C007800100038003C007800100038003 + C007800100038003C007800100038003C007800100038003C007800100078003 + C0078001000F8003C0078001000F8003C00F8001000F8003C01F8001001F8003 + C03F8001003FFFFFFFFFFFFF007FFFFF} + end + object MainMenu1: TMainMenu + Left = 64 + Top = 32 + end +end diff --git a/official/4.8.11/Demos/MDI Designer/MDIAPP.DPR b/official/4.8.11/Demos/MDI Designer/MDIAPP.DPR new file mode 100644 index 0000000..9e894bc --- /dev/null +++ b/official/4.8.11/Demos/MDI Designer/MDIAPP.DPR @@ -0,0 +1,15 @@ +program Mdiapp; + +uses + Forms, + MAIN in 'MAIN.PAS' {MainForm}, + DataUnit in 'DataUnit.pas' {ReportData: TDataModule}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TReportData, ReportData); + Application.Run; +end. diff --git a/official/4.8.11/Demos/MDI Designer/MDIAPP.RES b/official/4.8.11/Demos/MDI Designer/MDIAPP.RES new file mode 100644 index 0000000..4f7526a Binary files /dev/null and b/official/4.8.11/Demos/MDI Designer/MDIAPP.RES differ diff --git a/official/4.8.11/Demos/Main/1.fr3 b/official/4.8.11/Demos/Main/1.fr3 new file mode 100644 index 0000000..f9e3ab8 --- /dev/null +++ b/official/4.8.11/Demos/Main/1.fr3 @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/10.FR3 b/official/4.8.11/Demos/Main/10.FR3 new file mode 100644 index 0000000..2a30316 --- /dev/null +++ b/official/4.8.11/Demos/Main/10.FR3 @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/100.fr3 b/official/4.8.11/Demos/Main/100.fr3 new file mode 100644 index 0000000..f0619eb --- /dev/null +++ b/official/4.8.11/Demos/Main/100.fr3 @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/101.fr3 b/official/4.8.11/Demos/Main/101.fr3 new file mode 100644 index 0000000..a3d524c --- /dev/null +++ b/official/4.8.11/Demos/Main/101.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/102.fr3 b/official/4.8.11/Demos/Main/102.fr3 new file mode 100644 index 0000000..c0ef308 --- /dev/null +++ b/official/4.8.11/Demos/Main/102.fr3 @@ -0,0 +1,13 @@ + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/103.fr3 b/official/4.8.11/Demos/Main/103.fr3 new file mode 100644 index 0000000..0483570 --- /dev/null +++ b/official/4.8.11/Demos/Main/103.fr3 @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/official/4.8.11/Demos/Main/104.fr3 b/official/4.8.11/Demos/Main/104.fr3 new file mode 100644 index 0000000..df05ae7 --- /dev/null +++ b/official/4.8.11/Demos/Main/104.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/105.fr3 b/official/4.8.11/Demos/Main/105.fr3 new file mode 100644 index 0000000..1e5f9f6 --- /dev/null +++ b/official/4.8.11/Demos/Main/105.fr3 @@ -0,0 +1,35 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/11.FR3 b/official/4.8.11/Demos/Main/11.FR3 new file mode 100644 index 0000000..b2f7e74 --- /dev/null +++ b/official/4.8.11/Demos/Main/11.FR3 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/12.FR3 b/official/4.8.11/Demos/Main/12.FR3 new file mode 100644 index 0000000..f4a9ce1 --- /dev/null +++ b/official/4.8.11/Demos/Main/12.FR3 @@ -0,0 +1,28 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/13.fr3 b/official/4.8.11/Demos/Main/13.fr3 new file mode 100644 index 0000000..cf59944 --- /dev/null +++ b/official/4.8.11/Demos/Main/13.fr3 @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/official/4.8.11/Demos/Main/2.FR3 b/official/4.8.11/Demos/Main/2.FR3 new file mode 100644 index 0000000..b8dee3f --- /dev/null +++ b/official/4.8.11/Demos/Main/2.FR3 @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/21.FR3 b/official/4.8.11/Demos/Main/21.FR3 new file mode 100644 index 0000000..1481b74 --- /dev/null +++ b/official/4.8.11/Demos/Main/21.FR3 @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/22.FR3 b/official/4.8.11/Demos/Main/22.FR3 new file mode 100644 index 0000000..a7d8344 --- /dev/null +++ b/official/4.8.11/Demos/Main/22.FR3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/23.FR3 b/official/4.8.11/Demos/Main/23.FR3 new file mode 100644 index 0000000..4602809 --- /dev/null +++ b/official/4.8.11/Demos/Main/23.FR3 @@ -0,0 +1,6 @@ + + + + + + diff --git a/official/4.8.11/Demos/Main/24.FR3 b/official/4.8.11/Demos/Main/24.FR3 new file mode 100644 index 0000000..f0d8417 --- /dev/null +++ b/official/4.8.11/Demos/Main/24.FR3 @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/25.fr3 b/official/4.8.11/Demos/Main/25.fr3 new file mode 100644 index 0000000..8ebc608 --- /dev/null +++ b/official/4.8.11/Demos/Main/25.fr3 @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/3.FR3 b/official/4.8.11/Demos/Main/3.FR3 new file mode 100644 index 0000000..54f8981 --- /dev/null +++ b/official/4.8.11/Demos/Main/3.FR3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/31.FR3 b/official/4.8.11/Demos/Main/31.FR3 new file mode 100644 index 0000000..d3fa56f --- /dev/null +++ b/official/4.8.11/Demos/Main/31.FR3 @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/32.FR3 b/official/4.8.11/Demos/Main/32.FR3 new file mode 100644 index 0000000..2d5219a --- /dev/null +++ b/official/4.8.11/Demos/Main/32.FR3 @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/33.FR3 b/official/4.8.11/Demos/Main/33.FR3 new file mode 100644 index 0000000..860355b --- /dev/null +++ b/official/4.8.11/Demos/Main/33.FR3 @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/34.FR3 b/official/4.8.11/Demos/Main/34.FR3 new file mode 100644 index 0000000..bbab78a --- /dev/null +++ b/official/4.8.11/Demos/Main/34.FR3 @@ -0,0 +1,50 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/35.fr3 b/official/4.8.11/Demos/Main/35.fr3 new file mode 100644 index 0000000..0674088 --- /dev/null +++ b/official/4.8.11/Demos/Main/35.fr3 @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/36.fr3 b/official/4.8.11/Demos/Main/36.fr3 new file mode 100644 index 0000000..a70c764 --- /dev/null +++ b/official/4.8.11/Demos/Main/36.fr3 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/4.FR3 b/official/4.8.11/Demos/Main/4.FR3 new file mode 100644 index 0000000..c12d517 --- /dev/null +++ b/official/4.8.11/Demos/Main/4.FR3 @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/41.FR3 b/official/4.8.11/Demos/Main/41.FR3 new file mode 100644 index 0000000..5338a78 --- /dev/null +++ b/official/4.8.11/Demos/Main/41.FR3 @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/42.FR3 b/official/4.8.11/Demos/Main/42.FR3 new file mode 100644 index 0000000..27a5604 --- /dev/null +++ b/official/4.8.11/Demos/Main/42.FR3 @@ -0,0 +1,13 @@ + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/43.FR3 b/official/4.8.11/Demos/Main/43.FR3 new file mode 100644 index 0000000..6c445f6 --- /dev/null +++ b/official/4.8.11/Demos/Main/43.FR3 @@ -0,0 +1,14 @@ + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/44.fr3 b/official/4.8.11/Demos/Main/44.fr3 new file mode 100644 index 0000000..c7c36ca --- /dev/null +++ b/official/4.8.11/Demos/Main/44.fr3 @@ -0,0 +1,31 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/45.fr3 b/official/4.8.11/Demos/Main/45.fr3 new file mode 100644 index 0000000..726914e --- /dev/null +++ b/official/4.8.11/Demos/Main/45.fr3 @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/5.FR3 b/official/4.8.11/Demos/Main/5.FR3 new file mode 100644 index 0000000..60dcbf5 --- /dev/null +++ b/official/4.8.11/Demos/Main/5.FR3 @@ -0,0 +1,14 @@ + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/51.FR3 b/official/4.8.11/Demos/Main/51.FR3 new file mode 100644 index 0000000..a166485 --- /dev/null +++ b/official/4.8.11/Demos/Main/51.FR3 @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/52.FR3 b/official/4.8.11/Demos/Main/52.FR3 new file mode 100644 index 0000000..0e92260 --- /dev/null +++ b/official/4.8.11/Demos/Main/52.FR3 @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/6.FR3 b/official/4.8.11/Demos/Main/6.FR3 new file mode 100644 index 0000000..f8f8483 --- /dev/null +++ b/official/4.8.11/Demos/Main/6.FR3 @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/60.fr3 b/official/4.8.11/Demos/Main/60.fr3 new file mode 100644 index 0000000..32afe7c --- /dev/null +++ b/official/4.8.11/Demos/Main/60.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/61.FR3 b/official/4.8.11/Demos/Main/61.FR3 new file mode 100644 index 0000000..3f78734 --- /dev/null +++ b/official/4.8.11/Demos/Main/61.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/62.FR3 b/official/4.8.11/Demos/Main/62.FR3 new file mode 100644 index 0000000..748b093 --- /dev/null +++ b/official/4.8.11/Demos/Main/62.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/63.FR3 b/official/4.8.11/Demos/Main/63.FR3 new file mode 100644 index 0000000..b56e858 --- /dev/null +++ b/official/4.8.11/Demos/Main/63.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/64.FR3 b/official/4.8.11/Demos/Main/64.FR3 new file mode 100644 index 0000000..33d5273 --- /dev/null +++ b/official/4.8.11/Demos/Main/64.FR3 @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/65.FR3 b/official/4.8.11/Demos/Main/65.FR3 new file mode 100644 index 0000000..1c54b37 --- /dev/null +++ b/official/4.8.11/Demos/Main/65.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/66.FR3 b/official/4.8.11/Demos/Main/66.FR3 new file mode 100644 index 0000000..1f6478f --- /dev/null +++ b/official/4.8.11/Demos/Main/66.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/67.FR3 b/official/4.8.11/Demos/Main/67.FR3 new file mode 100644 index 0000000..f0b3505 --- /dev/null +++ b/official/4.8.11/Demos/Main/67.FR3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/68.FR3 b/official/4.8.11/Demos/Main/68.FR3 new file mode 100644 index 0000000..147e68e --- /dev/null +++ b/official/4.8.11/Demos/Main/68.FR3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/69.FR3 b/official/4.8.11/Demos/Main/69.FR3 new file mode 100644 index 0000000..1e4b3fa --- /dev/null +++ b/official/4.8.11/Demos/Main/69.FR3 @@ -0,0 +1,7 @@ + + + + + + + diff --git a/official/4.8.11/Demos/Main/7.FR3 b/official/4.8.11/Demos/Main/7.FR3 new file mode 100644 index 0000000..4e25511 --- /dev/null +++ b/official/4.8.11/Demos/Main/7.FR3 @@ -0,0 +1,12 @@ + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/70.fr3 b/official/4.8.11/Demos/Main/70.fr3 new file mode 100644 index 0000000..978e81d --- /dev/null +++ b/official/4.8.11/Demos/Main/70.fr3 @@ -0,0 +1,21 @@ + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/71.fr3 b/official/4.8.11/Demos/Main/71.fr3 new file mode 100644 index 0000000..ed3c83d --- /dev/null +++ b/official/4.8.11/Demos/Main/71.fr3 @@ -0,0 +1,44 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/72.fr3 b/official/4.8.11/Demos/Main/72.fr3 new file mode 100644 index 0000000..c0864c6 --- /dev/null +++ b/official/4.8.11/Demos/Main/72.fr3 @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/73.fr3 b/official/4.8.11/Demos/Main/73.fr3 new file mode 100644 index 0000000..ef85858 --- /dev/null +++ b/official/4.8.11/Demos/Main/73.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/8.FR3 b/official/4.8.11/Demos/Main/8.FR3 new file mode 100644 index 0000000..4a6b83f --- /dev/null +++ b/official/4.8.11/Demos/Main/8.FR3 @@ -0,0 +1,17 @@ + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/80.fr3 b/official/4.8.11/Demos/Main/80.fr3 new file mode 100644 index 0000000..21d4dca --- /dev/null +++ b/official/4.8.11/Demos/Main/80.fr3 @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/81.fr3 b/official/4.8.11/Demos/Main/81.fr3 new file mode 100644 index 0000000..8299f81 --- /dev/null +++ b/official/4.8.11/Demos/Main/81.fr3 @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/82.fr3 b/official/4.8.11/Demos/Main/82.fr3 new file mode 100644 index 0000000..48950b2 --- /dev/null +++ b/official/4.8.11/Demos/Main/82.fr3 @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/9.FR3 b/official/4.8.11/Demos/Main/9.FR3 new file mode 100644 index 0000000..3d41490 --- /dev/null +++ b/official/4.8.11/Demos/Main/9.FR3 @@ -0,0 +1,17 @@ + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/90.fr3 b/official/4.8.11/Demos/Main/90.fr3 new file mode 100644 index 0000000..d1df06c --- /dev/null +++ b/official/4.8.11/Demos/Main/90.fr3 @@ -0,0 +1,13 @@ + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/91.fr3 b/official/4.8.11/Demos/Main/91.fr3 new file mode 100644 index 0000000..649c56e --- /dev/null +++ b/official/4.8.11/Demos/Main/91.fr3 @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/92.fr3 b/official/4.8.11/Demos/Main/92.fr3 new file mode 100644 index 0000000..be5506d Binary files /dev/null and b/official/4.8.11/Demos/Main/92.fr3 differ diff --git a/official/4.8.11/Demos/Main/93.fr3 b/official/4.8.11/Demos/Main/93.fr3 new file mode 100644 index 0000000..b3b6460 --- /dev/null +++ b/official/4.8.11/Demos/Main/93.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/94.fr3 b/official/4.8.11/Demos/Main/94.fr3 new file mode 100644 index 0000000..1b017f5 --- /dev/null +++ b/official/4.8.11/Demos/Main/94.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/95.fr3 b/official/4.8.11/Demos/Main/95.fr3 new file mode 100644 index 0000000..8c194fc --- /dev/null +++ b/official/4.8.11/Demos/Main/95.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/96.fr3 b/official/4.8.11/Demos/Main/96.fr3 new file mode 100644 index 0000000..2a9474f --- /dev/null +++ b/official/4.8.11/Demos/Main/96.fr3 @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/97.fr3 b/official/4.8.11/Demos/Main/97.fr3 new file mode 100644 index 0000000..f1f49ca --- /dev/null +++ b/official/4.8.11/Demos/Main/97.fr3 @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/98.fr3 b/official/4.8.11/Demos/Main/98.fr3 new file mode 100644 index 0000000..efd66d8 --- /dev/null +++ b/official/4.8.11/Demos/Main/98.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/99.fr3 b/official/4.8.11/Demos/Main/99.fr3 new file mode 100644 index 0000000..e62c649 --- /dev/null +++ b/official/4.8.11/Demos/Main/99.fr3 @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/official/4.8.11/Demos/Main/FRDemo.bdsproj b/official/4.8.11/Demos/Main/FRDemo.bdsproj new file mode 100644 index 0000000..8fe126b --- /dev/null +++ b/official/4.8.11/Demos/Main/FRDemo.bdsproj @@ -0,0 +1,175 @@ +п»ї + + + + + + + + + + + FRDemo.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + + vcl;rtl;dbrtl;adortl;vcldb;vclx;bdertl;vcldbx;ibxpress;dsnap;cds;bdecds;qrpt;teeui;teedb;dss;teeqr;visualclx;visualdbclx;dsnapcrba;dsnapcon;VclSmp;vclshlctrls;dbexpress;dbxcds;dclaxserver;Tee;TeeGL;TeeLanguage;TeePro;TeeImage;fsTee6;frxTee6;fsIBX6;fs6;fqb60;frx6;frxADO6;frxBDE6;frxcs6;frxDB6;frxDBX6;frxe6;frxIBX6;fsADO6;fsBDE6;fsDB6 + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/Demos/Main/FRDemo.dpr b/official/4.8.11/Demos/Main/FRDemo.dpr new file mode 100644 index 0000000..86680b9 --- /dev/null +++ b/official/4.8.11/Demos/Main/FRDemo.dpr @@ -0,0 +1,15 @@ +program FRDemo; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {ReportData: TDataModule}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TReportData, ReportData); + Application.Run; +end. diff --git a/official/4.8.11/Demos/Main/FRDemo.res b/official/4.8.11/Demos/Main/FRDemo.res new file mode 100644 index 0000000..06b79d7 Binary files /dev/null and b/official/4.8.11/Demos/Main/FRDemo.res differ diff --git a/official/4.8.11/Demos/Main/Unit1.dfm b/official/4.8.11/Demos/Main/Unit1.dfm new file mode 100644 index 0000000..9444fc8 Binary files /dev/null and b/official/4.8.11/Demos/Main/Unit1.dfm differ diff --git a/official/4.8.11/Demos/Main/Unit1.pas b/official/4.8.11/Demos/Main/Unit1.pas new file mode 100644 index 0000000..aadaab9 --- /dev/null +++ b/official/4.8.11/Demos/Main/Unit1.pas @@ -0,0 +1,136 @@ +unit Unit1; + +{$I frx.inc} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Db, frxDesgn, frxClass, frxDCtrl, frxChart, + frxRich, frxBarcode, ImgList, ComCtrls, ExtCtrls, frxOLE, + frxCross, frxDMPExport, frxExportImage, frxExportRTF, + frxExportXML, frxExportXLS, frxExportHTML, frxGZip, frxExportPDF, + frxChBox, frxExportText, frxExportCSV, frxExportMail, + frxADOComponents, frxCrypt, frxExportODF, frxPrinter; + +type + TForm1 = class(TForm) + frxDesigner1: TfrxDesigner; + frxBarCodeObject1: TfrxBarCodeObject; + frxRichObject1: TfrxRichObject; + frxDialogControls1: TfrxDialogControls; + ImageList1: TImageList; + Image1: TImage; + Label1: TLabel; + Label3: TLabel; + frxOLEObject1: TfrxOLEObject; + frxCrossObject1: TfrxCrossObject; + frxDotMatrixExport1: TfrxDotMatrixExport; + frxBMPExport1: TfrxBMPExport; + frxJPEGExport1: TfrxJPEGExport; + frxTIFFExport1: TfrxTIFFExport; + frxHTMLExport1: TfrxHTMLExport; + frxXLSExport1: TfrxXLSExport; + frxXMLExport1: TfrxXMLExport; + frxRTFExport1: TfrxRTFExport; + frxGZipCompressor1: TfrxGZipCompressor; + frxPDFExport1: TfrxPDFExport; + Label4: TLabel; + frxCheckBoxObject1: TfrxCheckBoxObject; + frxMailExport1: TfrxMailExport; + frxCSVExport1: TfrxCSVExport; + frxGIFExport1: TfrxGIFExport; + frxSimpleTextExport1: TfrxSimpleTextExport; + frxADOComponents1: TfrxADOComponents; + frxCrypt1: TfrxCrypt; + GroupBox1: TGroupBox; + Tree: TTreeView; + GroupBox2: TGroupBox; + DescriptionM: TMemo; + DesignB: TButton; + PreviewB: TButton; + Label5: TLabel; + Label7: TLabel; + Label2: TLabel; + FileNameL: TLabel; + Shape1: TShape; + frxODSExport1: TfrxODSExport; + frxODTExport1: TfrxODTExport; + frxReport1: TfrxReport; + procedure DesignBClick(Sender: TObject); + procedure TreeCustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode; + State: TCustomDrawState; var DefaultDraw: Boolean); + procedure PreviewBClick(Sender: TObject); + procedure TreeChange(Sender: TObject; Node: TTreeNode); + procedure FormShow(Sender: TObject); + procedure Label3Click(Sender: TObject); + private + { Private declarations } + WPath: String; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2, ShellApi +{$IFDEF Delphi7} +, XPMan +{$ENDIF}; + +{$R *.DFM} + +procedure TForm1.FormShow(Sender: TObject); +begin + WPath := ExtractFilePath(Application.ExeName); + Tree.Items[0].Item[0].Selected := True; + Label2.Caption := FR_VERSION; + Label4.Caption := #174; +end; + +procedure TForm1.DesignBClick(Sender: TObject); +begin + frxReport1.DesignReport; +end; + +procedure TForm1.PreviewBClick(Sender: TObject); +begin + frxReport1.ShowReport; +end; + +procedure TForm1.TreeCustomDrawItem(Sender: TCustomTreeView; + Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); +begin + if Node.Count <> 0 then + Tree.Canvas.Font.Style := [fsBold]; +end; + +procedure TForm1.TreeChange(Sender: TObject; Node: TTreeNode); +begin + if Node.StateIndex = -1 then + begin + Tree.FullCollapse; + Node[0].Selected := True; + end + else + begin + DesignB.Enabled := True; + PreviewB.Enabled := True; + frxReport1.LoadFromFile(WPath + IntToStr(Node.StateIndex) + '.fr3'); + FileNameL.Caption := ' Report file: ' + IntToStr(Node.StateIndex) + '.fr3'; + DescriptionM.Lines := frxReport1.ReportOptions.Description; + end; +end; + +procedure TForm1.Label3Click(Sender: TObject); +begin + ShellExecute(GetDesktopWindow, 'open', + PChar(TLabel(Sender).Caption), nil, nil, sw_ShowNormal); +end; + +end. + + diff --git a/official/4.8.11/Demos/Main/Unit2.dfm b/official/4.8.11/Demos/Main/Unit2.dfm new file mode 100644 index 0000000..b164919 Binary files /dev/null and b/official/4.8.11/Demos/Main/Unit2.dfm differ diff --git a/official/4.8.11/Demos/Main/Unit2.pas b/official/4.8.11/Demos/Main/Unit2.pas new file mode 100644 index 0000000..5513fde --- /dev/null +++ b/official/4.8.11/Demos/Main/Unit2.pas @@ -0,0 +1,154 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxDBSet, Db, frxClass, ADODB; + +type + TReportData = class(TDataModule) + Customers: TADOTable; + CustomersCustNo: TFloatField; + CustomersCompany: TStringField; + CustomersAddr1: TStringField; + CustomersAddr2: TStringField; + CustomersCity: TStringField; + CustomersState: TStringField; + CustomersZip: TStringField; + CustomersCountry: TStringField; + CustomersPhone: TStringField; + CustomersFAX: TStringField; + CustomersTaxRate: TFloatField; + CustomersContact: TStringField; + CustomersLastInvoiceDate: TDateTimeField; + Orders: TADOTable; + OrdersOrderNo: TFloatField; + OrdersCustNo: TFloatField; + OrdersCustCompany: TStringField; + OrdersSaleDate: TDateTimeField; + OrdersShipDate: TDateTimeField; + OrdersEmpNo: TIntegerField; + OrdersShipToContact: TStringField; + OrdersShipToAddr1: TStringField; + OrdersShipToAddr2: TStringField; + OrdersShipToCity: TStringField; + OrdersShipToState: TStringField; + OrdersShipToZip: TStringField; + OrdersShipToCountry: TStringField; + OrdersShipToPhone: TStringField; + OrdersShipVIA: TStringField; + OrdersPO: TStringField; + OrdersTerms: TStringField; + OrdersPaymentMethod: TStringField; + OrdersItemsTotal: TCurrencyField; + OrdersTaxRate: TFloatField; + OrdersFreight: TCurrencyField; + OrdersAmountPaid: TCurrencyField; + LineItems: TADOTable; + LineItemsOrderNo: TFloatField; + LineItemsItemNo: TFloatField; + LineItemsPartNo: TFloatField; + LineItemsPartName: TStringField; + LineItemsQty: TIntegerField; + LineItemsPrice: TCurrencyField; + LineItemsDiscount: TFloatField; + LineItemsTotal: TCurrencyField; + LineItemsExtendedPrice: TCurrencyField; + Parts: TADOTable; + PartsPartNo: TFloatField; + PartsVendorNo: TFloatField; + PartsDescription: TStringField; + PartsOnHand: TFloatField; + PartsOnOrder: TFloatField; + PartsCost: TCurrencyField; + PartsListPrice: TCurrencyField; + CustomerSource: TDataSource; + OrderSource: TDataSource; + LineItemSource: TDataSource; + PartSource: TDataSource; + RepQuery: TADOQuery; + RepQuerySource: TDataSource; + CustomersDS: TfrxDBDataset; + OrdersDS: TfrxDBDataset; + ItemsDS: TfrxDBDataset; + PartDS: TfrxDBDataset; + QueryDS: TfrxDBDataset; + Bio: TADOTable; + BioSource: TDataSource; + BioDS: TfrxDBDataset; + Country: TADOTable; + CountrySource: TDataSource; + CountryDS: TfrxDBDataset; + Cross: TADOTable; + CrossSource: TDataSource; + CrossDS: TfrxDBDataset; + ADOConnection1: TADOConnection; + RepQueryaCustNo: TFloatField; + RepQueryCompany: TWideStringField; + RepQueryAddr1: TWideStringField; + RepQueryAddr2: TWideStringField; + RepQueryCity: TWideStringField; + RepQueryState: TWideStringField; + RepQueryZip: TWideStringField; + RepQueryCountry: TWideStringField; + RepQueryPhone: TWideStringField; + RepQueryFAX: TWideStringField; + RepQueryaTaxRate: TFloatField; + RepQueryContact: TWideStringField; + RepQueryLastInvoiceDate: TDateTimeField; + RepQuerybOrderNo: TFloatField; + RepQuerybCustNo: TFloatField; + RepQuerySaleDate: TDateTimeField; + RepQueryShipDate: TDateTimeField; + RepQueryEmpNo: TIntegerField; + RepQueryShipToContact: TWideStringField; + RepQueryShipToAddr1: TWideStringField; + RepQueryShipToAddr2: TWideStringField; + RepQueryShipToCity: TWideStringField; + RepQueryShipToState: TWideStringField; + RepQueryShipToZip: TWideStringField; + RepQueryShipToCountry: TWideStringField; + RepQueryShipToPhone: TWideStringField; + RepQueryShipVIA: TWideStringField; + RepQueryPO: TWideStringField; + RepQueryTerms: TWideStringField; + RepQueryPaymentMethod: TWideStringField; + RepQueryItemsTotal: TFloatField; + RepQuerybTaxRate: TFloatField; + RepQueryFreight: TFloatField; + RepQueryAmountPaid: TFloatField; + RepQuerycOrderNo: TFloatField; + RepQueryItemNo: TFloatField; + RepQuerycPartNo: TFloatField; + RepQueryQty: TIntegerField; + RepQueryDiscount: TFloatField; + RepQuerydPartNo: TFloatField; + RepQueryVendorNo: TFloatField; + RepQueryDescription: TWideStringField; + RepQueryOnHand: TFloatField; + RepQueryOnOrder: TFloatField; + RepQueryCost: TFloatField; + RepQueryListPrice: TFloatField; + procedure DataModuleCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + ReportData: TReportData; + +implementation + +{$R *.DFM} + +procedure TReportData.DataModuleCreate(Sender: TObject); +begin +// Cross.DatabaseName := ExtractFilePath(Application.ExeName); + ADOConnection1.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + ExtractFilePath(Application.ExeName) + 'demo.mdb'; + ADOConnection1.Open; +end; + +end. diff --git a/official/4.8.11/Demos/Main/crosstest.db b/official/4.8.11/Demos/Main/crosstest.db new file mode 100644 index 0000000..1865ed1 Binary files /dev/null and b/official/4.8.11/Demos/Main/crosstest.db differ diff --git a/official/4.8.11/Demos/Main/demo.mdb b/official/4.8.11/Demos/Main/demo.mdb new file mode 100644 index 0000000..d959714 Binary files /dev/null and b/official/4.8.11/Demos/Main/demo.mdb differ diff --git a/official/4.8.11/Demos/MasterDetailUDS/Project1.dpr b/official/4.8.11/Demos/MasterDetailUDS/Project1.dpr new file mode 100644 index 0000000..08b344c --- /dev/null +++ b/official/4.8.11/Demos/MasterDetailUDS/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/MasterDetailUDS/Project1.res b/official/4.8.11/Demos/MasterDetailUDS/Project1.res new file mode 100644 index 0000000..1228533 Binary files /dev/null and b/official/4.8.11/Demos/MasterDetailUDS/Project1.res differ diff --git a/official/4.8.11/Demos/MasterDetailUDS/Unit1.dfm b/official/4.8.11/Demos/MasterDetailUDS/Unit1.dfm new file mode 100644 index 0000000..fadf0d7 --- /dev/null +++ b/official/4.8.11/Demos/MasterDetailUDS/Unit1.dfm @@ -0,0 +1,132 @@ +object Form1: TForm1 + Left = 272 + Top = 220 + Width = 244 + Height = 166 + Caption = 'Master-Detail demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + PixelsPerInch = 96 + TextHeight = 13 + object BitBtn1: TBitBtn + Left = 80 + Top = 56 + Width = 75 + Height = 25 + Caption = 'Run!' + TabOrder = 0 + OnClick = BitBtn1Click + end + object frxReport1: TfrxReport + Version = '4.0a' + DotMatrixReport = False + IniFile = '\Software\Fast Reports' + PreviewOptions.Buttons = [pbPrint, pbLoad, pbSave, pbExport, pbZoom, pbFind, pbOutline, pbPageSetup, pbTools, pbEdit, pbNavigator, pbExportQuick] + PreviewOptions.Zoom = 1 + PrintOptions.Printer = 'Default' + PrintOptions.PrintOnSheet = 0 + ReportOptions.CreateDate = 38806.5953306944 + ReportOptions.LastChange = 38806.5953306944 + ScriptLanguage = 'PascalScript' + ScriptText.Strings = ( + 'begin' + '' + 'end.') + Left = 4 + Top = 12 + Datasets = < + item + DataSet = DetailDS + DataSetName = 'DetailDS' + end + item + DataSet = MasterDS + DataSetName = 'MasterDS' + end> + Variables = <> + Style = <> + object Page1: TfrxReportPage + PaperWidth = 210 + PaperHeight = 297 + PaperSize = 9 + LeftMargin = 10 + RightMargin = 10 + TopMargin = 10 + BottomMargin = 10 + object MasterData1: TfrxMasterData + Height = 20 + Top = 18.89765 + Width = 718.1107 + DataSet = MasterDS + DataSetName = 'MasterDS' + RowCount = 0 + object Memo1: TfrxMemoView + Width = 260 + Height = 20 + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlack + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [fsBold] + Frame.Typ = [ftLeft, ftRight, ftTop, ftBottom] + Memo.UTF8 = ( + '[MasterDS."name"]') + ParentFont = False + end + end + object DetailData1: TfrxDetailData + Height = 20 + Top = 60.47248 + Width = 718.1107 + DataSet = DetailDS + DataSetName = 'DetailDS' + RowCount = 0 + object Memo2: TfrxMemoView + Left = 24 + Width = 236 + Height = 20 + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlack + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [fsBold] + Frame.Typ = [ftLeft, ftRight, ftTop, ftBottom] + Memo.UTF8 = ( + '[DetailDS."name"]') + ParentFont = False + end + end + end + end + object MasterDS: TfrxUserDataSet + UserName = 'MasterDS' + OnCheckEOF = MasterDSCheckEOF + OnFirst = MasterDSFirst + OnNext = MasterDSNext + OnPrior = MasterDSPrior + Fields.Strings = ( + 'name') + OnGetValue = MasterDSGetValue + Left = 40 + Top = 12 + end + object DetailDS: TfrxUserDataSet + UserName = 'DetailDS' + OnCheckEOF = DetailDSCheckEOF + OnFirst = DetailDSFirst + OnNext = DetailDSNext + OnPrior = DetailDSPrior + Fields.Strings = ( + 'mas_id' + 'name') + OnGetValue = DetailDSGetValue + Left = 76 + Top = 12 + end +end diff --git a/official/4.8.11/Demos/MasterDetailUDS/Unit1.pas b/official/4.8.11/Demos/MasterDetailUDS/Unit1.pas new file mode 100644 index 0000000..4c9acfe --- /dev/null +++ b/official/4.8.11/Demos/MasterDetailUDS/Unit1.pas @@ -0,0 +1,114 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Buttons, frxClass; + +type + TForm1 = class(TForm) + MasterDS: TfrxUserDataSet; + DetailDS: TfrxUserDataSet; + BitBtn1: TBitBtn; + frxReport1: TfrxReport; + procedure MasterDSFirst(Sender: TObject); + procedure MasterDSNext(Sender: TObject); + procedure MasterDSPrior(Sender: TObject); + procedure MasterDSCheckEOF(Sender: TObject; var Eof: Boolean); + procedure MasterDSGetValue(const VarName: String; var Value: Variant); + procedure DetailDSCheckEOF(Sender: TObject; var Eof: Boolean); + procedure DetailDSFirst(Sender: TObject); + procedure DetailDSGetValue(const VarName: String; var Value: Variant); + procedure DetailDSNext(Sender: TObject); + procedure DetailDSPrior(Sender: TObject); + procedure BitBtn1Click(Sender: TObject); + private + MasterNo: Integer; + DetailNo: Integer; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +const + Master: array[1..3, 1..2] of ShortString = ( // master Id, master name + ('1', 'master 1'), + ('2', 'master 2'), + ('3', 'master 3')); + Detail: array[1..15, 1..2] of ShortString = ( // master Id, detail name + ('1', 'detail 1.1'), ('1', 'detail 1.2'), ('1', 'detail 1.3'), + ('1', 'detail 1.4'), ('1', 'detail 1.5'), ('2', 'detail 2.1'), + ('2', 'detail 2.2'), ('2', 'detail 2.3'), ('2', 'detail 2.4'), + ('2', 'detail 2.5'), ('3', 'detail 3.1'), ('3', 'detail 3.2'), + ('3', 'detail 3.3'), ('3', 'detail 3.4'), ('3', 'detail 3.5')); + + +procedure TForm1.MasterDSFirst(Sender: TObject); +begin + MasterNo := 1; +end; + +procedure TForm1.MasterDSNext(Sender: TObject); +begin + Inc(MasterNo); +end; + +procedure TForm1.MasterDSPrior(Sender: TObject); +begin + Dec(MasterNo); +end; + +procedure TForm1.MasterDSCheckEOF(Sender: TObject; var Eof: Boolean); +begin + Eof := MasterNo > High(Master); +end; + +procedure TForm1.MasterDSGetValue(const VarName: String; var Value: Variant); +begin + Value := Master[MasterNo][2]; +end; + +procedure TForm1.DetailDSFirst(Sender: TObject); +begin + DetailNo := 1; + while (not DetailDS.Eof) and (Detail[DetailNo][1] <> Master[MasterNo][1]) do + Inc(DetailNo); +end; + +procedure TForm1.DetailDSNext(Sender: TObject); +begin + Inc(DetailNo); + while (not DetailDS.Eof) and (Detail[DetailNo][1] <> Master[MasterNo][1]) do + Inc(DetailNo); +end; + +procedure TForm1.DetailDSPrior(Sender: TObject); +begin + Dec(DetailNo); + while (DetailNo > 1) and (Detail[DetailNo][1] <> Master[MasterNo][1]) do + Dec(DetailNo); +end; + +procedure TForm1.DetailDSCheckEOF(Sender: TObject; var Eof: Boolean); +begin + Eof := DetailNo > High(Detail); +end; + +procedure TForm1.DetailDSGetValue(const VarName: String; var Value: Variant); +begin + Value := Detail[DetailNo][2]; +end; + +procedure TForm1.BitBtn1Click(Sender: TObject); +begin + frxReport1.ShowReport(); +end; + +end. diff --git a/official/4.8.11/Demos/PrintArray/Project1.dpr b/official/4.8.11/Demos/PrintArray/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/PrintArray/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/PrintArray/Project1.res b/official/4.8.11/Demos/PrintArray/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/PrintArray/Project1.res differ diff --git a/official/4.8.11/Demos/PrintArray/Unit1.dfm b/official/4.8.11/Demos/PrintArray/Unit1.dfm new file mode 100644 index 0000000..18df611 Binary files /dev/null and b/official/4.8.11/Demos/PrintArray/Unit1.dfm differ diff --git a/official/4.8.11/Demos/PrintArray/Unit1.pas b/official/4.8.11/Demos/PrintArray/Unit1.pas new file mode 100644 index 0000000..b5d3953 --- /dev/null +++ b/official/4.8.11/Demos/PrintArray/Unit1.pas @@ -0,0 +1,45 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls; + +type + TForm1 = class(TForm) + Button1: TButton; + ArrayDS: TfrxUserDataSet; + frxReport1: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure frxReport1GetValue(VarName: String; var Value: Variant); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +var + ar: array[0..9] of Integer = (0,1,2,3,4,5,6,7,8,9); + +procedure TForm1.Button1Click(Sender: TObject); +begin + ArrayDS.RangeEnd := reCount; + ArrayDS.RangeEndCount := 10; + frxReport1.ShowReport; +end; + +procedure TForm1.frxReport1GetValue(VarName: String; var Value: Variant); +begin + if CompareText(VarName, 'element') = 0 then + Value := ar[ArrayDS.RecNo]; +end; + +end. diff --git a/official/4.8.11/Demos/PrintFile/Project1.dpr b/official/4.8.11/Demos/PrintFile/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/PrintFile/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/PrintFile/Project1.res b/official/4.8.11/Demos/PrintFile/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/PrintFile/Project1.res differ diff --git a/official/4.8.11/Demos/PrintFile/Unit1.dfm b/official/4.8.11/Demos/PrintFile/Unit1.dfm new file mode 100644 index 0000000..d221ca5 Binary files /dev/null and b/official/4.8.11/Demos/PrintFile/Unit1.dfm differ diff --git a/official/4.8.11/Demos/PrintFile/Unit1.pas b/official/4.8.11/Demos/PrintFile/Unit1.pas new file mode 100644 index 0000000..90c23dd --- /dev/null +++ b/official/4.8.11/Demos/PrintFile/Unit1.pas @@ -0,0 +1,49 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls; + +type + TForm1 = class(TForm) + Button1: TButton; + frxReport1: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure frxReport1GetValue(VarName: String; var Value: Variant); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +var + ar: array[0..9] of Integer = (0,1,2,3,4,5,6,7,8,9); + +procedure TForm1.Button1Click(Sender: TObject); +begin + frxReport1.ShowReport; +end; + +procedure TForm1.frxReport1GetValue(VarName: String; var Value: Variant); +var + sl: TStringList; +begin + if CompareText(VarName, 'file') = 0 then + begin + sl := TStringList.Create; + sl.LoadFromFile('unit1.pas'); + Value := sl.Text; + sl.Free; + end; +end; + +end. diff --git a/official/4.8.11/Demos/PrintStringGrid/Project1.dpr b/official/4.8.11/Demos/PrintStringGrid/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/PrintStringGrid/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/PrintStringGrid/Project1.res b/official/4.8.11/Demos/PrintStringGrid/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/PrintStringGrid/Project1.res differ diff --git a/official/4.8.11/Demos/PrintStringGrid/Unit1.dfm b/official/4.8.11/Demos/PrintStringGrid/Unit1.dfm new file mode 100644 index 0000000..eb34965 Binary files /dev/null and b/official/4.8.11/Demos/PrintStringGrid/Unit1.dfm differ diff --git a/official/4.8.11/Demos/PrintStringGrid/Unit1.pas b/official/4.8.11/Demos/PrintStringGrid/Unit1.pas new file mode 100644 index 0000000..94899d1 --- /dev/null +++ b/official/4.8.11/Demos/PrintStringGrid/Unit1.pas @@ -0,0 +1,59 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls, Grids, frxCross; + +type + TForm1 = class(TForm) + Button1: TButton; + StringGrid1: TStringGrid; + frxCrossObject1: TfrxCrossObject; + frxReport1: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure frxReport1BeforePrint(c: TfrxReportComponent); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +procedure TForm1.FormCreate(Sender: TObject); +var + i, j: Integer; +begin + for i := 1 to 16 do + for j := 1 to 16 do + StringGrid1.Cells[i - 1, j - 1] := IntToStr(i * j); +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + frxReport1.ShowReport; +end; + +procedure TForm1.frxReport1BeforePrint(c: TfrxReportComponent); +var + Cross: TfrxCrossView; + i, j: Integer; +begin + if c is TfrxCrossView then + begin + Cross := TfrxCrossView(c); + for i := 1 to 16 do + for j := 1 to 16 do + Cross.AddValue([i], [j], [StringGrid1.Cells[i - 1, j - 1]]); + end; +end; + +end. diff --git a/official/4.8.11/Demos/PrintStringList/Project1.dpr b/official/4.8.11/Demos/PrintStringList/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/PrintStringList/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/PrintStringList/Project1.res b/official/4.8.11/Demos/PrintStringList/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/PrintStringList/Project1.res differ diff --git a/official/4.8.11/Demos/PrintStringList/Unit1.dfm b/official/4.8.11/Demos/PrintStringList/Unit1.dfm new file mode 100644 index 0000000..a0480f8 Binary files /dev/null and b/official/4.8.11/Demos/PrintStringList/Unit1.dfm differ diff --git a/official/4.8.11/Demos/PrintStringList/Unit1.pas b/official/4.8.11/Demos/PrintStringList/Unit1.pas new file mode 100644 index 0000000..5c379c3 --- /dev/null +++ b/official/4.8.11/Demos/PrintStringList/Unit1.pas @@ -0,0 +1,58 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls; + +type + TForm1 = class(TForm) + Button1: TButton; + StringDS: TfrxUserDataSet; + frxReport1: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure frxReport1GetValue(const VarName: String; var Value: Variant); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + sl: TStringList; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +procedure TForm1.FormCreate(Sender: TObject); +begin + sl := TStringList.Create; + sl.Add('1'); + sl.Add('2'); + sl.Add('3'); + sl.Add('4'); + sl.Add('5'); + sl.Add('6'); + sl.Add('7'); + sl.Add('8'); + sl.Add('9'); +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + StringDS.RangeEnd := reCount; + StringDS.RangeEndCount := sl.Count; + frxReport1.ShowReport; +end; + +procedure TForm1.frxReport1GetValue(const VarName: String; var Value: Variant); +begin + if CompareText(VarName, 'element') = 0 then + Value := sl[StringDS.RecNo]; +end; + +end. diff --git a/official/4.8.11/Demos/PrintTable/Project1.dpr b/official/4.8.11/Demos/PrintTable/Project1.dpr new file mode 100644 index 0000000..79c301d --- /dev/null +++ b/official/4.8.11/Demos/PrintTable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Demos/PrintTable/Project1.res b/official/4.8.11/Demos/PrintTable/Project1.res new file mode 100644 index 0000000..6d7afb5 Binary files /dev/null and b/official/4.8.11/Demos/PrintTable/Project1.res differ diff --git a/official/4.8.11/Demos/PrintTable/Unit1.dfm b/official/4.8.11/Demos/PrintTable/Unit1.dfm new file mode 100644 index 0000000..301a481 Binary files /dev/null and b/official/4.8.11/Demos/PrintTable/Unit1.dfm differ diff --git a/official/4.8.11/Demos/PrintTable/Unit1.pas b/official/4.8.11/Demos/PrintTable/Unit1.pas new file mode 100644 index 0000000..e2b1d57 --- /dev/null +++ b/official/4.8.11/Demos/PrintTable/Unit1.pas @@ -0,0 +1,57 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, StdCtrls, frxCross, Db, DBTables; + +type + TForm1 = class(TForm) + Button1: TButton; + frxCrossObject1: TfrxCrossObject; + Table1: TTable; + frxReport1: TfrxReport; + procedure Button1Click(Sender: TObject); + procedure frxReport1BeforePrint(c: TfrxReportComponent); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} + +procedure TForm1.Button1Click(Sender: TObject); +begin + frxReport1.ShowReport; +end; + +procedure TForm1.frxReport1BeforePrint(c: TfrxReportComponent); +var + Cross: TfrxCrossView; + i, j: Integer; +begin + if c is TfrxCrossView then + begin + Cross := TfrxCrossView(c); + + Table1.First; + i := 0; + while not Table1.Eof do + begin + for j := 0 to Table1.Fields.Count - 1 do + Cross.AddValue([i], [Table1.Fields[j].DisplayLabel], [Table1.Fields[j].AsString]); + + Table1.Next; + Inc(i); + end; + end; +end; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Main.dfm b/official/4.8.11/Extra/New DB Engine/Main.dfm new file mode 100644 index 0000000..1f71b9d Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Main.dfm differ diff --git a/official/4.8.11/Extra/New DB Engine/Main.pas b/official/4.8.11/Extra/New DB Engine/Main.pas new file mode 100644 index 0000000..6c8719a --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Main.pas @@ -0,0 +1,202 @@ +unit Main; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls; + +type + TForm1 = class(TForm) + Label1: TLabel; + Label2: TLabel; + AbbrE: TEdit; + Label3: TLabel; + Label4: TLabel; + TableE: TEdit; + QueryE: TEdit; + DatabaseE: TEdit; + Button1: TButton; + Button2: TButton; + Bevel1: TBevel; + Label5: TLabel; + Label6: TLabel; + Label7: TLabel; + Label8: TLabel; + UnitsE: TEdit; + CopyrightM: TMemo; + Label9: TLabel; + Label10: TLabel; + CommentsM: TMemo; + Label11: TLabel; + PackageE: TEdit; + procedure Button1Click(Sender: TObject); + procedure AbbrEExit(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.DFM} +{$I-} + +type + PCharArray = ^TCharArray; + TCharArray = Array[0..32767] of Char; + +procedure TForm1.Button1Click(Sender: TObject); +var + BaseDir, NewDir: String; + SearchRec: TSearchRec; + r: Word; + mem: PCharArray; + memSize: Integer; + + procedure Replace(sFrom, sTo: String); + var + i, j: Integer; + Flag: Boolean; + begin + while Pos('?', sFrom) <> 0 do + sFrom[Pos('?', sFrom)] := #0; + i := 0; + while i < memSize do + begin + Flag := True; + for j := 1 to Length(sFrom) do + if AnsiCompareText(mem^[i + j - 1], sFrom[j]) <> 0 then + begin + Flag := False; + break; + end; + if Flag then + begin + Move((PChar(mem) + i + Length(sFrom))^, + (PChar(mem) + i + Length(sTo))^, memSize - (i + Length(sFrom))); + for j := 1 to Length(sTo) do + mem^[i + j - 1] := sTo[j]; + Inc(memSize, Length(sTo) - Length(sFrom)); + end; + Inc(i); + end; + end; + + procedure ProcessFile(s: String); + var + n: Integer; + stm: TMemoryStream; + stm1: TFileStream; + + function MakeTwoChar(s: String): String; + var + i: Integer; + begin + Result := ''; + for i := 1 to Length(s) do + Result := Result + s[i] + #0; + end; + + function GetCopyText: String; + var + i: Integer; + begin + Result := ''; + for i := 0 to CopyrightM.Lines.Count - 1 do + Result := Result + '// ' + CopyrightM.Lines[i] + #13#10; + end; + + begin + stm := TMemoryStream.Create; + stm.LoadFromFile(BaseDir + '\' + s); + FillChar(mem^, 32768, 0); + Move(stm.Memory^, mem^, stm.Size); + memSize := stm.Size; + + // components + Replace('TXXXTable', TableE.Text); + Replace('TXXXQuery', QueryE.Text); + Replace('TXXXDatabase', DatabaseE.Text); + // units + Replace('UXXX', UnitsE.Text); + // package + Replace('PXXX', PackageE.Text); + // dcr + Replace('F?R?X?X?X?X?', MakeTwoChar('FRX' + AbbrE.Text)); + // other + Replace('frxXXX', 'frx' + AbbrE.Text); + Replace('XXX', AbbrE.Text); + Replace('// Copyright', GetCopyText); + Replace('IdCopyright', CopyrightM.Lines.Text); + Replace('IdComments', CommentsM.Lines.Text); + + n := Pos('FRXXXX', AnsiUpperCase(s)); + if n <> 0 then + begin + Delete(s, n, 6); + Insert('frx' + AbbrE.Text, s, n); + end; + stm1 := TFileStream.Create(NewDir + '\' + s, fmCreate); + stm1.Write(mem^, memSize); + stm1.Free; + + stm.Free; + end; + +begin + if (Trim(AbbrE.Text) = '') or (Trim(TableE.Text) = '') or + (Trim(QueryE.Text) = '') or (Trim(DatabaseE.Text) = '') or + (Trim(UnitsE.Text) = '') or (Trim(PackageE.Text) = '') then + begin + MessageBox(0, PChar('You should fill all fields!'), PChar('Error'), + mb_OK + mb_IconError); + AbbrE.SetFocus; + Exit; + end; + + SetCurrentDir(ExtractFilePath(ParamStr(0))); + BaseDir := GetCurrentDir + '\Template'; + ChDir('..'); + NewDir := GetCurrentDir + '\' + AbbrE.Text; + New(mem); + +// make dir + MkDir(NewDir); + +// processing files + R := FindFirst(BaseDir + '\*.*', faAnyFile, SearchRec); + while R = 0 do + begin + if (SearchRec.Attr and faDirectory) = 0 then + ProcessFile(SearchRec.Name); + R := FindNext(SearchRec); + end; + FindClose(SearchRec); + + Dispose(mem); + + MessageBox(0, PChar('Files are converted and placed in the ' + + NewDir + ' folder.'), '', mb_OK + mb_IconInformation); + Close; +end; + +procedure TForm1.AbbrEExit(Sender: TObject); +begin + if AbbrE.Text = '' then Exit; + TableE.Text := 'T' + AbbrE.Text + 'Table'; + QueryE.Text := 'T' + AbbrE.Text + 'Query'; + DatabaseE.Text := 'T' + AbbrE.Text + 'Database'; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + Close; +end; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/NewEngine.dpr b/official/4.8.11/Extra/New DB Engine/NewEngine.dpr new file mode 100644 index 0000000..d9ecaad --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/NewEngine.dpr @@ -0,0 +1,13 @@ +program NewEngine; + +uses + Forms, + Main in 'Main.pas' {Form1}; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/official/4.8.11/Extra/New DB Engine/NewEngine.res b/official/4.8.11/Extra/New DB Engine/NewEngine.res new file mode 100644 index 0000000..c832058 Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/NewEngine.res differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX4.dpk b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX4.dpk new file mode 100644 index 0000000..d42154b --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX4.dpk @@ -0,0 +1,38 @@ +// Package file for Delphi 4 + +package dclfrxXXX4; + +{$R 'frxXXXReg.dcr'} +{$DESCRIPTION 'FastReport 3.0 XXX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + frxXXX4; + +contains + frxXXXReg in 'frxXXXReg.pas'; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX5.dpk b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX5.dpk new file mode 100644 index 0000000..2b8265d --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX5.dpk @@ -0,0 +1,38 @@ +// Package file for Delphi 5 + +package dclfrxXXX5; + +{$R 'frxXXXReg.dcr'} +{$DESCRIPTION 'FastReport 3.0 XXX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + frxXXX5; + +contains + frxXXXReg in 'frxXXXReg.pas'; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX6.dpk b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX6.dpk new file mode 100644 index 0000000..e00f322 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX6.dpk @@ -0,0 +1,39 @@ +// Package file for Delphi 6 + +package dclfrxXXX6; + +{$R 'frxXXXReg.dcr'} +{$DESCRIPTION 'FastReport 3.0 XXX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + frxXXX6; + +contains + frxXXXReg in 'frxXXXReg.pas'; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX7.dpk b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX7.dpk new file mode 100644 index 0000000..b52d81a --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX7.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 7 + +package dclfrxXXX7; + +{$R 'frxXXXReg.dcr'} +{$DESCRIPTION 'FastReport 3.0 XXX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + frxXXX7; + +contains + frxXXXReg in 'frxXXXReg.pas'; + + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.bdsproj b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.bdsproj new file mode 100644 index 0000000..f9ecffb --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + dclfrxXXX9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastReport 3.0 Components + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.dpk b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.dpk new file mode 100644 index 0000000..60d4955 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/dclfrxXXX9.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2005 + +package dclfrxXXX9; + +{$R 'frxXXXReg.dcr'} +{$DESCRIPTION 'FastReport 3.0 XXX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + frxXXX9; + +contains + frxXXXReg in 'frxXXXReg.pas'; + + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/file_id.diz b/official/4.8.11/Extra/New DB Engine/Template/file_id.diz new file mode 100644 index 0000000..a5c17f8 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/file_id.diz @@ -0,0 +1,3 @@ +IdComments + +IdCopyright \ No newline at end of file diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.bpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.bpk new file mode 100644 index 0000000..793756c --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.bpk @@ -0,0 +1,189 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = frxXXX4.bpl +OBJFILES = frxXXXReg.obj frxXXX4.obj +RESFILES = frxXXX4.res frxXXXReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +LIBRARIES = +SPARELIBS = VCL40.lib +PACKAGES = vcl40.bpi vcldb40.bpi PXXX40.bpi frx4.bpi frxDB4.bpi fs4.bpi fqb40.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release;..\;..\..\FastScript;..\..\FastQB +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -D"FastReport 3.0 XXX Components" -aa \ + -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.cpp b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.cpp new file mode 100644 index 0000000..b2b7a42 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.cpp @@ -0,0 +1,23 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("frxXXX4.res"); +USEPACKAGE("vcl40.bpi"); +USEUNIT("frxXXXReg.pas"); +USERES("frxXXXReg.dcr"); +USEPACKAGE("vcldb40.bpi"); +USEPACKAGE("PXXX40.bpi"); +USEPACKAGE("frx4.bpi"); +USEPACKAGE("frxDB4.bpi"); +USEPACKAGE("fs4.bpi"); +USEPACKAGE("fqb40.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.dpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.dpk new file mode 100644 index 0000000..65001c7 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.dpk @@ -0,0 +1,47 @@ +// Package file for Delphi 4 + +package frxXXX4; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + VCLDB40, + PXXX40, + frx4, + frxDB4, +{$IFDEF QBUILDER} + fqb40, +{$ENDIF} + fs4; + +contains + frxXXXComponents in 'frxXXXComponents.pas', + frxXXXEditor in 'frxXXXEditor.pas', + frxXXXRTTI in 'frxXXXRTTI.pas'; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.res b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.res new file mode 100644 index 0000000..eb2597a Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Template/frxXXX4.res differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.bpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.bpk new file mode 100644 index 0000000..a1f8fc6 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.bpk @@ -0,0 +1,92 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + + \ No newline at end of file diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.cpp b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.cpp new file mode 100644 index 0000000..88b89f8 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.cpp @@ -0,0 +1,27 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("frxBDE5.res"); +USEPACKAGE("vcl50.bpi"); +USEUNIT("frxXXXReg.pas"); +USERES("frxXXXReg.dcr"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("PXXX50.bpi"); +USEPACKAGE("frx5.bpi"); +USEPACKAGE("frxDB5.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("fqb50.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.dpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.dpk new file mode 100644 index 0000000..db72b8d --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.dpk @@ -0,0 +1,47 @@ +// Package file for Delphi 5 + +package frxXXX5; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLDB50, + PXXX50, + frx5, + frxDB5, +{$IFDEF QBUILDER} + fqb50, +{$ENDIF} + fs5; + +contains + frxXXXComponents in 'frxXXXComponents.pas', + frxXXXEditor in 'frxXXXEditor.pas', + frxXXXRTTI in 'frxXXXRTTI.pas'; + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.res b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.res new file mode 100644 index 0000000..da3d366 Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Template/frxXXX5.res differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.bpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.bpk new file mode 100644 index 0000000..261f387 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.bpk @@ -0,0 +1,148 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=2 +Item0=$(BCB)\Projects;$(BCB)\include;$(BCB)\include\vcl;..\ +Item1=$(BCB)\Projects;..\..\FR\SOURCE\ADO;$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=2 +Item0=$(BCB)\Projects;$(BCB)\lib\obj;$(BCB)\lib;..\ +Item1=$(BCB)\Projects;..\..\FR\SOURCE\ADO;$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[HistoryLists\hlConditionals] +Count=1 +Item0=_DEBUG + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.cpp b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.dpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.dpk new file mode 100644 index 0000000..4770ce9 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 6 + +package frxXXX6; + +{$I frx.inc} + +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + PXXX60, + frx6, + frxDB6, +{$IFDEF QBUILDER} + fqb60, +{$ENDIF} + fs6; + +contains + frxXXXComponents in 'frxXXXComponents.pas', + frxXXXEditor in 'frxXXXEditor.pas', + frxXXXRTTI in 'frxXXXRTTI.pas'; + + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.res b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.res new file mode 100644 index 0000000..2bbdbc1 Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Template/frxXXX6.res differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX7.dpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX7.dpk new file mode 100644 index 0000000..3a14558 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX7.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 7 + +package frxXXX7; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + PXXX70, + frx7, + frxDB7, +{$IFDEF QBUILDER} + fqb70, +{$ENDIF} + fs7; + +contains + frxXXXComponents in 'frxXXXComponents.pas', + frxXXXEditor in 'frxXXXEditor.pas', + frxXXXRTTI in 'frxXXXRTTI.pas'; + + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.bdsproj b/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.bdsproj new file mode 100644 index 0000000..f21e329 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + frxXXX9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.dpk b/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.dpk new file mode 100644 index 0000000..6a761bc --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXX9.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 2005 + +package frxXXX9; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + PXXX90, + frx9, + frxDB9, +{$IFDEF QBUILDER} + fqb90, +{$ENDIF} + fs9; + +contains + frxXXXComponents in 'frxXXXComponents.pas', + frxXXXEditor in 'frxXXXEditor.pas', + frxXXXRTTI in 'frxXXXRTTI.pas'; + + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.pas b/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.pas new file mode 100644 index 0000000..d96e46b --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.pas @@ -0,0 +1,497 @@ + +{******************************************} +{ } +{ FastReport v3.0 } +{ XXX enduser components } +{ } + +// Copyright +{ } +{******************************************} + +unit frxXXXComponents; + +interface + +{$I frx.inc} + +uses + Windows, Classes, frxClass, frxCustomDB, DB, UXXX +{$IFDEF Delphi6} +, Variants +{$ENDIF} +{$IFDEF QBUILDER} +, fqbClass +{$ENDIF}; + + +type + TfrxXXXComponents = class(TfrxDBComponents) + private + FDefaultDatabase: TXXXDatabase; + FOldComponents: TfrxXXXComponents; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function GetDescription: String; override; + published + property DefaultDatabase: TXXXDatabase read FDefaultDatabase write FDefaultDatabase; + end; + + TfrxXXXDatabase = class(TfrxCustomDatabase) + private + FDatabase: TXXXDatabase; + protected + procedure SetConnected(Value: Boolean); override; + procedure SetDatabaseName(const Value: String); override; + procedure SetLoginPrompt(Value: Boolean); override; + procedure SetParams(Value: TStrings); override; + function GetConnected: Boolean; override; + function GetDatabaseName: String; override; + function GetLoginPrompt: Boolean; override; + function GetParams: TStrings; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + class function GetDescription: String; override; + procedure SetLogin(const Login, Password: String); override; + property Database: TXXXDatabase read FDatabase; + published + property DatabaseName; + property LoginPrompt; + property Params; + property Connected; + end; + + TfrxXXXTable = class(TfrxCustomTable) + private + FDatabase: TfrxXXXDatabase; + FTable: TXXXTable; + procedure SetDatabase(const Value: TfrxXXXDatabase); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure SetMaster(const Value: TDataSource); override; + procedure SetMasterFields(const Value: String); override; + procedure SetIndexFieldNames(const Value: String); override; + procedure SetIndexName(const Value: String); override; + procedure SetTableName(const Value: String); override; + function GetIndexFieldNames: String; override; + function GetIndexName: String; override; + function GetTableName: String; override; + public + constructor Create(AOwner: TComponent); override; + constructor DesignCreate(AOwner: TComponent; Flags: Word); override; + class function GetDescription: String; override; + procedure BeforeStartReport; override; + property Table: TXXXTable read FTable; + published + property Database: TfrxXXXDatabase read FDatabase write SetDatabase; + end; + + TfrxXXXQuery = class(TfrxCustomQuery) + private + FDatabase: TfrxXXXDatabase; + FQuery: TXXXQuery; + procedure SetDatabase(const Value: TfrxXXXDatabase); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure SetMaster(const Value: TDataSource); override; + procedure SetSQL(Value: TStrings); override; + function GetSQL: TStrings; override; + public + constructor Create(AOwner: TComponent); override; + constructor DesignCreate(AOwner: TComponent; Flags: Word); override; + class function GetDescription: String; override; + procedure BeforeStartReport; override; + procedure UpdateParams; override; +{$IFDEF QBUILDER} + function QBEngine: TfqbEngine; override; +{$ENDIF} + property Query: TXXXQuery read FQuery; + published + property Database: TfrxXXXDatabase read FDatabase write SetDatabase; + end; + +{$IFDEF QBUILDER} + TfrxEngineXXX = class(TfqbEngine) + private + FQuery: TXXXQuery; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure ReadTableList(ATableList: TStrings); override; + procedure ReadFieldList(const ATableName: string; var AFieldList: TfqbFieldList); override; + function ResultDataSet: TDataSet; override; + procedure SetSQL(const Value: string); override; + end; +{$ENDIF} + + +var + XXXComponents: TfrxXXXComponents; + + +implementation + +{$R *.res} + +uses + frxXXXRTTI, +{$IFNDEF NO_EDITORS} + frxXXXEditor, +{$ENDIF} + frxDsgnIntf, frxRes; + + +{ TfrxXXXComponents } + +constructor TfrxXXXComponents.Create(AOwner: TComponent); +begin + inherited; + FOldComponents := XXXComponents; + XXXComponents := Self; +end; + +destructor TfrxXXXComponents.Destroy; +begin + if XXXComponents = Self then + XXXComponents := FOldComponents; + inherited; +end; + +function TfrxXXXComponents.GetDescription: String; +begin + Result := 'XXX'; +end; + +procedure TfrxXXXComponents.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (AComponent = FDefaultDatabase) and (Operation = opRemove) then + FDefaultDatabase := nil; +end; + + + +{ TfrxXXXDatabase } + +constructor TfrxXXXDatabase.Create(AOwner: TComponent); +begin + inherited; + FDatabase := TXXXDatabase.Create(nil); + Component := FDatabase; +end; + +destructor TfrxXXXDatabase.Destroy; +begin + inherited; +end; + +class function TfrxXXXDatabase.GetDescription: String; +begin + Result := 'XXX Database'; +end; + +function TfrxXXXDatabase.GetConnected: Boolean; +begin + Result := FDatabase.Connected; +end; + +function TfrxXXXDatabase.GetDatabaseName: String; +begin + Result := FDatabase.DatabaseName; +end; + +function TfrxXXXDatabase.GetLoginPrompt: Boolean; +begin + Result := FDatabase.LoginPrompt; +end; + +function TfrxXXXDatabase.GetParams: TStrings; +begin + Result := FDatabase.Params; +end; + +procedure TfrxXXXDatabase.SetConnected(Value: Boolean); +begin + BeforeConnect(Value); + FDatabase.Connected := Value; +end; + +procedure TfrxXXXDatabase.SetDatabaseName(const Value: String); +begin + FDatabase.DatabaseName := Value; +end; + +procedure TfrxXXXDatabase.SetLoginPrompt(Value: Boolean); +begin + FDatabase.LoginPrompt := Value; +end; + +procedure TfrxXXXDatabase.SetParams(Value: TStrings); +begin + FDatabase.Params := Value; +end; + +procedure TfrxXXXDatabase.SetLogin(const Login, Password: String); +begin +// this method is used by "New connection" wizard +// for example (IBX): +// Params.Text := 'user_name=' + Login + #13#10 + 'password=' + Password; +end; + + +{ TfrxXXXTable } + +constructor TfrxXXXTable.Create(AOwner: TComponent); +begin + FTable := TXXXTable.Create(nil); + DataSet := FTable; + SetDatabase(nil); + inherited; +end; + +constructor TfrxXXXTable.DesignCreate(AOwner: TComponent; Flags: Word); +var + i: Integer; + l: TList; +begin + inherited; + l := Report.AllObjects; + for i := 0 to l.Count - 1 do + if TObject(l[i]) is TfrxXXXDatabase then + begin + SetDatabase(TfrxXXXDatabase(l[i])); + break; + end; +end; + +class function TfrxXXXTable.GetDescription: String; +begin + Result := 'XXX Table'; +end; + +procedure TfrxXXXTable.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FDatabase) then + SetDatabase(nil); +end; + +procedure TfrxXXXTable.SetDatabase(const Value: TfrxXXXDatabase); +begin + FDatabase := Value; + if Value <> nil then + FTable.Database := Value.Database + else if XXXComponents <> nil then + FTable.Database := XXXComponents.DefaultDatabase + else + FTable.Database := nil; +end; + +function TfrxXXXTable.GetIndexFieldNames: String; +begin + Result := FTable.IndexFieldNames; +end; + +function TfrxXXXTable.GetIndexName: String; +begin + Result := FTable.IndexName; +end; + +function TfrxXXXTable.GetTableName: String; +begin + Result := FTable.TableName; +end; + +procedure TfrxXXXTable.SetIndexFieldNames(const Value: String); +begin + FTable.IndexFieldNames := Value; +end; + +procedure TfrxXXXTable.SetIndexName(const Value: String); +begin + FTable.IndexName := Value; +end; + +procedure TfrxXXXTable.SetTableName(const Value: String); +begin + FTable.TableName := Value; +end; + +procedure TfrxXXXTable.SetMaster(const Value: TDataSource); +begin + FTable.MasterSource := Value; +end; + +procedure TfrxXXXTable.SetMasterFields(const Value: String); +begin + FTable.MasterFields := Value; +end; + +procedure TfrxXXXTable.BeforeStartReport; +begin + SetDatabase(FDatabase); +end; + + +{ TfrxXXXQuery } + +constructor TfrxXXXQuery.Create(AOwner: TComponent); +begin + FQuery := TXXXQuery.Create(nil); + Dataset := FQuery; + SetDatabase(nil); + inherited; +end; + +constructor TfrxXXXQuery.DesignCreate(AOwner: TComponent; Flags: Word); +var + i: Integer; + l: TList; +begin + inherited; + l := Report.AllObjects; + for i := 0 to l.Count - 1 do + if TObject(l[i]) is TfrxXXXDatabase then + begin + SetDatabase(TfrxXXXDatabase(l[i])); + break; + end; +end; + +class function TfrxXXXQuery.GetDescription: String; +begin + Result := 'XXX Query'; +end; + +procedure TfrxXXXQuery.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FDatabase) then + SetDatabase(nil); +end; + +procedure TfrxXXXQuery.SetDatabase(const Value: TfrxXXXDatabase); +begin + FDatabase := Value; + if Value <> nil then + FQuery.Database := Value.Database + else if XXXComponents <> nil then + FQuery.Database := XXXComponents.DefaultDatabase + else + FQuery.Database := nil; +end; + +function TfrxXXXQuery.GetSQL: TStrings; +begin + Result := FQuery.SQL; +end; + +procedure TfrxXXXQuery.SetSQL(Value: TStrings); +begin + FQuery.SQL := Value; +end; + +procedure TfrxXXXQuery.SetMaster(const Value: TDataSource); +begin + FQuery.DataSource := Value; +end; + +procedure TfrxXXXQuery.UpdateParams; +begin + frxParamsToTParams(Self, FQuery.Params); +end; + +procedure TfrxXXXQuery.BeforeStartReport; +begin + SetDatabase(FDatabase); +end; + +{$IFDEF QBUILDER} +function TfrxXXXQuery.QBEngine: TfqbEngine; +begin + Result := TfrxEngineXXX.Create(nil); + TfrxEngineXXX(Result).FQuery.Database := FQuery.Database; +end; +{$ENDIF} + + +{$IFDEF QBUILDER} +constructor TfrxEngineXXX.Create(AOwner: TComponent); +begin + inherited; + FQuery := TXXXQuery.Create(Self); +end; + +destructor TfrxEngineXXX.Destroy; +begin + FQuery.Free; + inherited; +end; + +procedure TfrxEngineXXX.ReadFieldList(const ATableName: string; + var AFieldList: TfqbFieldList); +var + TempTable: TXXXTable; + Fields: TFieldDefs; + i: Integer; + tmpField: TfqbField; +begin + AFieldList.Clear; + TempTable := TXXXTable.Create(Self); + TempTable.Database := FQuery.Database; + TempTable.TableName := ATableName; + Fields := TempTable.FieldDefs; + try + try + TempTable.Active := True; + tmpField:= TfqbField(AFieldList.Add); + tmpField.FieldName := '*'; + for i := 0 to Fields.Count - 1 do + begin + tmpField := TfqbField(AFieldList.Add); + tmpField.FieldName := Fields.Items[i].Name; + tmpField.FieldType := Ord(Fields.Items[i].DataType) + end; + except + end; + finally + TempTable.Free; + end; +end; + +procedure TfrxEngineXXX.ReadTableList(ATableList: TStrings); +begin + ATableList.Clear; + FQuery.Database.GetTableNames(ATableList, ShowSystemTables); +end; + +function TfrxEngineXXX.ResultDataSet: TDataSet; +begin + Result := FQuery; +end; + +procedure TfrxEngineXXX.SetSQL(const Value: string); +begin + FQuery.SQL.Text := Value; +end; +{$ENDIF} + + +initialization + frxObjects.RegisterObject1(TfrxXXXDataBase, nil, '', 'XXX', 0, 37); + frxObjects.RegisterObject1(TfrxXXXTable, nil, '', 'XXX', 0, 38); + frxObjects.RegisterObject1(TfrxXXXQuery, nil, '', 'XXX', 0, 39); + +finalization + CatBmp.Free; + frxObjects.UnRegister(TfrxXXXDataBase); + frxObjects.UnRegister(TfrxXXXTable); + frxObjects.UnRegister(TfrxXXXQuery); + + +end. \ No newline at end of file diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.res b/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.res new file mode 100644 index 0000000..5003505 Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Template/frxXXXComponents.res differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXEditor.pas b/official/4.8.11/Extra/New DB Engine/Template/frxXXXEditor.pas new file mode 100644 index 0000000..933c527 --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXXEditor.pas @@ -0,0 +1,162 @@ + +{******************************************} +{ } +{ FastReport v3.0 } +{ XXX components design editors } +{ } + +// Copyright +{ } +{******************************************} + +unit frxXXXEditor; + +interface + +{$I frx.inc} + +implementation + +uses + Windows, Classes, SysUtils, Forms, Dialogs, frxXXXComponents, frxCustomDB, + frxDsgnIntf, frxRes, UXXX +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxDatabaseNameProperty = class(TfrxStringProperty) + public + function GetAttributes: TfrxPropertyAttributes; override; + function Edit: Boolean; override; + end; + + TfrxDatabaseProperty = class(TfrxComponentProperty) + public + function GetValue: String; override; + end; + + TfrxTableNameProperty = class(TfrxStringProperty) + public + function GetAttributes: TfrxPropertyAttributes; override; + procedure GetValues; override; + procedure SetValue(const Value: String); override; + end; + + TfrxIndexNameProperty = class(TfrxStringProperty) + public + function GetAttributes: TfrxPropertyAttributes; override; + procedure GetValues; override; + end; + + +{ TfrxDatabaseNameProperty } + +function TfrxDatabaseNameProperty.GetAttributes: TfrxPropertyAttributes; +begin + Result := [paDialog]; +end; + +function TfrxDatabaseNameProperty.Edit: Boolean; +var + SaveConnected: Boolean; +begin + with TOpenDialog.Create(nil) do + begin + InitialDir := GetCurrentDir; + Filter := 'put your filter here'; + Result := Execute; + if Result then + with TfrxXXXDatabase(Component).Database do + begin + SaveConnected := Connected; + Connected := False; + DatabaseName := FileName; + Connected := SaveConnected; + end; + Free; + end; +end; + + +{ TfrxDatabaseProperty } + +function TfrxDatabaseProperty.GetValue: String; +var + db: TfrxXXXDatabase; +begin + db := TfrxXXXDatabase(GetOrdValue); + if db = nil then + begin + if (XXXComponents <> nil) and (XXXComponents.DefaultDatabase <> nil) then + Result := XXXComponents.DefaultDatabase.Name + else + Result := frxResources.Get('prNotAssigned'); + end + else + Result := inherited GetValue; +end; + + +{ TfrxTableNameProperty } + +function TfrxTableNameProperty.GetAttributes: TfrxPropertyAttributes; +begin + Result := [paMultiSelect, paValueList, paSortList]; +end; + +procedure TfrxTableNameProperty.GetValues; +begin + inherited; + with TfrxXXXTable(Component).Table do + if Database <> nil then + DataBase.GetTableNames(Values, False); +end; + +procedure TfrxTableNameProperty.SetValue(const Value: String); +begin + inherited; + Designer.UpdateDataTree; +end; + + +{ TfrxIndexProperty } + +function TfrxIndexNameProperty.GetAttributes: TfrxPropertyAttributes; +begin + Result := [paMultiSelect, paValueList]; +end; + +procedure TfrxIndexNameProperty.GetValues; +var + i: Integer; +begin + inherited; + try + with TfrxXXXTable(Component).Table do + if (TableName <> '') and (IndexDefs <> nil) then + begin + IndexDefs.Update; + for i := 0 to IndexDefs.Count - 1 do + if IndexDefs[i].Name <> '' then + Values.Add(IndexDefs[i].Name); + end; + except + end; +end; + + +initialization + frxPropertyEditors.Register(TypeInfo(String), TfrxXXXDataBase, 'DatabaseName', + TfrxDataBaseNameProperty); + frxPropertyEditors.Register(TypeInfo(TfrxXXXDatabase), TfrxXXXTable, 'Database', + TfrxDatabaseProperty); + frxPropertyEditors.Register(TypeInfo(TfrxXXXDatabase), TfrxXXXQuery, 'Database', + TfrxDatabaseProperty); + frxPropertyEditors.Register(TypeInfo(String), TfrxXXXTable, 'TableName', + TfrxTableNameProperty); + frxPropertyEditors.Register(TypeInfo(String), TfrxXXXTable, 'IndexName', + TfrxIndexNameProperty); + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXRTTI.pas b/official/4.8.11/Extra/New DB Engine/Template/frxXXXRTTI.pas new file mode 100644 index 0000000..d9e22dd --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXXRTTI.pas @@ -0,0 +1,67 @@ + +{******************************************} +{ } +{ FastReport v3.0 } +{ XXX components RTTI } +{ } + +// Copyright +{ } +{******************************************} + +unit frxXXXRTTI; + +interface + +{$I frx.inc} + +implementation + +uses + Windows, Classes, fs_iinterpreter, frxXXXComponents +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddClass(TfrxXXXDatabase, 'TfrxCustomDatabase'); + AddClass(TfrxXXXTable, 'TfrxCustomTable'); + with AddClass(TfrxXXXQuery, 'TfrxCustomQuery') do + AddMethod('procedure ExecSQL', CallMethod); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TfrxXXXQuery then + begin + if MethodName = 'EXECSQL' then + TfrxXXXQuery(Instance).Query.ExecSQL + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +end. diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.dcr b/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.dcr new file mode 100644 index 0000000..afd0cd9 Binary files /dev/null and b/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.dcr differ diff --git a/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.pas b/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.pas new file mode 100644 index 0000000..8a72a7c --- /dev/null +++ b/official/4.8.11/Extra/New DB Engine/Template/frxXXXReg.pas @@ -0,0 +1,36 @@ + +{******************************************} +{ } +{ FastReport v3.0 } +{ XXX components registration } +{ } + +// Copyright +{ } +{******************************************} + +unit frxXXXReg; + +interface + +{$I frx.inc} + +procedure Register; + +implementation + +uses + Windows, Messages, SysUtils, Classes +{$IFNDEF Delphi6} +, DsgnIntf +{$ELSE} +, DesignIntf, DesignEditors +{$ENDIF} +, frxXXXComponents; + +procedure Register; +begin + RegisterComponents('FastReport 3.0', [TfrxXXXComponents]); +end; + +end. diff --git a/official/4.8.11/Extra/res2utf8/2unicode.bat b/official/4.8.11/Extra/res2utf8/2unicode.bat new file mode 100644 index 0000000..3077b07 --- /dev/null +++ b/official/4.8.11/Extra/res2utf8/2unicode.bat @@ -0,0 +1,2 @@ +@del *.fru /s > nul +@res2utf8.exe codepages.txt > unicode_log.txt \ No newline at end of file diff --git a/official/4.8.11/Extra/res2utf8/codepages.txt b/official/4.8.11/Extra/res2utf8/codepages.txt new file mode 100644 index 0000000..9d39916 --- /dev/null +++ b/official/4.8.11/Extra/res2utf8/codepages.txt @@ -0,0 +1,32 @@ +Arabic=1256 +Brazil=1252 +Bulgarian=1251 +Catalon=1250 +Chinese=936 +Croatian=1250 +Czech=1250 +Danish=1252 +Dutch=1252 +English=1252 +Farsi=1256 +French=1252 +German=1252 +Greek=1253 +Hungarian=1250 +Indonesian=1252 +Italian=1252 +Japanese=932 +Latvian=1257 +Polish=1250 +Portuguese=1252 +Romanian=1250 +Russian=1251 +Serbian=1251 +Slovak=1250 +Slovene=1250 +Spanish=1252 +Swedish=1252 +Swiss=1252 +Taiwan=950 +Turkish=1254 +Ukrainian=1251 diff --git a/official/4.8.11/Extra/res2utf8/res2utf8.dpr b/official/4.8.11/Extra/res2utf8/res2utf8.dpr new file mode 100644 index 0000000..853a34a --- /dev/null +++ b/official/4.8.11/Extra/res2utf8/res2utf8.dpr @@ -0,0 +1,122 @@ +// Resource converter to utf-8 by Alexander Fediachov (Samuray) +// 29.11.2007 + +program res2utf8; + +{$APPTYPE CONSOLE} +{$WARN SYMBOL_PLATFORM OFF} + +uses + Windows, SysUtils, Classes, frxXML; + +var + Codepages: TStringList; + StartDir: String; + +procedure Help; +begin + WriteLn('Usage: res2utf8.exe codepages.txt'); +end; + +procedure DoConvertFile(const FileName: String; const Lang: String); +var + FoutXML: TfrxXMLDocument; + VName, Val, outname: String; + us: WideString; + j, idx: Integer; + cp: Integer; + List: TStringList; + Root: TfrxXMLItem; + +begin + List := TStringList.Create; + List.LoadFromFile(FileName); + FoutXML := TfrxXMLDocument.Create; + FoutXML.Root.Name := 'Resources'; + FoutXML.AutoIndent := True; + Root := FoutXML.Root; + outname := ChangeFileExt(FileName, '.xml'); + if FileExists(outname) then + DeleteFile(outname); + try + if Codepages.Values[UpperCase(Lang)] <> '' then + cp := StrToInt(Codepages.Values[UpperCase(Lang)]) + else + cp := 0; + FoutXML.Root.Prop['CodePage'] := IntToStr(cp); + try + for idx := 0 to List.Count - 1 do + begin + VName := List[idx]; + Val := Copy(VName, Pos('=', VName) + 1, MaxInt); + VName := Copy(VName, 1, Pos('=', VName) - 1); + if (Length(VName) = 0) or (Length(Val) = 0) then continue; + j := MultiByteToWideChar(cp, 0, PAnsiChar(Val), Length(Val), nil, 0); + SetLength(us, j); + MultiByteToWideChar(cp, 0, PAnsiChar(Val), Length(Val), PWideChar(us), j); + SetLength(Val, Length(us) * 6); + j := UnicodeToUtf8(PChar(Val), Length(us) * 6, PWideChar(us), Length(us)); + SetLength(Val, j - 1); + with Root.Add do + begin + Name := 'StrRes'; + Prop['Name'] := VName; + Prop['Text'] := frxStrToXML(Val); + end; + end; + except + on e: Exception do + WriteLn(e.Message); + end; + WriteLn(ExtractFileName(FileName) + ' -> ' + outname); + FoutXML.SaveToFile(outname); + finally + FoutXML.Free; + List.Free; + end; +end; + +procedure DoConvert(const Dir: String; const Lang: String); +var + SRec: TSearchRec; + i: Integer; +begin + i := FindFirst(Dir + '\*.*', faDirectory + faArchive, SRec); + try + while i = 0 do + begin + if (SRec.Name <> '.') and (SRec.Name <> '..') then + begin + if (LowerCase(ExtractFileExt(SRec.Name)) = '.frc') then + DoConvertFile(Dir + '\' + SRec.Name, Lang) + else + if (SRec.Attr and faDirectory) = faDirectory then + begin + WriteLn(SRec.Name + ':'); + DoConvert(Dir + '\' + SRec.Name, SRec.Name); + end; + end; + i := FindNext(SRec); + end; + WriteLn; + finally + FindClose(SRec); + end; +end; + +begin + if (ParamCount > 0) and FileExists(ParamStr(1)) then + begin + Codepages := TStringList.Create; + try + Codepages.LoadFromFile(ParamStr(1)); + Codepages.Text := UpperCase(Codepages.Text); + StartDir := GetCurrentDir; + DoConvert(StartDir, ''); + finally + Codepages.Free; + end; + end + else + Help; +end. diff --git a/official/4.8.11/Extra/res2utf8/res2utf8.exe b/official/4.8.11/Extra/res2utf8/res2utf8.exe new file mode 100644 index 0000000..cbcae49 Binary files /dev/null and b/official/4.8.11/Extra/res2utf8/res2utf8.exe differ diff --git a/official/4.8.11/FastQB/adler32.zobj b/official/4.8.11/FastQB/adler32.zobj new file mode 100644 index 0000000..04e2028 Binary files /dev/null and b/official/4.8.11/FastQB/adler32.zobj differ diff --git a/official/4.8.11/FastQB/compress.zobj b/official/4.8.11/FastQB/compress.zobj new file mode 100644 index 0000000..4de94fa Binary files /dev/null and b/official/4.8.11/FastQB/compress.zobj differ diff --git a/official/4.8.11/FastQB/crc32.zobj b/official/4.8.11/FastQB/crc32.zobj new file mode 100644 index 0000000..4b7261c Binary files /dev/null and b/official/4.8.11/FastQB/crc32.zobj differ diff --git a/official/4.8.11/FastQB/deflate.zobj b/official/4.8.11/FastQB/deflate.zobj new file mode 100644 index 0000000..8cf3759 Binary files /dev/null and b/official/4.8.11/FastQB/deflate.zobj differ diff --git a/official/4.8.11/FastQB/fqb.dcr b/official/4.8.11/FastQB/fqb.dcr new file mode 100644 index 0000000..1f3ca4c Binary files /dev/null and b/official/4.8.11/FastQB/fqb.dcr differ diff --git a/official/4.8.11/FastQB/fqb.inc b/official/4.8.11/FastQB/fqb.inc new file mode 100644 index 0000000..29d48dd --- /dev/null +++ b/official/4.8.11/FastQB/fqb.inc @@ -0,0 +1,159 @@ +{*******************************************} +{ } +{ FastQueryBuilder v1.03 } +{ Include file } +{ } +{ Copyright (c) 2004-2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + + +{$B-} {- Complete Boolean Evaluation } +{$R-} {- Range-Checking } +{$V-} {- Var-String Checking } +{$T-} {- Typed @ operator } +{$X+} {- Extended syntax } +{$P+} {- Open string params } +{$J+} {- Writeable structured consts } +{$H+} {- Use long strings by default } + +{$IFDEF VER120} // Delphi 4.0 + {$DEFINE Delphi4} +{$ENDIF} + +{$IFDEF VER130} // Delphi 5.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} +{$ENDIF} + +{$IFDEF VER140} // Delphi 6.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} +{$ENDIF} + +{$IFDEF VER150} // Delphi 7.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} + +{$IFDEF VER170} // Delphi 9.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{$IFDEF VER180} // Delphi 10.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{$IFDEF VER185} // Delphi 11.0 (Spacely) + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{$IFDEF VER190} // Delphi 11.0 (Highlander) + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$WARN UNSAFE_CODE OFF} +{$ENDIF} + +{$IFDEF VER200} // Delphi 12.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$DEFINE Delphi12} + {$DEFINE RICHBCB} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_PLATFORM OFF} + {$WARN UNIT_PLATFORM OFF} + {$WARN SYMBOL_DEPRECATED OFF} + {$WARN UNIT_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER210} // Delphi 13.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$DEFINE Delphi12} + {$DEFINE Delphi13} + {$DEFINE RICHBCB} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_PLATFORM OFF} + {$WARN UNIT_PLATFORM OFF} + {$WARN SYMBOL_DEPRECATED OFF} + {$WARN UNIT_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER93} // Borland C++ Builder 1.0 + {$DEFINE Delphi2} +{$ENDIF} + +{$IFDEF VER110} // Borland C++ Builder 3.0 + {$DEFINE Delphi3} + {$ObjExportAll on} +{$ENDIF} + +{$IFDEF VER125} // Borland C++ Builder 4.0 + {$DEFINE Delphi4} + {$ObjExportAll on} +{$ENDIF} + +{$IFDEF VER130} // Borland C++ Builder 5.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER140} // Borland C++ Builder 6.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER150} // Borland C++ Builder 7.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$WARN UNSAFE_CODE OFF} + {$ENDIF} +{$ENDIF} + +{$WARNINGS OFF} diff --git a/official/4.8.11/FastQB/fqb.lrs b/official/4.8.11/FastQB/fqb.lrs new file mode 100644 index 0000000..f9246f9 --- /dev/null +++ b/official/4.8.11/FastQB/fqb.lrs @@ -0,0 +1,434 @@ +LazarusResources.Add('TFQBDIALOG','BMP',[ + 'BM'#248#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#194#6#0#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#156'7'#14#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#155'7'#15#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#156'7'#14#255#255#255#255#255#255#255#255#255#255#255#255#187's' + +'B'#186'o@'#184'l='#182'h:'#181'e7'#178'b4'#177'_1'#175'\/'#174'Y,'#171'U)' + +#170'S'''#168'O$'#166'L!'#165'J'#31#163'G'#29#161'D'#27#160'A'#24#157'<'#19 + +#156'9'#15#156'7'#14#156'8'#16#155'7'#15#255#255#255#255#255#255#189'uE'#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#155'7'#15#228 + +#172#142#155'8'#15#255#255#255#255#255#255#191'xG'#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#14'z'#27#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#155'7'#15#156'7'#14#255#255 + +#255#255#255#255#192'zI'#248#248#248#248#248#248#248#248#248#248#248#248#14 + +'z'#27#14'z'#27'N'#210'x'#14'z'#27#248#248#248#175'Z-'#173'W+'#171'T('#169'Q' + +'&'#168'N#'#166'K '#164'H'#30#162'E'#28#160'B'#25#156':'#16#248#248#248#156 + +'8'#15#163'D'#30#255#255#255#193'}K'#248#248#248#248#248#248#248#248#248#28 + +#142'0N'#210'xZ'#226#137']'#230#142'R'#217'~'#14'z'#27#176']0'#248#248#248 + +#180'e7'#248#248#248#234#179#139#224#162'z'#155'7'#15#248#248#248#234#179#139 + +#160'A'#24#248#248#248#156'9'#15#156'7'#14#255#255#255#195#128'M'#248#248#248 + +#248#248#248#28#142'0.'#180'O%'#161'>'#24#151'#^'#231#143'/'#154'@'#248#248 + +#248#178'`3'#248#248#248#180'e7'#248#248#248#217'vN'#213'rJ'#160';'#18#176'L' + +'#'#248#248#248#162'D'#27#248#248#248#155'8'#15#156'7'#14#255#255#255#197#130 + +'P'#248#248#248#248#248#248#24#151'#;'#163'J'#248#248#248#248#248#248'/'#154 + +'@'#248#248#248#248#248#248#179'c5'#248#248#248#180'e7'#248#248#248#234#179 + +#139#234#179#139#248#248#248#156'7'#14#155'7'#15#160'@'#22#155'7'#15#156'7' + +#14#202#148'~'#255#255#255#197#133'R'#248#248#248#248#248#248#18#130#28#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#180'e7' + +#174'[.'#174'[.'#174'[.'#174'[.'#174'[.'#174'[.'#169'Q%'#176']0'#156':'#18 + +#155'7'#15#156'9'#15#255#255#255#255#255#255#199#135'S'#248#248#248#196#130 + +'O'#194'L'#193'|J'#191'yG'#190'uD'#188'sB'#186'o?'#184'l='#182'h:'#228#172 + +#142#180'e7'#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#156';'#17#248#248#248#156':'#16#255#255#255#255#255#255#200#138'V' + +#248#248#248#198#132'Q'#248#248#248#202#141'Y'#248#248#248#234#179#139#234 + +#179#139#234#179#139#234#179#139#248#248#248#182'h9'#179'e6'#178'a3'#176'^1' + +#163'G'#28#157'<'#18#156':'#16#156':'#16#156':'#16#248#248#248#156':'#16#255 + +#255#255#255#255#255#202#139'X'#248#248#248#198#134'T'#248#248#248#202#141'Y' + +#248#248#248#217'vN'#217'vN'#217'vN'#217'vN'#248#248#248#183'k<'#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#165'K '#255#255#255#255#255#255#203#142'Z'#248#248#248 + +#200#136'V'#248#248#248#202#141'Y'#234#179#139#234#179#139#234#179#139#234 + +#179#139#234#179#139#248#248#248#185'm>'#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#167 + +'N#'#255#255#255#255#255#255#204#144'['#248#248#248#202#139'W'#195'M'#195'' + +'M'#195'M'#195'M'#195'M'#195'M'#195'M'#195'M'#187'pA'#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#168'P%'#255#255#255#255#255#255#205#145'\'#248#248#248#202 + +#141'Y'#248#248#248#202#141'Y'#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#188'tB'#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#170'R''' + ,#255#255#255#255#255#255#206#147'^'#248#248#248#203#143'['#202#140'X'#201#138 + +'W'#200#136'T'#198#133'R'#196#130'P'#195'M'#193'|J'#192'yH'#190'vE'#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#172'U)'#255#255#255#255#255#255#207#149'`'#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248#248 + +#248#173'Y,'#255#255#255#255#255#255#207#150'a'#206#149'_'#205#147'^'#205#144 + +'\'#203#143'Z'#202#140'X'#201#138'V'#199#135'S'#197#132'R'#196#129'O'#194'L' + +#193'{I'#190'xG'#189'uD'#188'rA'#186'o?'#184'l<'#181'h9'#180'e6'#178'b3'#177 + +'^1'#175'[/'#255#255#255#255#255#255#208#152'b'#208#150'`'#207#148'_'#206#146 + +'^'#204#144'['#203#142'Z'#201#140'X'#200#137'V'#198#135'S'#197#132'Q'#196#128 + +'N'#194'~L'#192'zI'#191'xF'#189'tD'#187'qA'#186'n?'#184'k<'#182'h9'#179'd6' + +#178'a3'#176']1'#255#255#255#255#255#255#209#153'c'#208#151'a'#207#150'a'#206 + +#148'_'#205#146'^'#204#144'['#203#141'Y'#201#139'W'#200#137'V'#199#134'S'#197 + +#131'Q'#195#129'N'#194'}L'#192'zI'#190'wG'#188'tD'#187'qA'#185'n?'#183'k<' + +#181'g9'#179'd6'#178'`3'#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0 +]); +LazarusResources.Add('TFQBTABLEAREA','BMP',[ + 'BM'#248#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#194#6#0#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#185'n>'#184'k<'#182'i:'#181'f8' + +#179'd5'#178'a3'#177'^0'#175'[.'#174'Y-'#173'V*'#171'T('#169'R&'#168'P$'#167 + +'M"'#166'K '#165'I'#30#164'F'#29#163'E'#27#162'C'#25#161'A'#24#160'@'#23#159 + +'>'#21#255#255#255#255#255#255#187'q@'#250#244#234#159'>'#21#250#243#231#250 + +#243#229#250#242#228#250#241#227#249#241#226#250#240#224#249#240#224#249#239 + +#222#249#238#221#248#238#220#249#238#219#248#237#218#248#236#218#248#236#216 + +#159'>'#21#247#235#215#159'>'#21#247#235#213#160'?'#22#255#255#255#255#255 + +#255#188'sC'#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159 + +'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21 + +#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#161'@'#24#255 + +#255#255#255#255#255#190'uD'#251#245#234#250#244#233#250#244#231#250#244#230 + +#250#242#229#249#242#228#249#242#227#249#241#225#249#240#224#249#240#222#249 + +#240#222#248#239#221#248#238#220#247#238#219#248#237#218#247#237#217#247#237 + +#216#247#237#215#159'>'#21#247#236#214#161'B'#25#255#255#255#255#255#255#191 + +'xG'#251#246#235#251#245#234#250#245#233#250#244#231#250#244#231#249#243#229 + +#249#242#228#249#242#227#249#241#226#249#241#224#248#240#223#248#240#222#248 + +#239#221#248#238#220#248#238#218#248#237#217#248#237#216#248#237#216#159'>' + +#21#159'>'#21#162'D'#26#255#255#255#255#255#255#192'{I'#251#247#237#251#246 + +#235#251#245#235#250#244#233#250#244#232#250#243#230#250#243#229#250#242#227 + +#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#248 + +#238#217#159'>'#21#247#236#216#164'F'#29#255#255#255#255#255#255#193'}K'#252 + +#246#239#251#247#237#251#245#235#251#246#234#250#244#233#250#243#231#250#243 + +#231#250#243#229#173'V*'#249#242#226#249#241#226#249#241#224#249#240#222#248 + +#240#222#249#239#221#248#238#220#173'V*'#248#238#217#159'>'#21#248#236#217 + +#165'I'#30#255#255#255#255#255#255#194'M'#252#247#240#251#246#238#251#246 + +#237#251#246#236#251#245#235#250#244#233#250#244#232#250#243#230#173'V*'#249 + +#242#228#199'm@'#199'm@'#199'm@'#199'm@'#199'm@'#248#238#221#173'V*'#248#238 + +#219#159'>'#21#249#237#218#166'J'#31#255#255#255#255#255#255#196#129'O'#252 + +#248#241#252#247#239#251#247#238#249#243#229#249#243#229'$'#141'4'#249#243 + +#229#249#243#229#173'V*'#249#243#229#173'V*'#173'V*'#173'V*'#173'V*'#173'V*' + +#248#239#222#173'V*'#248#239#219#159'>'#21#248#238#219#167'L!'#255#255#255 + +#255#255#255#198#132'Q'#252#248#242#252#248#241#239#242#229'7'#152'E'#22#133 + +'&R'#216'~&'#156'?'#249#243#229#173'V*'#250#243#230#249#243#229#250#242#227 + +#250#241#227#250#241#226#249#241#224#249#240#222#173'V*'#248#239#221#159'>' + +#21#249#238#220#169'N#'#255#255#255#255#255#255#198#134'S'#252#249#243#239 + +#243#231'8'#156'HE'#199'kU'#221#129'`'#234#146'\'#228#138#25#137'+'#173'V*' + +#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#249#239#222 + +#159'>'#21#249#238#221#170'Q%'#255#255#255#255#255#255#200#136'T'#252#250#245 + +'?'#159'L0'#177'MC'#174'Y:'#159'=P'#212'xB'#168'T'#252#249#242#252#249#242 + +#250#245#233#250#244#232#250#243#231#250#243#230#250#242#228#249#241#227#249 + +#241#226#249#240#224#248#240#223#159'>'#21#248#239#223#171'S'''#255#255#255 + +#255#255#255#201#138'W'#253#250#245'7'#162'=@'#163'K'#252#249#242#252#248#241 + +'W'#169'^'#252#249#242#251#246#237#251#245#235#251#245#234#251#244#233#250 + +#244#231#250#243#230#250#243#229#249#242#227#249#242#226#249#241#226#249#241 + +#224#159'>'#21#249#239#224#171'U)'#255#255#255#255#255#255#201#140'X'#253#250 + +#246#31#136'('#252#249#242#253#249#243#252#249#242#251#248#241#252#247#240 + +#251#247#238#251#246#237#251#246#236#251#246#234#251#245#233#251#244#232#250 + +#244#230#250#243#229#249#242#228#249#242#226#249#242#226#159'>'#21#249#240 + +#225#173'X+'#255#255#255#255#255#255#203#142'Z'#253#251#247#173'V*'#173'V*' + +#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#251#245#235#251#245 + +#235#250#244#233#250#244#232#250#244#231#250#243#229#250#242#228#249#241#226 + +#159'>'#21#249#240#226#175'Z-'#255#255#255#255#255#255#204#144'['#253#251#248 + +#173'V*'#253#250#247#253#250#246#252#249#245#252#249#243#252#249#242#252#248 + +#241#252#247#240#173'V*'#251#246#237#251#246#236#251#245#234#251#244#233#250 + +#244#231#250#243#230#250#243#229#250#243#228#159'>'#21#250#241#227#175']/' + +#255#255#255#255#255#255#205#146']'#254#252#249#173'V*'#253#251#247#199'm@' + +#199'm@'#199'm@'#199'm@'#199'm@'#252#248#240#173'V*'#252#247#238#251#246#237 + +#251#246#235#251#245#234#250#244#233#250#243#232#250#243#230#250#242#229#159 + +'>'#21#250#241#228#177'_1'#255#255#255#255#255#255#206#147'^'#253#252#250#173 + ,'V*'#254#251#248#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#252#248#242#173'V*' + +#252#248#240#251#247#238#251#247#237#251#246#235#251#245#235#251#244#233#251 + +#244#231#250#243#230#159'>'#21#250#242#229#179'a3'#255#255#255#255#255#255 + +#206#148'^'#254#252#251#173'V*'#253#251#249#254#251#248#253#251#248#253#251 + +#247#253#250#245#253#249#244#252#249#243#173'V*'#252#248#241#252#247#239#252 + +#247#239#251#246#237#251#246#236#251#245#234#251#245#233#250#244#232#159'>' + +#21#250#243#231#180'd6'#255#255#255#255#255#255#206#149'`'#254#252#251#173'V' + +'*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#173'V*'#253#248 + +#242#251#248#241#252#248#240#251#247#238#252#246#236#251#246#236#251#245#234 + +#251#245#233#159'>'#21#159'>'#21#181'f8'#255#255#255#255#255#255#207#151'a' + +#254#253#252#254#252#252#254#252#251#253#252#250#254#252#249#254#252#249#253 + +#251#247#253#250#246#253#250#245#253#250#244#252#249#243#253#249#242#252#248 + +#241#252#248#240#251#247#238#251#246#237#251#246#235#250#245#234#159'>'#21 + +#251#244#234#182'i:'#255#255#255#255#255#255#208#152'b'#207#151'a'#206#149'`' + +#206#148'_'#205#147']'#204#145'\'#203#143'['#202#141'Y'#201#139'X'#200#137'V' + +#199#136'T'#197#133'R'#196#131'O'#195#128'N'#194'~L'#192'{J'#192'yH'#189'vF' + +#188'sC'#186'qA'#186'n?'#184'l='#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0 +]); +LazarusResources.Add('TFQBTABLELISTBOX','BMP',[ + 'BM'#248#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#194#6#0#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#185'm='#183'j;'#182'h8'#180'e6' + +#179'c5'#178'`3'#176'^0'#175'[.'#174'Y,'#172'W*'#171'U('#169'R&'#169'P$'#168 + +'M#'#167'L '#166'J '#164'H'#29#163'F'#28#162'E'#26#161'C'#25#161'B'#24#160'@' + +#23#255#255#255#255#255#255#185'o?'#250#244#233#251#243#232#250#243#231#250 + +#243#230#250#242#228#250#242#227#249#242#227#249#241#227#249#240#225#249#240 + +#225#248#240#224#248#239#224#248#238#223#248#238#221#248#238#220#248#238#220 + +#247#237#220#247#237#219#159'>'#21#247#237#218#160'A'#24#255#255#255#255#255 + +#255#187'rA'#251#244#234#250#244#233#250#244#232#250#243#231#250#242#230#250 + +#242#230#250#242#229#250#241#228#249#240#227#249#240#226#248#240#225#249#239 + +#224#248#239#223#248#238#222#248#238#222#248#237#222#248#237#221#247#238#220 + +#159'>'#21#159'>'#21#162'C'#25#255#255#255#255#255#255#189'tC'#251#245#235 + +#176'X'#0#176'X'#0#176'X'#0#176'X'#0#249#243#231#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#248 + +#238#220#159'>'#21#247#237#220#163'E'#26#255#255#255#255#255#255#189'wF'#251 + +#245#237#251#245#236#251#244#235#250#244#233#250#243#232#250#243#232#250#243 + +#231#249#242#230#250#242#229#250#242#228#250#241#227#249#240#226#249#240#226 + +#249#240#225#249#239#223#249#239#222#248#239#222#248#238#222#159'>'#21#248 + +#238#220#163'G'#28#255#255#255#255#255#255#191'yH'#251#246#238#176'X'#0#176 + +'X'#0#176'X'#0#176'X'#0#250#243#232#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176 + +'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#248#238#222#159 + +'>'#21#248#238#221#164'H'#30#255#255#255#255#255#255#193'|J'#251#246#239#251 + +#245#238#251#245#237#250#244#236#251#244#234#251#244#234#250#244#234#250#243 + +#233#250#243#232#250#243#230#250#242#230#249#241#228#249#241#227#249#241#226 + +#248#241#225#248#239#225#248#239#224#248#239#223#159'>'#21#248#239#222#165'J' + +#31#255#255#255#255#255#255#194'~L'#252#247#240#209#153'c'#209#153'c'#209#153 + +'c'#209#153'c'#251#245#236#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209 + +#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#249 + +#240#225#159'>'#21#248#238#223#167'L '#255#255#255#255#255#255#195#129'N'#251 + +#247#241#252#247#240#252#246#239#252#246#238#251#245#237#251#245#237#251#245 + +#236#251#244#235#251#244#234#250#243#232#250#243#231#249#242#230#250#242#229 + +#249#242#228#249#242#227#249#240#227#249#240#226#249#240#225#159'>'#21#249 + +#240#224#168'M"'#255#255#255#255#255#255#196#131'P'#252#248#242#209#153'c' + +#209#153'c'#209#153'c'#209#153'c'#251#246#238#209#153'c'#209#153'c'#209#153 + +'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153 + +'c'#209#153'c'#249#241#226#159'>'#21#249#240#224#169'P%'#255#255#255#255#255 + +#255#197#133'R'#253#248#243#252#248#242#252#248#241#252#247#241#252#246#240 + +#252#246#238#251#246#238#251#245#237#251#245#236#250#245#235#251#244#234#250 + +#243#233#250#243#232#250#242#231#250#242#230#250#242#230#249#242#229#249#241 + +#228#159'>'#21#248#240#226#170'R&'#255#255#255#255#255#255#198#135'T'#253#249 + +#244#209#153'c'#209#153'c'#209#153'c'#209#153'c'#252#247#240#209#153'c'#209 + +#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209 + +#153'c'#209#153'c'#209#153'c'#250#241#229#159'>'#21#249#240#227#171'U('#255 + +#255#255#255#255#255#199#137'U'#253#250#246#252#248#244#252#249#243#252#248 + +#242#252#247#241#252#247#241#252#247#240#252#247#239#252#246#238#251#246#238 + +#251#245#236#251#245#235#251#244#234#250#244#234#250#244#233#250#244#231#250 + +#243#231#250#242#230#159'>'#21#250#241#228#172'W*'#255#255#255#255#255#255 + +#200#139'W'#253#249#246'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2#253#248#241'Z'#2#2'Z'#2#2 + +'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2'Z'#2#2#250#243#231 + +#159'>'#21#250#241#229#174'Y,'#255#255#255#255#255#255#201#141'Y'#253#250#247 + +#253#250#246#253#249#245#253#249#244#252#248#244#252#248#244#252#248#243#252 + +#248#242#252#247#241#252#246#239#251#246#238#251#246#238#251#246#237#251#245 + +#235#251#244#235#251#244#234#250#244#233#250#243#232#159'>'#21#249#242#230 + +#175'[.'#255#255#255#255#255#255#202#143'Z'#253#251#248#176'X'#0#176'X'#0#176 + +'X'#0#176'X'#0#253#249#244#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176 + +'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#250#244#234#159'>'#21#250 + +#243#232#176'^0'#255#255#255#255#255#255#203#145'\'#254#251#249#254#250#248 + +#253#250#247#253#250#247#253#250#247#253#250#246#253#249#244#252#249#243#252 + +#248#243#253#247#241#252#247#240#252#247#240#252#246#239#251#246#238#251#245 + +#237#250#245#237#250#245#236#251#244#235#159'>'#21#250#243#232#178'a2'#255 + ,#255#255#255#255#255#204#146'\'#253#251#250#176'X'#0#176'X'#0#176'X'#0#176'X' + +#0#253#250#245#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#176'X'#0#176'X'#0#251#245#236#159'>'#21#250#244#234#179'c' + +'4'#255#255#255#255#255#255#205#148'^'#253#251#250#254#251#249#254#251#249 + +#253#250#248#253#251#247#253#251#246#253#250#246#253#249#246#253#249#245#252 + +#249#244#252#248#243#252#248#242#252#247#241#252#247#240#252#247#239#252#247 + +#239#252#246#238#251#246#237#159'>'#21#251#245#235#180'e7'#255#255#255#255 + +#255#255#206#148'_'#254#252#250#176'X'#0#176'X'#0#176'X'#0#176'X'#0#254#250 + +#248#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#176'X'#0#252#246#238#159'>'#21#159'>'#21#182'h9'#255#255 + +#255#255#255#255#207#150'`'#254#252#251#254#252#250#254#251#250#254#251#250 + +#253#251#250#253#251#248#253#251#248#254#251#248#253#250#247#253#250#246#253 + +#250#245#252#248#244#253#248#243#252#248#242#252#248#241#252#248#241#252#247 + +#241#251#247#239#159'>'#21#251#245#237#183'k;'#255#255#255#255#255#255#207 + +#151'a'#206#150'`'#206#148'_'#205#147'^'#205#146']'#203#144'\'#203#143'Z'#201 + +#141'X'#201#140'W'#199#137'U'#199#135'S'#197#133'Q'#196#131'P'#195#128'N'#194 + +'~L'#193'|I'#191'zH'#189'wE'#189'uD'#188'rB'#186'p@'#185'm>'#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 +]); +LazarusResources.Add('TFQBSYNTAXMEMO','BMP',[ + 'BM'#248#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#194#6#0#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#183'k;'#181'g8'#180'd7'#179'b4' + +#177'`1'#175']/'#174'Z-'#172'W+'#171'U('#170'R&'#168'O$'#167'M"'#166'K'#31 + +#165'I'#30#163'F'#28#162'D'#26#161'B'#24#160'@'#23#159'?'#21#158'<'#20#158';' + +#18#157':'#17#255#255#255#255#255#255#184'm='#251#245#237#251#245#236#251#244 + +#235#251#244#234#250#244#233#250#243#232#249#243#231#250#242#230#250#241#229 + +#249#241#229#249#241#227#248#241#227#249#240#226#248#240#225#248#240#224#248 + +#239#224#248#238#223#248#238#222#247#238#221#247#238#221#158';'#18#255#255 + +#255#255#255#255#186'p@'#251#246#238#251#245#237'QPBQPBQPBQPBQPB'#250#243#231 + +#249#243#230#249#242#229#250#241#228#249#241#227#249#241#227#248#240#226#248 + +#240#225#249#239#225#248#239#223#248#239#223#247#238#222#247#238#222#158'<' + +#20#255#255#255#255#255#255#187'rB'#251#246#238#252#246#238'cfRcfRcfRcfRcfR' + +#250#243#233#249#243#231#249#242#230#249#242#229#249#241#228#249#241#228#249 + +#240#226#249#240#226#248#240#225#248#239#224#248#239#223#248#238#223#247#238 + +#222#159'>'#21#255#255#255#255#255#255#189'uD'#252#246#239#251#246#239#251 + +#246#237#251#245#236#251#245#236#251#245#235#250#244#234#250#244#233#249#243 + +#232#249#242#231#250#242#231#250#242#229#249#242#229#248#241#227#249#241#227 + +#248#240#226#248#240#225#248#240#224#248#239#223#248#238#223#160'@'#23#255 + +#255#255#255#255#255#191'xF'#252#247#241#251#247#239#251#246#239#251#246#238 + +#251#245#237#251#245#236'QPBQPBQPBQPBQPBQPBQPB'#249#242#228#249#241#227#248 + +#241#227#249#241#226#248#240#225#248#240#225#248#239#223#161'B'#25#255#255 + +#255#255#255#255#192'zI'#252#248#241#251#247#241#252#246#240#251#246#239#251 + +#246#238#251#245#236'cfRcfRcfRcfRcfRcfRcfR'#249#242#229#249#241#229#249#241 + +#227#249#241#227#248#240#226#248#240#225#249#239#224#162'D'#26#255#255#255 + +#255#255#255#194'}K'#252#248#242#252#248#241#251#247#241#251#247#240#251#246 + +#238#252#246#238#251#245#237#251#245#236#251#244#235#250#244#234#250#243#233 + +#250#244#232#250#243#231#250#242#230#249#242#229#250#241#228#248#241#227#248 + +#240#227#249#240#226#248#240#225#164'F'#28#255#255#255#255#255#255#195'M' + +#252#249#243#252#248#243#252#247#242#252#248#240#252#247#240#251#246#239#251 + +#246#238#3' '#250#251#245#236#3' '#250#3' '#250#3' '#250#3' '#250#3' '#250#3 + +' '#250#4#6#232#4#6#232#4#6#232#4#6#232#248#241#226#164'H'#30#255#255#255#255 + +#255#255#196#130'O'#252#249#245#252#249#243#252#248#242#252#248#241#252#248 + +#241#252#246#240#252#246#239#3' '#250#250#245#237#3' '#250#3' '#250#3' '#250 + +#3' '#250#3' '#250#4#6#232#4#6#232#4#6#232#4#6#232#4#6#232#249#241#227#166'J' + +' '#255#255#255#255#255#255#198#132'Q'#253#249#245#252#248#244#252#248#243 + +#252#248#242#252#248#241#251#247#240#251#246#240#251#246#239#251#246#238#251 + +#245#237#250#245#236#251#244#235#250#244#234#250#244#233#250#243#232#250#243 + +#232#249#242#231#250#242#229#249#242#229#249#241#228#167'M"'#255#255#255#255 + +#255#255#199#135'S'#253#249#246#253#249#245#252#248#244#252#249#243#253#248 + +#242#251#248#241'QPBQPBQPBQPBQPBQPBQPBQPBQPBQPB'#250#243#231#250#242#231#249 + +#241#229#249#242#229#168'P$'#255#255#255#255#255#255#200#136'U'#253#250#246 + +#253#250#246#253#249#245#253#249#244#252#249#243#252#248#243'cfRcfRcfRcfRcfR' + +'cfRcfRcfRcfRcfR'#249#243#232#249#243#231#249#242#230#249#242#230#170'R&'#255 + +#255#255#255#255#255#201#139'W'#253#250#248#253#250#247#253#250#245#253#249 + +#245#252#249#244#252#248#243#252#248#242#252#248#242#252#247#240#252#247#240 + +#251#246#239#251#246#238#251#246#237#251#245#236#250#244#235#250#244#235#250 + +#243#233#250#243#233#250#243#231#249#242#230#171'U('#255#255#255#255#255#255 + +#202#141'Y'#254#251#248#254#250#247#253#250#246#253#249#246#253#249#245#195 + +'ta'#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#252#246#239#251#245#238#251#246 + +#237#251#245#236#250#244#235#250#244#234#250#243#234#250#244#232#249#243#232 + +#172'W+'#255#255#255#255#255#255#203#143'Z'#253#251#248#254#251#248#253#250 + +#247#253#250#247#253#249#245#253#249#245#252#249#245#253#248#244#252#248#242 + +#252#247#241#251#247#240#252#247#240#251#246#239#251#245#238#251#245#237#251 + +#245#236#251#244#235#250#244#234#250#243#233#250#244#232#174'Z-'#255#255#255 + +#255#255#255#204#144'['#254#251#249#253#251#249#253#251#248#253#250#247#253 + +#250#246#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#251#247#240 + +#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#195'ta'#250#244#233#175'\/'#255#255 + +#255#255#255#255#205#147']'#254#252#250#254#251#249#253#251#249#253#250#248 + +#254#250#247#253#250#247#253#250#246#252#249#245#253#249#244#252#248#243#252 + +#248#243#252#248#242#252#247#241#252#246#240#252#246#239#251#245#238#251#245 + ,#237#251#244#236#251#244#235#250#244#234#177'_2'#255#255#255#255#255#255#206 + +#148'_'#254#252#250#254#251#249'QPBQPBQPBQPBQPBQPB'#252#249#245#252#249#244 + +#253#248#243#252#248#242#252#247#242#252#247#240#251#247#240#251#246#239#251 + +#246#238#251#246#237#251#245#236#251#244#235#179'b4'#255#255#255#255#255#255 + +#207#149'_'#254#252#251#254#252#250'cfRcfRcfRcfRcfRcfR'#253#250#246#253#249 + +#245#252#249#244#252#248#243#253#248#243#252#247#241#252#247#241#251#247#240 + +#252#246#238#251#246#238#251#245#237#251#245#236#180'e7'#255#255#255#255#255 + +#255#208#151'a'#254#252#251#254#251#251#254#252#250#254#251#250#253#251#250 + +#253#251#248#253#251#248#253#250#247#253#250#246#253#249#246#253#249#245#252 + +#248#245#252#248#243#252#248#243#252#248#242#252#247#241#252#247#240#251#246 + +#239#251#246#237#251#246#237#181'h8'#255#255#255#255#255#255#208#152'b'#207 + +#151'a'#207#150'`'#206#148'_'#205#146']'#204#144'\'#203#143'Z'#202#141'X'#201 + +#139'W'#200#137'U'#198#135'T'#197#132'R'#196#130'O'#194'M'#194'}K'#192'zI' + +#191'xF'#189'uD'#188'rB'#186'o?'#184'm>'#183'k;'#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0 +]); +LazarusResources.Add('TFQBGRID','BMP',[ + 'BM'#248#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#194#6#0#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#177'a2'#178'c4'#180'e6'#181'h9'#182'j;'#184'm='#185'p?'#186'sB' + +#188'uD'#190'xF'#191'{H'#192'}K'#193'M'#195#129'N'#196#132'Q'#197#134'R'#199 + +#137'T'#199#138'V'#200#140'W'#201#142'X'#202#143'Z'#203#145'['#255#255#255 + +#255#255#255#176'^0'#252#247#241#159'>'#21#251#246#239#251#245#237#250#245 + +#236#250#244#235#250#243#233#250#243#233#249#243#231#249#242#230#249#242#229 + +#249#241#228#248#240#226#249#240#226#249#240#225#248#239#224#248#239#223#248 + +#239#222#248#238#222#247#238#221#202#144'Z'#255#255#255#255#255#255#175'\.' + +#252#247#242#159'>'#21#252#246#239#252#246#238#251#246#237#251#245#236#251 + +#245#235#250#243#234#250#242#232#250#242#231#249#242#229#249#241#229#249#241 + +#228#248#240#226#248#240#226#248#240#225#248#238#224#247#239#223#248#238#222 + +#247#238#221#201#142'Y'#255#255#255#255#255#255#174'[-'#252#248#243#159'>'#21 + +#252#247#241#176'X'#0#176'X'#0#176'X'#0#250#244#236#176'X'#0#176'X'#0#176'X' + +#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#247#238#222#201#141'X'#255#255#255#255#255#255#173'Y+'#253#248#244 + +#159'>'#21#251#247#241#251#247#240#252#246#238#251#245#237#251#245#236#251 + +#245#235#251#244#234#250#244#233#250#242#232#250#242#231#249#241#230#249#241 + +#229#249#241#227#248#240#227#248#240#225#248#239#225#248#238#223#248#238#222 + +#200#140'W'#255#255#255#255#255#255#172'W*'#253#249#244#159'>'#21#252#247#242 + +#176'X'#0#176'X'#0#176'X'#0#251#246#238#176'X'#0#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#247 + +#239#223#199#138'U'#255#255#255#255#255#255#170'U('#252#249#245#159'>'#21#253 + +#248#243#252#247#242#251#247#241#252#246#239#251#246#239#251#246#237#251#244 + +#236#251#244#235#250#244#234#249#243#232#249#243#232#250#241#230#249#241#229 + +#249#241#228#248#240#227#249#240#226#248#240#225#248#239#224#198#137'T'#255 + +#255#255#255#255#255#169'S'''#253#249#246#159'>'#21#252#248#243#209#153'c' + +#209#153'c'#209#153'c'#251#247#239#209#153'c'#209#153'c'#209#153'c'#209#153 + +'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153 + +'c'#209#153'c'#248#239#225#198#134'S'#255#255#255#255#255#255#168'Q%'#253#249 + +#246#159'>'#21#252#249#245#252#249#243#252#248#243#252#248#242#251#246#240 + +#252#246#239#251#246#238#250#245#237#250#245#235#251#244#234#250#243#233#250 + +#243#232#249#242#230#249#241#229#249#241#228#248#241#227#249#241#227#249#239 + +#225#197#132'Q'#255#255#255#255#255#255#168'O#'#254#250#248#159'>'#21#253#249 + +#245#209#153'c'#209#153'c'#209#153'c'#252#247#242#209#153'c'#209#153'c'#209 + +#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209#153'c'#209 + +#153'c'#209#153'c'#248#241#228#248#240#226#196#131'P'#255#255#255#255#255#255 + +#167'N#'#253#251#248#159'>'#21#253#250#246#253#249#245#252#248#244#252#248 + +#243#252#247#242#251#247#241#252#247#240#251#246#239#251#246#238#251#245#236 + +#250#245#235#251#243#234#249#243#232#250#243#232#249#242#231#249#241#230#249 + +#241#228#248#240#227#194#129'N'#255#255#255#255#255#255#165'L!'#254#250#248 + +#159'>'#21#253#250#247#176'X'#0#176'X'#0#176'X'#0#252#248#243#176'X'#0#176'X' + +#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#248#241#228#194'L'#255#255#255#255#255#255#165'K'#31#253 + +#251#249#159'>'#21#253#250#248#253#250#247#253#250#245#253#249#245#253#249 + +#244#252#248#243#251#248#241#252#246#240#252#246#239#251#245#239#250#245#237 + +#251#244#236#250#244#235#250#244#233#250#243#232#249#242#231#249#241#230#249 + +#241#229#192'}K'#255#255#255#255#255#255#165'I'#31#253#251#249#159'>'#21#253 + +#251#248#176'X'#0#176'X'#0#176'X'#0#252#249#245#176'X'#0#176'X'#0#176'X'#0 + +#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#176'X'#0#250 + +#242#231#250#242#229#191'{I'#255#255#255#255#255#255#164'I'#30#254#252#251 + +#159'>'#21#253#251#249#253#251#248#254#250#247#253#250#246#253#249#245#252 + +#249#244#252#249#243#252#248#242#251#248#241#252#246#240#251#246#239#251#245 + ,#238#251#245#237#251#245#235#250#244#234#249#243#233#249#242#232#249#242#231 + +#190'yG'#255#255#255#255#255#255#163'G'#29#159'>'#21#159'>'#21#159'>'#21#159 + +'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21 + +#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>'#21#159'>' + +#21#159'>'#21#189'wF'#255#255#255#255#255#255#163'F'#28#254#252#251#159'>'#21 + +#253#251#250#254#251#249#253#251#248#253#250#248#253#250#247#253#250#246#252 + +#249#245#252#249#244#252#248#243#252#248#242#252#247#241#251#247#239#251#246 + +#238#251#245#237#250#244#236#250#244#234#250#243#234#250#243#232#188'uC'#255 + +#255#255#255#255#255#162'E'#27#163'F'#28#163'H'#29#164'I'#30#165'K'#31#166'L' + +'"'#167'N#'#168'Q$'#169'R'''#170'T('#172'W*'#173'Y,'#174'\.'#175'^0'#177'a2' + +#178'c5'#180'f7'#181'i9'#183'k;'#184'n='#186'q@'#187'sA'#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0 +]); diff --git a/official/4.8.11/FastQB/fqb100.bdsproj b/official/4.8.11/FastQB/fqb100.bdsproj new file mode 100644 index 0000000..d28461b --- /dev/null +++ b/official/4.8.11/FastQB/fqb100.bdsproj @@ -0,0 +1,161 @@ +п»ї + + + + + + + + + + + fqb100.dpk + + + 9.0 + + + 8 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastQueryBuilder 1.03 + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + diff --git a/official/4.8.11/FastQB/fqb100.dpk b/official/4.8.11/FastQB/fqb100.dpk new file mode 100644 index 0000000..60eebc3 --- /dev/null +++ b/official/4.8.11/FastQB/fqb100.dpk @@ -0,0 +1,47 @@ +package fqb100; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb110.bdsproj b/official/4.8.11/FastQB/fqb110.bdsproj new file mode 100644 index 0000000..8ca5fc2 --- /dev/null +++ b/official/4.8.11/FastQB/fqb110.bdsproj @@ -0,0 +1,161 @@ +п»ї + + + + + + + + + + + fqb110.dpk + + + 9.0 + + + 8 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastQueryBuilder 1.03 + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + diff --git a/official/4.8.11/FastQB/fqb110.dpk b/official/4.8.11/FastQB/fqb110.dpk new file mode 100644 index 0000000..34e5dc4 --- /dev/null +++ b/official/4.8.11/FastQB/fqb110.dpk @@ -0,0 +1,47 @@ +package fqb110; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb120.bdsproj b/official/4.8.11/FastQB/fqb120.bdsproj new file mode 100644 index 0000000..c1ac422 --- /dev/null +++ b/official/4.8.11/FastQB/fqb120.bdsproj @@ -0,0 +1,161 @@ +п»ї + + + + + + + + + + + fqb120.dpk + + + 9.0 + + + 8 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastQueryBuilder 1.03 + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + diff --git a/official/4.8.11/FastQB/fqb120.dpk b/official/4.8.11/FastQB/fqb120.dpk new file mode 100644 index 0000000..47dfa5d --- /dev/null +++ b/official/4.8.11/FastQB/fqb120.dpk @@ -0,0 +1,47 @@ +package fqb120; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb120.dproj b/official/4.8.11/FastQB/fqb120.dproj new file mode 100644 index 0000000..d7fe55b --- /dev/null +++ b/official/4.8.11/FastQB/fqb120.dproj @@ -0,0 +1,121 @@ +п»ї + + {C1338ECF-144E-4339-ACE2-3F11F7D3D8A2} + fqb120.dpk + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + 00400000 + e:\out\fqb120.bpl + true + true + true + true + true + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) + false + FastQueryBuilder 1.03 + x86 + true + false + false + true + true + false + 0 + false + true + false + false + + + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + + + +
fqbSynmemo
+ + +
fqbLinkForm
+ + + +
fqbDesign
+ + + + Base + + + + + Delphi.Personality + Package + + + + fqb120.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + diff --git a/official/4.8.11/FastQB/fqb140.bdsproj b/official/4.8.11/FastQB/fqb140.bdsproj new file mode 100644 index 0000000..d145841 --- /dev/null +++ b/official/4.8.11/FastQB/fqb140.bdsproj @@ -0,0 +1,161 @@ +п»ї + + + + + + + + + + + fqb140.dpk + + + 9.0 + + + 8 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastQueryBuilder 1.03 + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + diff --git a/official/4.8.11/FastQB/fqb140.dpk b/official/4.8.11/FastQB/fqb140.dpk new file mode 100644 index 0000000..fceb640 --- /dev/null +++ b/official/4.8.11/FastQB/fqb140.dpk @@ -0,0 +1,44 @@ +package fqb140; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl; + +contains + fqbClass in 'fqbClass.pas', + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas', + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas'; + +end. diff --git a/official/4.8.11/FastQB/fqb40.bpk b/official/4.8.11/FastQB/fqb40.bpk new file mode 100644 index 0000000..4622d63 --- /dev/null +++ b/official/4.8.11/FastQB/fqb40.bpk @@ -0,0 +1,189 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = fqb40.bpl +OBJFILES = fqbReg.obj fqb40.obj +RESFILES = fqb.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +IDLFILES = +IDLGENFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib +PACKAGES = vcl40.bpi vcldb40.bpi vclx40.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- \ + -a8 -k -y -v -vi- -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +IDLCFLAGS = -I$(BCB)\include -I$(BCB)\include\vcl -src_suffixcpp +PFLAGS = -U$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zd +LFLAGS = -L$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -D"FastQueryBuilder 1.0" -aa -Tpp -x -Gn -Gl \ + -Gi -v +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +!if !$d(IDL2CPP) +IDL2CPP = idl2cpp +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(IDLGENFILES) $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/FastQB/fqb40.cpp b/official/4.8.11/FastQB/fqb40.cpp new file mode 100644 index 0000000..a0e4ed2 --- /dev/null +++ b/official/4.8.11/FastQB/fqb40.cpp @@ -0,0 +1,18 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEPACKAGE("vcl40.bpi"); +USERES("fqb.dcr"); +USEUNIT("fqbReg.pas"); +USEPACKAGE("vcldb40.bpi"); +USEPACKAGE("vclx40.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastQB/fqb40.dpk b/official/4.8.11/FastQB/fqb40.dpk new file mode 100644 index 0000000..b5e14a3 --- /dev/null +++ b/official/4.8.11/FastQB/fqb40.dpk @@ -0,0 +1,44 @@ +package fqb40; + +{$ALIGN ON} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl40, + vclx40, + vcldb40 + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb50.bpk b/official/4.8.11/FastQB/fqb50.bpk new file mode 100644 index 0000000..3fc8999 --- /dev/null +++ b/official/4.8.11/FastQB/fqb50.bpk @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=1 +Special=1 +Private=0 +DLL=0 + + diff --git a/official/4.8.11/FastQB/fqb50.cpp b/official/4.8.11/FastQB/fqb50.cpp new file mode 100644 index 0000000..9b34e80 --- /dev/null +++ b/official/4.8.11/FastQB/fqb50.cpp @@ -0,0 +1,28 @@ + +#include +#pragma hdrstop +USEUNIT("fqbClass.pas"); +USEUNIT("fqbSynmemo.pas"); +USEUNIT("fqbLinkForm.pas"); +USEUNIT("fqbUtils.pas"); +USEUNIT("fqbDesign.pas"); +USEUNIT("fqbZLib.pas"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vclx50.bpi"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("vclbde50.bpi"); + +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/official/4.8.11/FastQB/fqb50.dpk b/official/4.8.11/FastQB/fqb50.dpk new file mode 100644 index 0000000..a612a4d --- /dev/null +++ b/official/4.8.11/FastQB/fqb50.dpk @@ -0,0 +1,45 @@ +package fqb50; + +{$ALIGN ON} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl50, + vclx50, + vcldb50, + vclbde50 + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb60.bpk b/official/4.8.11/FastQB/fqb60.bpk new file mode 100644 index 0000000..5ee1914 --- /dev/null +++ b/official/4.8.11/FastQB/fqb60.bpk @@ -0,0 +1,104 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=1 +Special=1 +Private=0 +DLL=0 + + diff --git a/official/4.8.11/FastQB/fqb60.cpp b/official/4.8.11/FastQB/fqb60.cpp new file mode 100644 index 0000000..55bebe9 --- /dev/null +++ b/official/4.8.11/FastQB/fqb60.cpp @@ -0,0 +1,20 @@ + +#include +#pragma hdrstop +USEFORMNS("fqbSynmemo.pas", Fqbsynmemo, fqbSynmemo); +USEFORMNS("fqbLinkForm.pas", Fqblinkform, fqbLinkForm); +USEFORMNS("fqbDesign.pas", Fqbdesign, fqbDesign); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/official/4.8.11/FastQB/fqb60.dpk b/official/4.8.11/FastQB/fqb60.dpk new file mode 100644 index 0000000..ed6a741 --- /dev/null +++ b/official/4.8.11/FastQB/fqb60.dpk @@ -0,0 +1,47 @@ +package fqb60; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb70.dpk b/official/4.8.11/FastQB/fqb70.dpk new file mode 100644 index 0000000..0413133 --- /dev/null +++ b/official/4.8.11/FastQB/fqb70.dpk @@ -0,0 +1,47 @@ +package fqb70; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqb90.bdsproj b/official/4.8.11/FastQB/fqb90.bdsproj new file mode 100644 index 0000000..ec17ecc --- /dev/null +++ b/official/4.8.11/FastQB/fqb90.bdsproj @@ -0,0 +1,161 @@ +п»ї + + + + + + + + + + + fqb90.dpk + + + 9.0 + + + 8 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 0 + 0 + 1 + 1 + 1 + 0 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 0 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastQueryBuilder 1.03 + + + + + + + + + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1053 + 1252 + + + diff --git a/official/4.8.11/FastQB/fqb90.dpk b/official/4.8.11/FastQB/fqb90.dpk new file mode 100644 index 0000000..afda5e0 --- /dev/null +++ b/official/4.8.11/FastQB/fqb90.dpk @@ -0,0 +1,47 @@ +package fqb90; + +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS ON} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastQueryBuilder 1.03'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$I fqb.inc} + +requires + vcl, + rtl, + vclx, + dbrtl, + vcldb, + bdertl + ; + +contains + fqbClass in 'fqbClass.pas' , + fqbSynmemo in 'fqbSynmemo.pas' {fqbSynmemo}, + fqbLinkForm in 'fqbLinkForm.pas' {fqbLinkForm}, + fqbUtils in 'fqbUtils.pas' , + fqbDesign in 'fqbDesign.pas' {fqbDesign}, + fqbZLib in 'fqbZLib.pas' + ; + +end. diff --git a/official/4.8.11/FastQB/fqbClass.pas b/official/4.8.11/FastQB/fqbClass.pas new file mode 100644 index 0000000..d472c3e --- /dev/null +++ b/official/4.8.11/FastQB/fqbClass.pas @@ -0,0 +1,2361 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ } +{ Copyright (c) 2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbClass; + +interface + +uses + Windows, Messages, Classes, Controls, Menus, Forms, Graphics, StdCtrls, Grids, + DB, SysUtils, ExtCtrls, CheckLst, Buttons, Comctrls +{$IFDEF FQB_COM} + ,FastQueryBuilder_TLB + ,FastReport_TLB + ,VCLCOM + ,ComServ + ,ComObj +{$ENDIF} +{$IFDEF Delphi6} + ,Variants +{$ENDIF}; + +type + TfqbTable = class; + TfqbTableArea = class; + EfqbError = class(Exception) + end; + + TfqbField = class(TCollectionItem) + private + FFieldName: string; + FFielType: Integer; + FLinked: Boolean; + function GetFieldName: string; + public + property FieldName: string read GetFieldName write FFieldName; + property FieldType: Integer read FFielType write FFielType; + property Linked: Boolean read FLinked write FLinked; + end; + + TfqbFieldList = class(TOwnedCollection) + private + function GetItem(Index: Integer): TfqbField; + procedure SetItem(Index: Integer; const Value: TfqbField); + public + function Add: TfqbField; + property Items[Index: Integer]: TfqbField read GetItem write SetItem; default; + end; + + TfqbLink = class(TCollectionItem) + protected + FArea: TfqbTableArea; + FDestField: TfqbField; + FDestTable: TfqbTable; + FJOp: Integer; + FJType: Integer; + FMenu: TPopupMenu; + FSelected: Boolean; + FSourceField: TfqbField; + FSourceTable: TfqbTable; + procedure DoDelete(Sender: TObject); + procedure DoOptions(Sender: TObject); + procedure Draw; + function GetDestCoords: TPoint; + function GetSourceCoords: TPoint; + procedure SetSelected(const Value: Boolean); + public + constructor Create(Collection: TCollection); override; + destructor Destroy; override; + property DestCoords: TPoint read GetDestCoords; + property DestField: TfqbField read FDestField; + property DestTable: TfqbTable read FDestTable; + property JoinOperator: Integer read FJOp write FJOp; + property JoinType: Integer read FJType write FJType; + property Selected: Boolean read FSelected write SetSelected; + property SourceCoords: TPoint read GetSourceCoords; + property SourceField: TfqbField read FSourceField; + property SourceTable: TfqbTable read FSourceTable; + end; + + TfqbLinkList = class(TOwnedCollection) + private + function GetItem(Index: Integer): TfqbLink; + procedure SetItem(Index: Integer; const Value: TfqbLink); + public + function Add: TfqbLink; + property Items[Index: Integer]: TfqbLink read GetItem write SetItem; default; + end; + + TfqbCheckListBox = class(TCheckListBox) + protected + procedure ClickCheck; override; + procedure DragOver(Sender: TObject; X, Y: Integer; State: TDragState; var + Accept: Boolean); override; + public + procedure DragDrop(Sender: TObject; X, Y: Integer); override; + end; + + TfqbTable = class(TPanel) + private + FAliasName: string; + FButtonClose: TSpeedButton; + FButtonMinimize: TSpeedButton; + FCheckListBox: TfqbCheckListBox; + FFieldList: TfqbFieldList; + FImage: TImage; + FLabel: TLabel; + FOldHeight: Integer; + FTableName: string; + function GetSellectedField: TfqbField; + procedure SetTableName(const Value: string); + procedure SetXPStyle(const AComp: TControl); + protected + procedure CreateParams(var Params: TCreateParams); override; + function GetLinkPoint(AIndex: integer; ASide: char): TPoint; + procedure Resize; override; + procedure WMMove(var Message: TWMMove); message WM_MOVE; + procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure CMRelease(var Message: TMessage); message CM_RELEASE; + procedure _DoExit(Sender: TObject); + procedure _DoMinimize(Sender: TObject); + procedure _DoRestore(Sender: TObject); + property ChBox: TfqbCheckListBox read FCheckListBox; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure UpdateFieldList; + procedure UpdateLinkList; + property AliasName: string read FAliasName; + property FieldList: TfqbFieldList read FFieldList write FFieldList; + property SellectedField: TfqbField read GetSellectedField; + property TableName: string read FTableName write SetTableName; + end; + + TfqbTableArea = class(TScrollBox) + private + FCanvas: TCanvas; + FInstX: Integer; + FInstY: Integer; + FLinkList: TfqbLinkList; + protected + procedure Click; override; + function GenerateAlias(const ATableNAme: string): string; virtual; + function GetLineAtCursor: Integer; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function CompareFields(TableID1: integer; FIndex1: integer; TableID2: integer; + FIndex2: integer): Boolean; + procedure DragDrop(Source: TObject; X, Y: Integer); override; + procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var + Accept: Boolean); override; + function FindTable(const AName, AAlias: string): TfqbTable; + procedure InsertTable(const X, Y : integer; const Name: string); overload; + procedure InsertTable(const Name : string); overload; + property LinkList: TfqbLinkList read FLinkList; + end; + + TfqbTableListBox = class(TListBox) + protected + procedure DblClick; override; + procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); + override; + procedure CreateWnd; override; + public + constructor Create(AOwner: TComponent); override; + end; + + PGridColumn = ^TGridColumn; + TGridColumn = record + Table: string; + Alias: string; + Field: string; + Visibl: Boolean; + Where: string; + Sort: Integer; + Func: Integer; + Group: Integer; + end; + + TfqbEdit = class(TEdit) + private + FButton: TSpeedButton; + FOnButtonClick: TNotifyEvent; + FPanel: TPanel; + FShowButton: Boolean; + procedure SetShowButton(const Value: Boolean); + protected + procedure ButtonClick(Sender: TObject); + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure SetEditRect; + procedure WMSize(var Message: TWMSize); message WM_SIZE; + public + constructor Create(AOwner: TComponent); override; + property OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick; + property ShowButton: Boolean read FShowButton write SetShowButton; + end; + + TfqbColumnResizeEvent = procedure (Sender: TCustomListview; ColumnIndex: Integer; + ColumnWidth: Integer) of object; + TfqbGrid = class(TListView) + private + FEndColumnResizeEvent: TfqbColumnResizeEvent; + FFunctionList: TComboBox; + FGroupList: TComboBox; + FPopupMenu: TPopupMenu; + FSortList: TComboBox; + FVisibleList: TComboBox; + FWhereEditor: TfqbEdit; + procedure fqbOnChange(Sender: TObject); + procedure fqbOnMenu(Sender: TObject); + procedure fqbOnPopup(Sender: TObject); + procedure fqbOnSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean); + procedure fqbSetBounds(var Contr: TControl); + protected + procedure CreateWnd; override; + procedure DoColumnResize(ColumnIndex, ColumnWidth: Integer); virtual; + function FindColumnIndex(pHeader: pNMHdr): Integer; + function FindColumnWidth(pHeader: pNMHdr): Integer; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + override; + procedure RecalcColWidth; + procedure Resize; override; + procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY; + procedure WMVscroll(var Msg: TWMNotify); message WM_VSCROLL; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function AddColumn: Integer; + procedure Exchange(const AItm1, AItm2: integer); + procedure fqbUpdate; + procedure UpdateColumn; + property OnEndColumnResize: TfqbColumnResizeEvent read FEndColumnResizeEvent + write FEndColumnResizeEvent; + end; + + TfqbEngine = class(TComponent) + private + FShowSystemTables: Boolean; + public + procedure ReadFieldList(const ATableName: string; var AFieldList: TfqbFieldList); + virtual; abstract; + procedure ReadTableList(ATableList: TStrings); virtual; abstract; + function ResultDataSet: TDataSet; virtual; abstract; + procedure SetSQL(const Value: string); virtual; abstract; + published + property ShowSystemTables: Boolean read FShowSystemTables write + FShowSystemTables default False; + end; + +{$IFDEF FQB_COM} + TfqbDialog = class( TComponent, IFastQueryBuilder ) +{$ELSE} + TfqbDialog = class(TComponent) +{$ENDIF} + private + FEngine: TfqbEngine; + function GetSchemaInsideSQL: Boolean; + function GetSQL: string; + function GetSQLSchema: string; + procedure SetEngine(const Value: TfqbEngine); + procedure SetSchemaInsideSQL(const Value: Boolean); + procedure SetSQL(Value: string); + procedure SetSQLSchema(const Value: string); + protected +{$IFDEF FQB_COM} + function DesignQuery(const Param1: IfrxCustomQuery; out ModalResult: WordBool): HResult; stdcall; + function Get_SQL(out Value: WideString): HResult; stdcall; + function Set_SQL(const Value: WideString): HResult; stdcall; + function Get_SQLSchema(out Value: WideString): HResult; stdcall; + function Set_SQLSchema(const Value: WideString): HResult; stdcall; +{$ENDIF} + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + function Execute: Boolean; virtual; + property SQL: string read GetSQL write SetSQL; + property SQLSchema: string read GetSQLSchema write SetSQLSchema; + published + property Engine: TfqbEngine read FEngine write SetEngine; + property SchemaInsideSQL: Boolean read GetSchemaInsideSQL write + SetSchemaInsideSQL default True; + end; + + TfqbCore = class(TObject) + private + FEngine: TfqbEngine; + FGrid: TfqbGrid; + FSchemaInsideSQL: Boolean; + FSQL: string; + FSQLSchema: string; + FTableArea: TfqbTableArea; + FUseCoding: Boolean; + FText: string; + FUsingQuotes: Boolean; + function ExtractSchema(const Value: string): string; + function ExtractSQL(const Str: string): string; + function GetEngine: TfqbEngine; + function GetGrid: TfqbGrid; + function GetSQL: string; + function GetSQLSchema: string; + function GetTableArea: TfqbTableArea; + procedure SetSchemaInsideSQL(const Value: Boolean); + procedure SetSQL(Value: string); + procedure SetSQLSchema(const Value: string); + public + constructor Create; virtual; + destructor Destroy; override; + procedure Clear; + function GenerateSQL: string; + procedure LoadFromFile(const FileName: string); + procedure LoadFromStr(const Str: TStringList); + procedure RecognizeModel(const crc32: Cardinal; const FileName: string); + procedure SaveToFile(const FileName: string); + procedure SaveToStr(var Str: TStringList); + property Engine: TfqbEngine read GetEngine write FEngine; + property Grid: TfqbGrid read GetGrid write FGrid; + property SQL: string read GetSQL write SetSQL; + property SQLSchema: string read GetSQLSchema write SetSQLSchema; + property TableArea: TfqbTableArea read GetTableArea write FTableArea; + property SchemaInsideSQL: Boolean read FSchemaInsideSQL write SetSchemaInsideSQL + default True; + property UsingQuotes: Boolean read FUsingQuotes write FUsingQuotes; + + end; + + +function fqbCore: TfqbCore; + +const + StrFieldType : array [0..29] of string = (''{0}, 'String'{1}, 'Smallint'{2}, + 'Integer'{3}, 'Word'{4}, 'Boolean'{5}, 'Float'{6}, + 'Currency'{7}, 'BCD'{8}, 'Date'{9}, 'Time'{10}, + 'DateTime'{11}, 'Bytes'{12}, 'VarBytes'{13}, 'AutoInc'{14}, + 'Blob'{15}, 'Memo'{16}, 'Graphic'{17}, 'FmtMemo'{18}, + 'ParadoxOle'{19}, 'DBaseOle'{20}, 'TypedBinary'{21}, + 'Cursor'{22}, 'FixedChar'{23}, 'WideString'{24}, 'Largeint'{25}, + 'ADT'{26}, 'Array'{27}, 'Reference'{28}, 'DataSet'{29}); + + _fqbBeginModel = '/*_FQBMODEL'; + _fqbEndModel = '_FQBEND*/'; + +implementation + +{$R images.res} + +uses Math, IniFiles, Dialogs, Commctrl, fqbDesign, fqbLinkForm, fqbUtils, + fqbRes, fqbrcDesign + {$IFDEF Delphi7} + ,Themes + {$ENDIF} + {$IFDEF FQB_COM} + ,frxCustomDB + {$ENDIF} + ; + +const + clSelectedLink = clGreen; + clNotSelectedLink = clBlack; + + LinkType: array[0..5] of string = ('=', '>', '<', '>=', '<=', '<>'); + JoinType: array[0..3] of string = ('INNER JOIN', 'LEFT OUTER JOIN', + 'RIGHT OUTER JOIN', 'FULL OUTER JOIN'); + + rowColumn = 0; + rowVisibility = 1; + rowWhere = 2; + rowSort = 3; + rowFunction = 4; + rowGroup = 5; + + CompatibleIntTypes = [2, 3, 4, 12, 14]; + CompatibleDateTimeTypes = [9, 10, 11]; + CompatibleFloatTypes = [6, 7]; + +type + TcrTControl = class(TControl) + end; + +var + FfqbCore: TfqbCore = nil; + FExternalCreation: Boolean = True; + +function fqbCore: TfqbCore; +begin + if FfqbCore = nil then + begin + FExternalCreation := False; + try + FfqbCore := TfqbCore.Create; + finally + FExternalCreation := True; + end; + end; + Result := FfqbCore; +end; + +function FindFQBcomp(const AClassName: string; const Source: TComponent): TComponent; + var + i: integer; +begin + Result := nil; + if UpperCase(Source.ClassName) = UpperCase(AClassName) then + Result := Source + else + for i := 0 to Source.ComponentCount - 1 do + if Result = nil then + Result := FindFQBcomp(AClassName, Source.Components[i]) + else + Exit +end; + +{----------------------- TfqbField -----------------------} +function TfqbField.GetFieldName: string; +begin + if ((Pos(' ', FFieldName) > 0) or (Pos('/', FFieldName) > 0) + or ((UpperCase(FFieldName) <> FFieldName)) and fqbCore.UsingQuotes) then + Result := '"' + FFieldName + '"' + else + Result := FFieldName +end; + +{----------------------- TfqbFieldList -----------------------} +function TfqbFieldList.Add: TfqbField; +begin + Result := TfqbField(inherited Add) +end; + +function TfqbFieldList.GetItem(Index: Integer): TfqbField; +begin + Result := TfqbField(inherited Items[Index]) +end; + +procedure TfqbFieldList.SetItem(Index: Integer; const Value: TfqbField); +begin + Items[Index].Assign(Value) +end; + +{----------------------- TfqbLinkList -----------------------} +function TfqbLinkList.Add: TfqbLink; +begin + Result := TfqbLink(inherited Add) +end; + +function TfqbLinkList.GetItem(Index: Integer): TfqbLink; +begin + Result := TfqbLink(inherited Items[Index]) +end; + +procedure TfqbLinkList.SetItem(Index: Integer; const Value: TfqbLink); +begin + Items[Index].Assign(Value) +end; + +{----------------------- TfqbLink -----------------------} +constructor TfqbLink.Create(Collection: TCollection); +var + tmp: TMenuItem; +begin + inherited Create(Collection); + FJOp := 0; + FJType:= 0; + FMenu:= TPopupMenu.Create(nil); + tmp:= TMenuItem.Create(FMenu); + tmp.Caption:= 'Link options'; + tmp.OnClick:= DoOptions; + FMenu.Items.Add(tmp); + tmp:= TMenuItem.Create(FMenu); + tmp.Caption:= 'Delete'; + tmp.OnClick:= DoDelete; + FMenu.Items.Add(tmp) +end; + +destructor TfqbLink.Destroy; +begin + SourceField.Linked := false; + DestField.Linked := false; + FMenu.Free; + inherited Destroy; +end; + +procedure TfqbLink.DoDelete(Sender: TObject); +begin + Free +end; + +procedure TfqbLink.DoOptions(Sender: TObject); +var + fqbLinkForm: TfqbLinkForm; +begin + fqbLinkForm := TfqbLinkForm.Create(nil); + try + fqbLinkForm.txtTable1.Caption := SourceTable.TableName; + fqbLinkForm.txtCol1.Caption := SourceField.FieldName; + fqbLinkForm.txtTable2.Caption := DestTable.TableName; + fqbLinkForm.txtCol2.Caption := DestField.FieldName;; + fqbLinkForm.RadioOpt.ItemIndex := JoinOperator; + fqbLinkForm.RadioType.ItemIndex := JoinType; + if fqbLinkForm.ShowModal = mrOk then + begin + JoinOperator := fqbLinkForm.RadioOpt.ItemIndex; + JoinType := fqbLinkForm.RadioType.ItemIndex + end; + finally + fqbLinkForm.Free + end +end; + +procedure TfqbLink.Draw; +var + pnt1, pnt2: TPoint; + cnt1, cnt2: Integer; + dSrc, dDest: Integer; + + const Delta = 15; + +begin + pnt1:= SourceCoords; + pnt2:= DestCoords; + cnt1:= SourceTable.BoundsRect.Left + (SourceTable.Width div 2); + cnt2:= DestTable.BoundsRect.Left + (DestTable.Width div 2); + if cnt1 < cnt2 then + begin + dSrc:= Delta; + dDest:= -Delta + end + else + begin + dSrc:= -Delta; + dDest:= Delta + end; + FArea.FCanvas.MoveTo(pnt1.x, pnt1.y); + FArea.FCanvas.Pen.Color:= clNotSelectedLink; + FArea.FCanvas.Pen.Width:= 3; + FArea.FCanvas.LineTo(pnt1.x + dSrc, pnt1.y); + FArea.FCanvas.Pen.Width:= 1; + if Selected then + FArea.FCanvas.Pen.Color:= clSelectedLink + else + FArea.FCanvas.Pen.Color:= clNotSelectedLink; + FArea.FCanvas.LineTo(pnt2.x + dDest, pnt2.y); + FArea.FCanvas.Pen.Width:= 3; + FArea.FCanvas.Pen.Color:= clNotSelectedLink; + FArea.FCanvas.LineTo(pnt2.x, pnt2.y) +end; + +function TfqbLink.GetDestCoords: TPoint; +var + cnt1, cnt2: Integer; +begin + cnt1:= SourceTable.BoundsRect.Left + (SourceTable.Width div 2); + cnt2:= DestTable.BoundsRect.Left + (DestTable.Width div 2); + + if cnt1 < cnt2 then + Result:= DestTable.GetLinkPoint(DestField.Index,'L') + else + Result:= DestTable.GetLinkPoint(DestField.Index,'R') +end; + +function TfqbLink.GetSourceCoords: TPoint; +var + cnt1, cnt2: Integer; +begin + cnt1:= SourceTable.BoundsRect.Left + (SourceTable.Width div 2); + cnt2:= DestTable.BoundsRect.Left + (DestTable.Width div 2); + + if cnt1 < cnt2 then + Result:= SourceTable.GetLinkPoint(SourceField.Index,'R') + else + Result:= SourceTable.GetLinkPoint(SourceField.Index,'L') +end; + +procedure TfqbLink.SetSelected(const Value: Boolean); +var + i: Integer; +begin + for i:= 0 to Collection.Count - 1 do + TfqbLinkList(Collection).Items[i].FSelected := false; + FSelected := Value +end; + +{----------------------- TfqbTableArea -----------------------} +constructor TfqbTableArea.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FCanvas := TControlCanvas.Create; + TControlCanvas(FCanvas).Control := Self; + Color := clBtnFace; + FCanvas.Brush.Color := clBtnFace; + + FLinkList := TfqbLinkList.Create(Self, TfqbLink); + + FInstX := 15; + FInstY := 15; +end; + +destructor TfqbTableArea.Destroy; +begin + FCanvas.Free; + FLinkList.Free; + inherited Destroy; +end; + +procedure TfqbTableArea.Click; +var + n: Integer; +begin + n := GetLineAtCursor; + if ((n >= 0) and (n < LinkList.Count)) then + begin + LinkList[n].Selected := true; + Invalidate; + LinkList[n].FMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y) + end; + inherited Click; +end; + +function TfqbTableArea.CompareFields(TableID1: integer; FIndex1: integer; TableID2: + integer; FIndex2: integer): Boolean; +var + tp1, tp2: Integer; +begin + if ((TableID1 > ComponentCount) or (TableID2 > ComponentCount)) then + Result := false + else + begin + tp1 := TfqbTable(Components[TableID1]).FieldList[Findex1].FieldType; + tp2 := TfqbTable(Components[TableID2]).FieldList[Findex2].FieldType; + + if ((tp1 in CompatibleIntTypes) + and (tp2 in CompatibleIntTypes)) then + Result := True + else + if ((tp1 in CompatibleDateTimeTypes) + and (tp2 in CompatibleDateTimeTypes)) then + Result := True + else + if ((tp1 in CompatibleFloatTypes) + and (tp2 in CompatibleFloatTypes)) then + Result := True + else + Result := TfqbTable(Components[TableID1]).FieldList[Findex1].FieldType = + TfqbTable(Components[TableID2]).FieldList[Findex2].FieldType + end +end; + +procedure TfqbTableArea.DragDrop(Source: TObject; X, Y: Integer); +begin + InsertTable(X, Y, (Source as TfqbTableListBox).Items[(Source as TfqbTableListBox).ItemIndex]) +end; + +procedure TfqbTableArea.DragOver(Source: TObject; X, Y: Integer; State: TDragState; + var Accept: Boolean); +begin + Accept := Source is TfqbTableListBox +end; + +function TfqbTableArea.FindTable(const AName, AAlias: string): TfqbTable; +var + i: Integer; +begin + Result:= nil; + for i:= 0 to ComponentCount - 1 do + if ((TfqbTable(Components[i]).TableName = AName) and + (TfqbTable(Components[i]).AliasName = AAlias)) then + Result:= TfqbTable(Components[i]) +end; + +function TfqbTableArea.GenerateAlias(const ATableNAme: string): string; +var + n: Integer; + + function FindDublicat(AAlias: string): boolean; + var i: integer; + begin + Result:= False; + for i:= 0 to ComponentCount - 1 do + begin + if AAlias = TfqbTable(Components[i]).AliasName then + begin + Result:= True; + Break + end + end + end; + +begin + Result:= ATableName[1]; + n:=1; + while FindDublicat(Result) do + begin + Result:= ATableName[1] + IntToStr(n); + Inc(n) + end +end; + +function TfqbTableArea.GetLineAtCursor: Integer; + + procedure SwapInt(var X, Y: Integer); + var + T: Integer; + begin + T := X; + X := Y; + Y := T + end; + + function InRange(const AValue, AMin, AMax: Integer): Boolean; + begin + Result := (AValue >= AMin) and (AValue <= AMax) + end; + + const + sf = 6; //Scale factor + var + i,TX1, TX2, TY1,TY2,X1,Y1, + X2,Y2,Lx, Ly, C: integer; + MousePos: TPoint; + Delta: Real; + +begin + Result:= - 1; + for i:= 0 to LinkList.Count - 1 do + begin + MousePos:= Mouse.CursorPos; + MousePos:= ScreenToClient(MousePos); + X1:= TfqbLink(LinkList[i]).GetSourceCoords.X; + X2:= TfqbLink(LinkList[i]).GetDestCoords.X; + Y1:= TfqbLink(LinkList[i]).GetSourceCoords.Y; + Y2:= TfqbLink(LinkList[i]).GetDestCoords.Y; + TX1:= X1; + TX2:= X2; + TY1:= Y1; + TY2:= Y2; + if TX1> TX2 then SwapInt(TX1, TX2); + if TY1> TY2 then SwapInt(TY1, TY2); + Lx:= X2-X1; + Ly:= Y2-Y1; + C:= -Ly*X1 + Lx*Y1; + Delta:= Sqrt(Power((X1-X2), 2) + Power((Y1-Y2), 2)) * sf; + if (Abs(-Ly*MousePos.X + Lx*MousePos.Y - C)<= Delta) and + InRange(MousePos.X, TX1 - sf, TX2 + sf) and + InRange(MousePos.Y, TY1 - sf, TY2 + sf) then + begin + Result:= i; + break + end + end +end; + +procedure TfqbTableArea.InsertTable(const X, Y : integer; const Name: string); +var + tmp: TfqbTable; +begin + tmp := TfqbTable.Create(Self); + tmp.Left := X; + tmp.Top := Y; + tmp.Parent := Self; + tmp.TableName := Name; + fqbCore.Engine.ReadFieldList(Name, tmp.FFieldList); + tmp.UpdateFieldList +end; + +procedure TfqbTableArea.InsertTable(const Name : string); +begin + InsertTable(FInstX, FInstY, Name); + + if FInstY > Height then + FInstY:= 15 + else + FInstY:= FInstY + 15; + + if FInstX > Width then + FInstX := 15 + else + FInstX:= FInstX + 15 +end; + +procedure TfqbTableArea.WMPaint(var Message: TWMPaint); +var + i: Integer; + + {$IFDEF TRIAL} + str: string; + l, dx: integer; + {$ENDIF} + +begin + inherited; + {$IFDEF TRIAL} + FCanvas.Font.Size := 50; + FCanvas.Font.Color:= clRed; + FCanvas.Font.Name := 'Tahoma'; + str := 'deretsigern'; + l := FCanvas.TextWidth(str + 'U'); + dx := (Width div 2) - (l div 2); + FCanvas.TextOut(dx, 100, 'U'); + for i := 11 downto 1 do + FCanvas.TextOut(FCanvas.PenPos.x, FCanvas.PenPos.y, str[i]); + {$ENDIF} + for i := 0 to LinkList.Count - 1 do + LinkList[i].Draw +end; + +{----------------------- TfqbTable -----------------------} +constructor TfqbTable.Create(AOwner: TComponent); +begin + inherited; + + Width := 130; + Height := 150; + BevelOuter := bvNone; + BorderWidth := 1; + + FLabel := TLabel.Create(Self); + with FLabel do + begin + Parent := Self; + Align := alTop; + Color := clActiveCaption; + Font.Charset := DEFAULT_CHARSET; + Font.Color := clCaptionText; + AutoSize := False; + Height := Height + 6; + Font.Size := Font.Size + 1; + Layout := tlCenter; + SetXPStyle(FLabel); + end; + + FImage := TImage.Create(Self); + with FImage do + begin + Parent := Self; + Top := 3; + Left := 3; + Width := 16; + Height := 16; + AutoSize := True; + FImage.Picture.Bitmap.LoadFromResourceName(HInstance,'TABLEIMAGE1'); + Transparent := True; + SetXPStyle(FImage); + end; + + FButtonClose := TSpeedButton.Create(Self); + with FButtonClose do + begin + Parent := Self; + Top := 3; + Width := 17; + Height := 15; + OnClick := _DoExit; + Glyph.LoadFromResourceName(HInstance,'BTN_CLOSE'); + end; + + FButtonMinimize := TSpeedButton.Create(Self); + with FButtonMinimize do + begin + Parent := Self; + Top := 3; + Width := 17; + Height := 15; + OnClick := _DoMinimize; + Glyph.LoadFromResourceName(HInstance,'BTN_MINI'); + end; + + FCheckListBox := TfqbCheckListBox.Create(Self); + with FCheckListBox do + begin + Parent := Self; + Align := alClient; + ItemHeight := 13; + Style := lbOwnerDrawVariable; + DragMode := dmAutomatic + end; + + Constraints.MinHeight := FLabel.Height + 8; + Constraints.MinWidth := 120; + + Caption := ''; + FFieldList := TfqbFieldList.Create(Self, TfqbField); + DragMode := dmAutomatic; + DoubleBuffered := true; + ShowHint := False; + Height := 200; + Width := 150; + + SetXPStyle(Self); +end; + +destructor TfqbTable.Destroy; +var + i: Integer; +begin + if GetParentForm(Self) <> nil then + begin + for i:= fqbCore.Grid.Items.Count - 1 downto 0 do + begin + if TGridColumn(fqbCore.Grid.Items[i].Data^).Table = TableName then + begin + FreeMem(fqbCore.Grid.Items[i].Data,SizeOf(TGridColumn)); + fqbCore.Grid.Items[i].Delete; + end + end; + fqbCore.Grid.UpdateColumn + end; + UpdateLinkList; + + FLabel.Free; + FCheckListBox.Free; + FFieldList.Free; + FImage.Free; + FButtonClose.Free; + FButtonMinimize.Free; + + if Parent <> nil then + begin + Parent.Invalidate; + Parent:= nil + end; + inherited +end; + +procedure TfqbTable.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + with Params do + begin + Style:= Style or WS_SIZEBOX; + WindowClass.Style:= WindowClass.Style xor CS_VREDRAW + end +end; + +function TfqbTable.GetLinkPoint(AIndex: integer; ASide: char): TPoint; +var + tmpRec: TRect; +begin + tmpRec := ChBox.ItemRect(AIndex); + tmpRec.Top := tmpRec.Top + FLabel.Height + (ChBox.Height - ChBox.ClientHeight); + tmpRec.Bottom := tmpRec.Bottom + FLabel.Height + (ChBox.Height - ChBox.ClientHeight); + + if tmpRec.Bottom > ClientHeight then + Result.y := ClientHeight + else + if tmpRec.Top < 0 then + Result.y := 0 + else + Result.y := tmpRec.Top + (tmpRec.Bottom - tmpRec.Top) div 2; + + Result := Parent.ScreenToClient(ClientToScreen(Result)); + + // if ASide = 'L' then Left side else if ASide = 'R' then Right side + if ASide = 'L' then + Result.x := BoundsRect.Left + else + Result.x := BoundsRect.Right +end; + +function TfqbTable.GetSellectedField: TfqbField; +begin + Result := FFieldList[ChBox.ItemIndex] +end; + +procedure TfqbTable.Resize; +begin + inherited Resize; + FButtonClose.Left := Width - 25; + FButtonMinimize.Left := Width - 42 +end; + +procedure TfqbTable.SetTableName(const Value: string); + + function GetSpace(const Width: integer):string; + begin + Result := ''; + repeat + Result := Result + ' ' + until FLabel.Canvas.TextWidth(Result) > Width + end; + +begin + FTableName := Value; + FAliasName:= TfqbTableArea(Parent).GenerateAlias(Value); + FLabel.Caption := GetSpace(FImage.Width + 2) + Value + ' - ' + FAliasName +end; + +procedure TfqbTable.SetXPStyle(const AComp: TControl); +begin + {$IFDEF Delphi7} + if ThemeServices.ThemesEnabled then + AComp.ControlStyle := AComp.ControlStyle - [csParentBackground] + [csOpaque]; + {$ENDIF}; +end; + +procedure TfqbTable.UpdateFieldList; +var + i: Integer; +begin + ChBox.Items.BeginUpdate; + ChBox.Items.Clear; + if FFieldList.Count > 0 then + ChBox.Items.Add(TfqbField(FFieldList[0]).FieldName); + for i:= 1 to FFieldList.Count - 1 do + ChBox.Items.Add(TfqbField(FFieldList[i]).FieldName + ' (' + + StrFieldType[TfqbField(FFieldList[i]).FieldType] + ')'); + ChBox.Items.EndUpdate +end; + +procedure TfqbTable.UpdateLinkList; +var + i: Integer; +begin + if Parent = nil then Exit; + for i:= (Parent as TfqbTableArea).LinkList.Count - 1 downto 0 do + if (((Parent as TfqbTableArea).LinkList[i].SourceTable = self) or ((Parent as TfqbTableArea).LinkList[i].DestTable = self)) then + (Parent as TfqbTableArea).LinkList[i].Free +end; + +procedure TfqbTable.WMMove(var Message: TWMMove); +begin + inherited; + Parent.Invalidate +end; + +procedure TfqbTable.WMNCHitTest(var M: TWMNCHitTest); +var + x: Integer; +begin + inherited; + x := ClientToScreen(Point(FButtonMinimize.Left,0)).X; + if ((M.Result = htClient) and (M.XPos - x < 0)) then + M.Result := htCaption +end; + +procedure TfqbTable.WMPaint(var Message: TWMPaint); +begin + inherited; + Parent.Invalidate +end; + +procedure TfqbTable._DoExit(Sender: TObject); +begin + PostMessage(Handle, CM_RELEASE, 0, 0); +end; + +procedure TfqbTable._DoMinimize(Sender: TObject); +begin + FOldHeight := Height; + Height := 0; + FButtonMinimize.OnClick := _DoRestore +end; + +procedure TfqbTable._DoRestore(Sender: TObject); +begin + Height := FOldHeight; + FButtonMinimize.OnClick := _DoMinimize +end; + +{----------------------- TfqbTableListBox -----------------------} +constructor TfqbTableListBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + DragMode := dmAutomatic; +end; + +procedure TfqbTableListBox.CreateWnd; +begin + Style := lbOwnerDrawFixed; + ItemHeight := 18; + inherited; +end; + +procedure TfqbTableListBox.DblClick; +begin + inherited DblClick; + fqbCore.TableArea.InsertTable(Items[ItemIndex]) +end; + +procedure TfqbTableListBox.DrawItem(Index: Integer; Rect: TRect; State: + TOwnerDrawState); +var + Bitmap: TBitmap; + BMPRect: TRect; +begin + inherited DrawItem(Index, Rect, State); + Canvas.FillRect(Rect); + Bitmap := TBitmap.Create; + Bitmap.LoadFromResourceName(HInstance,'TABLEIMAGE1'); + if Bitmap <> nil then + begin + BMPRect := Bounds(Rect.Left + 3, Rect.Top + 1, 16, 16); + Canvas.BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), + Bitmap.Canvas.Pixels[0, Bitmap.Height-1]); + end; + Canvas.TextOut(Rect.Left+24, Rect.Top+2, Items[Index]); + Bitmap.Free +end; + +{----------------------- TfqbDialog -----------------------} +constructor TfqbDialog.Create(AOwner: TComponent); +begin + inherited; + fqbCore.SchemaInsideSQL := True; +end; + +function TfqbDialog.Execute: Boolean; +var + tmp: TStringList; +begin + {$IFDEF TRIAL} + ShowMessage(' Fast Query Builder'#10#13'Unregistered version'); + {$ENDIF} + fqbDesigner := TfqbDesigner.Create(Self); + fqbCore.Engine := Engine; + fqbCore.Grid := fqbDesigner.fqbGrid1; + fqbCore.TableArea := fqbDesigner.fqbTableArea1; + + tmp:= TStringList.Create; + tmp.Text := fqbCore.FText; + try + try + fqbCore.LoadFromStr(tmp); + except + end; + + if fqbDesigner.ShowModal = mrOk then + begin + tmp.Clear; + fqbCore.SaveToStr(tmp); + fqbCore.FText := tmp.Text; + Result := true + end + else + Result := false; + fqbCore.Clear; + finally + tmp.Free; + fqbDesigner.Free + end +end; + +{$IFDEF FQB_COM} +function TfqbDialog.DesignQuery( + const Param1: IfrxCustomQuery; + out ModalResult: WordBool): HResult; stdcall; +var + SQLText: WideString; + SQLSchemaText: WideString; + idsp: IInterfaceComponentReference; + obj: TComponent; //TfqbEngine; +begin + try + Result := Param1.QueryInterface( IInterfaceComponentReference, idsp); + if Result = S_OK then + begin + obj := idsp.GetComponent; + if obj is TfrxCustomQuery then + begin + Engine := TfrxCustomQuery(obj).QBEngine; + SchemaInsideSQL := False; + Param1.Get_SQL(SQLText); + SQL := SQLText; + Param1.Get_SQLSchema(SQLSchemaText); + SQLSchema := SQLSchemaText; + ModalResult := Execute; + end + else + begin + ShowMessage(' Fast Query Builder'#10#13'Received object is not TfrxCustomQuery'); + end + end; + except + Result := E_FAIL; + end; +end; + +function TfqbDialog.Get_SQL(out Value: WideString): HResult; stdcall; +begin + Value := SQL; + Result := S_OK; +end; +function TfqbDialog.Set_SQL(const Value: WideString): HResult; stdcall; +begin + SQL := Value; + Result := S_OK; +end; +function TfqbDialog.Get_SQLSchema(out Value: WideString): HResult; stdcall; +begin + Value := SQLSchema; + Result := S_OK; +end; +function TfqbDialog.Set_SQLSchema(const Value: WideString): HResult; stdcall; +begin + SQLSchema := Value; + Result := S_OK; +end; +{$ENDIF} + +function TfqbDialog.GetSchemaInsideSQL: Boolean; +begin + Result := fqbCore.SchemaInsideSQL; +end; + +function TfqbDialog.GetSQL: string; +begin + Result := fqbCore.SQL; +end; + +function TfqbDialog.GetSQLSchema: string; +begin + Result := fqbCore.SQLSchema; +end; + +procedure TfqbDialog.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FEngine) and (Operation = opRemove) then + begin + FEngine := nil; + fqbCore.Engine := nil; + end; +end; + +procedure TfqbDialog.SetEngine(const Value: TfqbEngine); +begin + if FEngine <> Value then + begin + FEngine := Value; + fqbCore.Engine := Value; + FreeNotification(FEngine); + end +end; + +procedure TfqbDialog.SetSchemaInsideSQL(const Value: Boolean); +begin + fqbCore.SchemaInsideSQL := Value; +end; + +procedure TfqbDialog.SetSQL(Value: string); +begin + fqbCore.SQL := Value; +end; + +procedure TfqbDialog.SetSQLSchema(const Value: string); +begin + fqbCore.SQLSchema := Value; +end; + +{----------------------- TfqbCore -----------------------} +constructor TfqbCore.Create; +begin + if FfqbCore <> nil then + raise EfqbError.Create('TfqbCore class already initialized.'); + if FExternalCreation then + raise EfqbError.Create('Call fqbCore function to reference this class.'); + inherited; + FUseCoding := True; + FUsingQuotes := False; +end; + +destructor TfqbCore.Destroy; +begin + FfqbCore := nil; + inherited; +end; + +procedure TfqbCore.Clear; +var + i: Integer; +begin + for i:= Grid.Items.Count - 1 downto 0 do + Dispose(PGridColumn(Grid.Items[i].Data)); + Grid.Items.Clear; + + for i := TableArea.ComponentCount - 1 downto 0 do + TableArea.Components[i].Free +end; + +function TfqbCore.ExtractSchema(const Value: string): string; +var + e, b: Integer; +begin + b := Pos(_fqbBeginModel, Value) + Length(_fqbBeginModel); + e := Pos(_fqbEndModel, Value); + if not (e = 0) then + begin + Result := Copy(Value, b, e-b); + Result := fqbTrim(Result, [#10, #13]); + end + else + Result := Value; +end; + +function TfqbCore.ExtractSQL(const Str: string): string; +var + e, b: Integer; +begin + b := Pos(_fqbBeginModel, Str); + e := Pos(_fqbEndModel, Str); + Result := Str; + Delete(Result, b, e); +end; + +function TfqbCore.GenerateSQL: string; + + const + strTab = ' '; + strSel = 'SELECT '; + strFrom = 'FROM'; + strWhere = 'WHERE'; + strOrder = 'ORDER BY '; + strGroup = 'GROUP BY '; + var + i: integer; + tmpStr, orderStr, prd, groupStr: string; + slFrom, slWhere: TStringList; + Tbl1, Tbl2, Tbl3: TfqbTable; + CopyLL: TList; + flg: boolean; + SQL: TStringList; + + function FormingFrom(const Ind: integer):string; + var + tmp: TfqbLink; + begin + tmp := TableArea.LinkList[Ind]; + Result := {strTab + }JoinType[tmp.JoinType] + ' ' + + Tbl2.TableName + ' ' + Tbl2.AliasName + ' ON (' + + Tbl1.AliasName + '.' + tmp.SourceField.FieldName + + LinkType[tmp.JoinOperator] + + Tbl2.AliasName + '.' + tmp.DestField.FieldName + ')' + end; + + function FormingFromAnd(const Ind: integer):string; + var + tmp: TfqbLink; + begin + tmp := TfqbLink(TableArea.LinkList[Ind]); + Result := ' AND (' + + Tbl1.AliasName + '.' + tmp.SourceField.FieldName + + LinkType[tmp.JoinOperator] + + Tbl3.AliasName + '.' + tmp.DestField.FieldName + ') ' + end; + +begin + if Grid.Items.Count = 0 then Exit; + + SQL := TStringList.Create; + //SELECT + tmpStr := strSel; + + for i := 0 to Grid.Items.Count - 1 do + + if TGridColumn(Grid.Items[i].Data^).Visibl then + begin + + if Grid.Items[i].SubItems[rowFunction - 1] <> '' then + prd := Grid.Items[i].SubItems[rowFunction - 1] + '(' + else + prd := ''; + + tmpStr := tmpStr + prd + TGridColumn(Grid.Items[i].Data^).Alias + '.' + + TGridColumn(Grid.Items[i].Data^).Field; + + if prd <> '' then prd := ')'; + + tmpStr := tmpStr + prd + ', ' + end; + tmpStr := Copy(tmpStr,1,Length(tmpStr) - 2); + SQL.Add(tmpStr); + + //FROM + tmpStr := ''; + slFrom := TStringList.Create; + CopyLL := TList.Create; + for i := 0 to TableArea.LinkList.Count - 1 do + CopyLL.Add(Pointer(i)); + while CopyLL.Count <> 0 do + begin + Tbl1 := TableArea.LinkList[0].SourceTable; + Tbl2 := TableArea.LinkList[0].DestTable; + slFrom.Add(strTab + Tbl1.TableName + ' ' + Tbl1.AliasName); + slFrom.Add(strTab + FormingFrom(0)); + for i := 1 to CopyLL.Count - 1 do + begin + Tbl3 := TableArea.LinkList[i].DestTable; + + if (Tbl3.AliasName = Tbl2.AliasName) then + begin + slFrom[slFrom.Count - 1] := slFrom[slFrom.Count - 1] + FormingFromAnd(Integer(CopyLL[i])); + CopyLL[i] := Pointer(-1); + end + else + begin + Tbl1 := TableArea.LinkList[Integer(CopyLL[i])].SourceTable; + Tbl2 := Tbl3; + slFrom.Add(strTab + FormingFrom(Integer(CopyLL[i]))); + CopyLL[i] := Pointer(-1) + end + + end; + CopyLL.Delete(0); + for i := CopyLL.Count - 1 downto 0 do + if Integer(CopyLL[i]) = -1 then CopyLL.Delete(i) + end; + + flg := false; + for i := 0 to Grid.Items.Count - 1 do + begin + tmpStr := TGridColumn(Grid.Items[i].Data^).Table + ' ' + + TGridColumn(Grid.Items[i].Data^).Alias; + + if Pos(tmpStr, slFrom.Text) = 0 then + begin + if slFrom.Count <> 0 then + slFrom[slFrom.Count - 1] := slFrom[slFrom.Count - 1] + ', '; + + slFrom.Add(strTab + tmpStr); + flg := true + end + end; + + if flg then + slFrom.Text := Copy(slFrom.Text,1,Length(slFrom.Text) - 2); + + CopyLL.Free; + + //WHERE + slWhere := TStringList.Create; + for i := 0 to Grid.Items.Count - 1 do + if TGridColumn(Grid.Items[i].Data^).Where <> '' then + slWhere.Add(strTab + TGridColumn(Grid.Items[i].Data^).Alias + '.' + + TGridColumn(Grid.Items[i].Data^).Field + ' ' + + TGridColumn(Grid.Items[i].Data^).Where + ' AND'); + + if slWhere.Count <> 0 then + begin + slWhere.Text:= Copy(slWhere.Text,1,Length(slWhere.Text) - 6); + slWhere.Insert(0,strWhere) + end; + + //ORDER + orderStr:= ''; + prd:= ''; + flg:= false; + for i:= 0 to Grid.Items.Count - 1 do + begin + if TGridColumn(Grid.Items[i].Data^).Sort <> 0 then + begin + if TGridColumn(Grid.Items[i].Data^).Sort = 2 then + prd := 'DESC' + else + prd := ''; + orderStr:= orderStr + TGridColumn(Grid.Items[i].Data^).Alias + '.' + + TGridColumn(Grid.Items[i].Data^).Field + ' ' + prd + ', '; + flg:= true; + end; + end; + if flg then + orderStr := Trim(Copy(orderStr,1,Length(orderStr) - 2)); + + //GROUP + groupStr:= ''; + flg:= false; + for i:= 0 to Grid.Items.Count - 1 do + begin + if TGridColumn(Grid.Items[i].Data^).Group <> 0 then + begin + groupStr:= groupStr + TGridColumn(Grid.Items[i].Data^).Alias + '.' + + TGridColumn(Grid.Items[i].Data^).Field + ', '; + flg:= true; + end; + end; + if flg then groupStr:= Copy(groupStr,1,Length(groupStr) - 2); + + SQL.Add(strFrom); + SQL.AddStrings(slFrom); + SQL.AddStrings(slWhere); + + if groupStr <> '' then SQL.Add(strGroup + groupStr); + + if orderStr <> '' then SQL.Add(strOrder + orderStr); + + slFrom.Free; + slWhere.Free; + + FText := SQL.Text; + Result := SQL.Text; + SQL.Free +end; + +function TfqbCore.GetEngine: TfqbEngine; +begin + Result := FEngine; + if not Assigned(FEngine) then + raise EfqbError.Create('fqbCore.Engine not assigned'); + +end; + +function TfqbCore.GetGrid: TfqbGrid; +begin + Result := FGrid; + if not Assigned(FGrid) then + raise EfqbError.Create('fqbCore.Grid not assigned'); +end; + +function TfqbCore.GetSQL: string; +begin + if SchemaInsideSQL then + Result := Ftext + else + Result := fqbCore.ExtractSQL(Ftext); +end; + +function TfqbCore.GetSQLSchema: string; +begin + if SchemaInsideSQL then + Result := '' + else + Result := fqbCore.ExtractSchema(Ftext); +end; + +function TfqbCore.GetTableArea: TfqbTableArea; +begin + Result := FTableArea; + if not Assigned(FTableArea) then + raise EfqbError.Create('fqbCore.TableArea not assigned'); +end; + +procedure TfqbCore.LoadFromFile(const FileName: string); +var + StrLst, StrSrc: TStringList; + tmp, tmp2: string; +begin + StrLst := TStringList.Create; + StrSrc := TStringList.Create; + StrSrc.LoadFromFile(FileName); + + try + tmp2 := ExtractSQL(StrSrc.Text); + tmp := ExtractSchema(StrSrc.Text); + + if fqbCore.FUseCoding then + begin + tmp := fqbTrim(tmp, [#10,#13]); + if tmp = '' then Exit; + tmp:= fqbDeCompress(tmp) + end; + + StrLst.Clear; + StrLst.Text := tmp; + + tmp := fqbGetUniqueFileName('fqb'); + StrLst.SaveToFile(tmp); + tmp2 := fqbTrim(tmp2, [#10,#13]); + fqbCore.RecognizeModel(fqbStringCRC32(tmp2), tmp); + finally + DeleteFile(tmp); + + StrLst.Free; + StrSrc.Free; + end; +end; + +procedure TfqbCore.LoadFromStr(const Str: TStringList); +var + tmp: string; +begin + tmp := fqbGetUniqueFileName('fqb'); + Str.SaveToFile(tmp); + try + fqbCore.LoadFromFile(tmp); + finally + DeleteFile(tmp) + end +end; + +procedure TfqbCore.RecognizeModel(const crc32: Cardinal; const FileName: string); +var + fqbFile: TIniFile; + tbl: TStringList; + i: Integer; + Rec: TRect; + parstr, tmpstr: string; + vis: TfqbTable; + lnk: TfqbLink; + c: Cardinal; + + function IndexOf(const FieldName: string): integer; + var + i: integer; + begin + Result:= -1; + for i:= 0 to vis.FieldList.Count - 1 do + if TfqbField(vis.FieldList[i]).FieldName = FieldName then + Result:= i; + end; + +begin + fqbFile:= TIniFile.Create(FileName); + tbl:= TStringList.Create; + tmpstr := fqbFile.ReadString('DataBase','SQL',''); + c := StrToInt64(tmpstr); + if c <> crc32 then + begin + ShowMessage('The file was changed. The Model can not be loaded.'); + fqbFile.Free; + tbl.Free; + Exit + end; + try + fqbCore.Engine.ReadTableList(TfqbTableListBox(FindFQBcomp('TfqbTableListBox',GetParentForm(TableArea))).Items); + fqbFile.ReadSectionValues('Tables',tbl); + try + for i:= 0 to tbl.Count - 1 do + begin + parstr:= tbl.Values[tbl.Names[i]]; + tmpstr:= fqbParse(',',parstr,1); + Rec.Top:= StrToInt(fqbParse(',',parstr,2)); + Rec.Left:= StrToInt(fqbParse(',',parstr,3)); + Rec.Right:= StrToInt(fqbParse(',',parstr,4)); + Rec.Bottom:= StrToInt(fqbParse(',',parstr,5)); + TableArea.InsertTable(Rec.Left, Rec.Top, tmpstr); + TfqbTable(TableArea.Components[i]).Height:= Rec.Right; + TfqbTable(TableArea.Components[i]).Width:= Rec.Bottom + end + except + fqbCore.Clear; + Exit + end; + tbl.Clear; + fqbFile.ReadSectionValues('Grid',tbl); + try + for i:= 0 to tbl.Count - 1 do + begin + parstr:=tbl.Values[tbl.Names[i]]; + vis:= TableArea.FindTable(fqbParse(',',parstr,2),fqbParse(',',parstr,3)); + if vis = nil then Exit; + + vis.ChBox.Checked[IndexOf(fqbParse(',',parstr,1))]:= true; + vis.ChBox.ItemIndex:= IndexOf(fqbParse(',',parstr,1)); + vis.ChBox.ClickCheck; + + // n:= Grid.Items.Count - 1; + + TGridColumn(Grid.Items[i].Data^).Table:= fqbParse(',',parstr,2); + TGridColumn(Grid.Items[i].Data^).Alias:= fqbParse(',',parstr,3); + TGridColumn(Grid.Items[i].Data^).Field:= fqbParse(',',parstr,1); + TGridColumn(Grid.Items[i].Data^).Visibl:= Boolean(StrToInt(fqbParse(',',parstr,4))); + TGridColumn(Grid.Items[i].Data^).Sort:= StrToInt(fqbParse(',',parstr,5)); + TGridColumn(Grid.Items[i].Data^).Func:= StrToInt(fqbParse(',',parstr,6)); + TGridColumn(Grid.Items[i].Data^).Group:= StrToInt(fqbParse(',',parstr,7)); + TGridColumn(Grid.Items[i].Data^).Where:= fqbParse(',',parstr,8, True); + + // format: + // field_name = table_name, alias, visible, sorting, function, group, where + end; + except + fqbCore.Clear; + Exit + end; + tbl.Clear; + fqbFile.ReadSectionValues('Links',tbl); + try + for i:= 0 to tbl.Count - 1 do + begin + parstr:=tbl.Values[tbl.Names[i]]; + + lnk:= TfqbLink(TableArea.LinkList.Add); + lnk.FArea:= TableArea; + lnk.FSourceTable := TfqbTable(TableArea.Components[StrToInt(fqbParse(',',parstr,2))]); + lnk.FSourceField := lnk.SourceTable.FieldList[StrToInt(fqbParse(',',parstr,1))]; + lnk.SourceField.Linked := True; + + lnk.FDestTable := TfqbTable(TableArea.Components[StrToInt(fqbParse(',',parstr,4))]); + lnk.FDestField := lnk.DestTable.FieldList[StrToInt(fqbParse(',',parstr,3))]; + lnk.FDestField.Linked := True; + + lnk.FJType := StrToInt(fqbParse(',',parstr, 5)); + lnk.FJOp := StrToInt(fqbParse(',',parstr, 6)); + // format: + // index = sind,slst,dind,dlst,JType,JOper + end; + except + fqbCore.Clear; + Exit + end; + Grid.UpdateColumn; + finally + fqbFile.Free; + tbl.Free + end +end; + +procedure TfqbCore.SaveToFile(const FileName: string); +var + tmp: TStringList; +begin + tmp := TStringList.Create; + fqbCore.SaveToStr(tmp); + tmp.SaveToFile(FileName); + tmp.Free; +end; + +procedure TfqbCore.SaveToStr(var Str: TStringList); +var + i: Integer; + tmp, tmp2: string; +begin + Str.Clear; + tmp2 := fqbCore.GenerateSQL; + tmp := fqbTrim(tmp2, [#10,#13]); + + if tmp = '' then Exit; + + Str.Add('[DataBase]'); + Str.Add('SQL=' + IntToStr(fqbStringCRC32(tmp))); + + Str.Add('[Tables]'); + for i:= 0 to TableArea.ComponentCount - 1 do + begin + tmp := TfqbTable(TableArea.Components[i]).AliasName + '='; + tmp := tmp + TfqbTAble(TableArea.Components[i]).TableName; + tmp := tmp + ',' + IntToStr(TfqbTable(TableArea.Components[i]).Top); + tmp := tmp + ',' + IntToStr(TfqbTable(TableArea.Components[i]).Left); + tmp := tmp + ',' + IntToStr(TfqbTable(TableArea.Components[i]).Height); + tmp := tmp + ',' + IntToStr(TfqbTable(TableArea.Components[i]).Width); + Str.Add(tmp); + // format: + // alias= tablename,top,left,height,width + end; + + Str.Add('[Grid]'); + for i:= 0 to Grid.Items.Count - 1 do + begin + tmp := IntToStr(i) + '='; + tmp:= tmp + TGridColumn(Grid.Items[i].Data^).Field; + tmp:= tmp + ',' + TGridColumn(Grid.Items[i].Data^).Table; + tmp:= tmp + ',' + TGridColumn(Grid.Items[i].Data^).Alias; + tmp:= tmp + ',' + IntToStr(Integer(TGridColumn(Grid.Items[i].Data^).Visibl)); + tmp:= tmp + ',' + IntToStr(TGridColumn(Grid.Items[i].Data^).Sort); + tmp:= tmp + ',' + IntToStr(TGridColumn(Grid.Items[i].Data^).Func); + tmp:= tmp + ',' + IntToStr(TGridColumn(Grid.Items[i].Data^).Group); + tmp:= tmp + ',' + TGridColumn(Grid.Items[i].Data^).Where; + Str.Add(tmp); + // format: + // field_name = table_name, alias, visible, sorting, function, group, where + end; + + Str.Add('[Links]'); + for i:= 0 to TableArea.LinkList.Count - 1 do + begin + tmp:= IntToStr(i) + '='; + tmp:= tmp + IntToStr(TableArea.LinkList[i].SourceField.Index); + tmp:= tmp + ',' + IntToStr(TableArea.LinkList[i].SourceTable.ComponentIndex); + tmp:= tmp + ',' + IntToStr(TableArea.LinkList[i].DestField.Index); + tmp:= tmp + ',' + IntToStr(TableArea.LinkList[i].DestTable.ComponentIndex); + tmp:= tmp + ',' + IntToStr(TfqbLink(TableArea.LinkList[i]).JoinType); + tmp:= tmp + ',' + IntToStr(TfqbLink(TableArea.LinkList[i]).JoinOperator); + Str.Add(tmp); + // format: + // index = sind,slst,dind,dlst,JType,JOper + end; + + if fqbCore.FUseCoding then + tmp := fqbCompress(str.Text) + else + tmp := str.Text; + + Str.Clear; + Str.Add(tmp2); + Str.Add(_fqbBeginModel); + Str.Add(tmp); + Str.Add(_fqbEndModel); +end; + +procedure TfqbCore.SetSchemaInsideSQL(const Value: Boolean); +begin + FSchemaInsideSQL := Value; + if SchemaInsideSQL then + begin + FSQL := fqbCore.ExtractSQL(Ftext); + FSQLSchema := fqbCore.ExtractSchema(Ftext); + end +end; + +procedure TfqbCore.SetSQL(Value: string); +begin + FSQL := fqbCore.ExtractSQL(Value); + FSQLSchema := fqbCore.ExtractSchema(Value); + Ftext := FSQL + _fqbBeginModel + #$D#$A + FSQLSchema + #$D#$A + _fqbEndModel +end; + +procedure TfqbCore.SetSQLSchema(const Value: string); +begin + FSQLSchema := fqbCore.ExtractSchema(Value); + Ftext := FSQL + _fqbBeginModel + #$D#$A + FSQLSchema + #$D#$A + _fqbEndModel +end; + +{----------------------- TfqbCheckListBox -----------------------} +procedure TfqbCheckListBox.ClickCheck; +var + tmp: TfqbGrid; + tbl: TfqbTable; + i: Integer; +begin + tmp := fqbCore.Grid; + tbl := (Parent as TfqbTable); + + if not Assigned(tmp) then + raise EfqbError.Create('Class TfqbGrid not fount on form.'); + + if State[ItemIndex] = cbChecked then + begin + i:= tmp.AddColumn; + TGridColumn(tmp.Items[i].Data^).Table:= tbl.TableName; + TGridColumn(tmp.Items[i].Data^).Field:= tbl.FieldList[ItemIndex].FieldName; + TGridColumn(tmp.Items[i].Data^).Alias:= tbl.AliasName; + TGridColumn(tmp.Items[i].Data^).Where:= ''; + TGridColumn(tmp.Items[i].Data^).Sort:= 0; + TGridColumn(tmp.Items[i].Data^).Func:= 0; + TGridColumn(tmp.Items[i].Data^).Group:= 0; + TGridColumn(tmp.Items[i].Data^).Visibl:= True + end + else + if State[ItemIndex] = cbUnchecked then + begin + for i:= tmp.Items.Count - 1 downto 0 do + begin + if ((TGridColumn(tmp.Items[i].Data^).Table = tbl.TableName) + and (TGridColumn(tmp.Items[i].Data^).Field = tbl.FieldList[ItemIndex].FieldName)) then + begin + FreeMem(tmp.Items[i].Data, SizeOf(TGridColumn)); + tmp.Items.Delete(i) + end + end + end; + tmp.UpdateColumn; + Repaint; + inherited ClickCheck; +end; + +procedure TfqbCheckListBox.DragDrop(Sender: TObject; X, Y: Integer); +var + lnk: TfqbLink; +begin + lnk := (Parent.Parent as TfqbTableArea).LinkList.Add; + lnk.FArea := Parent.Parent as TfqbTableArea; + lnk.FSourceField := ((Sender as TControl).Parent as TfqbTable).SellectedField; + lnk.FSourceField.Linked := true; + lnk.FSourceTable := (Sender as TControl).Parent as TfqbTable; + + lnk.FDestField := (Self.Parent as TfqbTable).SellectedField; + lnk.FDestField.Linked := true; + lnk.FDestTable := Self.Parent as TfqbTable; + + TfqbTableArea(Parent.Parent).Invalidate; + TfqbTable((Sender as TControl).Parent).Invalidate; + Invalidate +end; + +procedure TfqbCheckListBox.DragOver(Sender: TObject; X, Y: Integer; State: + TDragState; var Accept: Boolean); +var + int: Integer; +begin + Accept := False; + if ((not (Sender is TfqbCheckListBox)) or + (Self = Sender)) then Exit; + + int := (Self as TfqbCheckListBox).ItemAtPos(Point(X,Y),True); + + if (int > (Self as TfqbCheckListBox).Items.Count - 1) or (int < 0) then + Exit; + + (Self as TfqbCheckListBox).ItemIndex:= int; + if not (Parent.Parent as TfqbTableArea).CompareFields(Parent.ComponentIndex, int, (Sender as TfqbCheckListBox).Parent.ComponentIndex, (Sender as TfqbCheckListBox).ItemIndex) + then Exit; + + Accept := True +end; + +{----------------------- TfqbGrid -----------------------} +constructor TfqbGrid.Create(AOwner: TComponent); +var + i: Integer; + mi: TMenuItem; +begin + inherited Create(AOwner); + for i:= 0 to 5 do + with Columns.Add do + begin + case i of + rowColumn : Caption := fqbGet(1820); + rowVisibility: Caption := fqbGet(1821); + rowWhere : Caption := fqbGet(1822); + rowSort : Caption := fqbGet(1823); + rowFunction : Caption := fqbGet(1824); + rowGroup : Caption := fqbGet(1825); + end; + Width := 80; + end; + + ViewStyle := vsReport; + ColumnClick := False; + HideSelection := False; + Width := 300; + DragMode := dmAutomatic; + + OnSelectItem := fqbOnSelectItem; + + FPopupMenu := TPopupMenu.Create(Self); + mi := TMenuItem.Create(FPopupMenu); + mi.Caption := fqbGet(1826); + mi.OnClick := fqbOnMenu; + mi.Tag := -1; + FPopupMenu.Items.Add(mi); + mi := TMenuItem.Create(FPopupMenu); + mi.Caption := fqbGet(1827); + mi.OnClick := fqbOnMenu; + mi.Tag := 1; + FPopupMenu.Items.Add(mi); + + FPopupMenu.OnPopup := fqbOnPopup; + PopupMenu := FPopupMenu; +end; + +destructor TfqbGrid.Destroy; +var + i: Integer; +begin + for i:= 0 to Items.Count - 1 do + Dispose(PGridColumn(Items[i])); + inherited +end; + +function TfqbGrid.AddColumn: Integer; +var + tmp: TListItem; + p: PGridColumn; +begin + tmp := Items.Add; + tmp.SubItems.Add(''); + tmp.SubItems.Add(''); + tmp.SubItems.Add(''); + tmp.SubItems.Add(''); + tmp.SubItems.Add(''); + + New(p); + tmp.Data := p; + + Result:= tmp.Index +end; + +procedure TfqbGrid.CreateWnd; +var + wnd: HWND; +begin + inherited CreateWnd; + + FVisibleList := TComboBox.Create(Self); + FVisibleList.Visible := false; + FVisibleList.Parent := Self; + FVisibleList.Style := csOwnerDrawFixed; + FVisibleList.ItemHeight := 12; + FVisibleList.Items.Add(fqbGet(1828)); + FVisibleList.Items.Add(fqbGet(1829)); + FVisibleList.OnChange := fqbOnChange; + FVisibleList.Tag := rowVisibility; + + FWhereEditor:= TfqbEdit.Create(Self); + FWhereEditor.Visible := false; + FWhereEditor.Parent := Self; + FWhereEditor.OnChange := fqbOnChange; + FWhereEditor.Tag := rowWhere; + + FSortList := TComboBox.Create(Self); + FSortList.Visible := false; + FSortList.Parent := Self; + FSortList.Style := csOwnerDrawFixed; + FSortList.ItemHeight := 12; + FSortList.Items.Add(fqbGet(1830)); + FSortList.Items.Add(fqbGet(1831)); + FSortList.Items.Add(fqbGet(1832)); + FSortList.OnChange := fqbOnChange; + FSortList.Tag := rowSort; + + FFunctionList := TComboBox.Create(Self); + FFunctionList.Visible := false; + FFunctionList.Parent := Self; + FFunctionList.Style := csOwnerDrawFixed; + FFunctionList.ItemHeight := 12; + FFunctionList.Items.Add(fqbGet(1830)); + FFunctionList.Items.Add('AVG'); + FFunctionList.Items.Add('COUNT'); + FFunctionList.Items.Add('MAX'); + FFunctionList.Items.Add('MIN'); + FFunctionList.Items.Add('SUM'); + FFunctionList.OnChange := fqbOnChange; + FFunctionList.Tag := rowFunction; + + FGroupList := TComboBox.Create(Self); + FGroupList.Visible := False; + FGroupList.Parent := Self; + FGroupList.Style := csOwnerDrawFixed; + FGroupList.ItemHeight := 12; + FGroupList.Items.Add(fqbGet(1830)); + FGroupList.Items.Add(fqbGet(1833)); + FGroupList.OnChange := fqbOnChange; + FGroupList.Tag := rowGroup; + + RecalcColWidth; + + wnd := GetWindow(Handle, GW_CHILD); + SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE) and not HDS_FULLDRAG) +end; + +procedure TfqbGrid.DoColumnResize(ColumnIndex, ColumnWidth: Integer); +begin + // RecalcColWidth; + fqbUpdate; + if Assigned(FEndColumnResizeEvent) then + FEndColumnResizeEvent(Self, ColumnIndex, ColumnWidth) +end; + +procedure TfqbGrid.Exchange(const AItm1, AItm2: integer); +var + tmpStr: string; + tmpDat: Pointer; +begin + tmpStr := Items[AItm1].Caption; + tmpDat := Items[AItm1].Data; + + Items[AItm1].Caption := Items[AItm2].Caption; + Items[AItm1].Data := Items[AItm2].Data; + + Items[AItm2].Caption := tmpStr; + Items[AItm2].Data := tmpDat; + + fqbUpdate; +end; + +function TfqbGrid.FindColumnIndex(pHeader: pNMHdr): Integer; +var + hwndHeader: HWND; + ItemInfo: THdItem; + ItemIndex: Integer; + buf: array [0..128] of Char; +begin + Result := -1; + hwndHeader := pHeader^.hwndFrom; + ItemIndex := pHDNotify(pHeader)^.Item; + FillChar(iteminfo, SizeOf(iteminfo), 0); + iteminfo.Mask := HDI_TEXT; + iteminfo.pszText := buf; + iteminfo.cchTextMax := SizeOf(buf) - 1; + Header_GetItem(hwndHeader, ItemIndex, iteminfo); + if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then + Result := ItemIndex + else + begin + for ItemIndex := 0 to Columns.Count - 1 do + if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then + begin + Result := ItemIndex; + Break; + end + end +end; + +function TfqbGrid.FindColumnWidth(pHeader: pNMHdr): Integer; +begin + Result := -1; + if Assigned(PHDNotify(pHeader)^.pItem) and + ((PHDNotify(pHeader)^.pItem^.mask and HDI_WIDTH) <> 0) then + Result := PHDNotify(pHeader)^.pItem^.cxy; +end; + +procedure TfqbGrid.fqbOnChange(Sender: TObject); +var + tmp: TcrTControl; +begin + if Selected = nil then Exit; + tmp := TcrTControl(Sender); + if tmp.ClassName = 'TComboBox' then + if TComboBox(tmp).ItemIndex = 0 then + Selected.SubItems[tmp.tag - 1] := '' + else + Selected.SubItems[tmp.tag - 1] := tmp.Text; + + if tmp.ClassName = 'TfqbEdit' then + Selected.SubItems[tmp.tag - 1] := tmp.Text; + + if tmp.tag = rowVisibility then + TGridColumn(Selected.Data^).Visibl := (TComboBox(tmp).ItemIndex = 0); + if tmp.tag = rowWhere then + TGridColumn(Selected.Data^).Where := tmp.Caption; + if tmp.tag = rowSort then + TGridColumn(Selected.Data^).Sort := TComboBox(tmp).ItemIndex; + if tmp.tag = rowFunction then + TGridColumn(Selected.Data^).Func := TComboBox(tmp).ItemIndex; + if tmp.tag = rowGroup then + TGridColumn(Selected.Data^).Group := TComboBox(tmp).ItemIndex; +end; + +procedure TfqbGrid.fqbOnMenu(Sender: TObject); +begin + Exchange(Selected.Index, Selected.Index + (Sender as TComponent).Tag); + Items[Selected.Index + (Sender as TComponent).Tag].Selected := True; + UpdateColumn +end; + +procedure TfqbGrid.fqbOnPopup(Sender: TObject); +begin + if Assigned(Selected) then + begin + FPopupMenu.Items[0].Enabled := Selected.Index <> 0; + FPopupMenu.Items[1].Enabled := Selected.Index <> Items.Count - 1; + end + else + begin + FPopupMenu.Items[0].Enabled := False; + FPopupMenu.Items[1].Enabled := False; + end +end; + +procedure TfqbGrid.fqbOnSelectItem(Sender: TObject; Item: TListItem; Selected: + Boolean); +var + tmp: TfqbTableArea; + tbl: TfqbTable; + i: Integer; +begin + fqbUpdate; + tmp := fqbCore.TableArea; + if not Assigned(tmp) then Exit; + tbl := tmp.FindTable(TGridColumn(Item.Data^).Table, TGridColumn(Item.Data^).Alias); + if not Assigned(tbl) then Exit; + tbl.BringToFront; + for i:= 0 to tbl.FieldList.Count - 1 do + if tbl.FieldList[i].FieldName = TGridColumn(Item.Data^).Field then + tbl.ChBox.ItemIndex := i; +end; + +procedure TfqbGrid.fqbSetBounds(var Contr: TControl); +var + i: Integer; +begin + Contr.Visible := false; + if Selected = nil then Exit; + if Assigned(TopItem) then + if TopItem.Index > Selected.Index then Exit; + Contr.Width := Columns[Contr.Tag].Width + 1; + Contr.Top := Selected.Top - 2; + Contr.Left := 0; + for i:= 0 to Contr.Tag - 1 do + Contr.Left := Contr.Left + Columns[i].Width; + Contr.Height := 19; + if Contr.ClassName = 'TComboBox' then + begin + TComboBox(Contr).ItemIndex := TComboBox(Contr).Items.IndexOf(Selected.SubItems[Contr.Tag - 1]); + end + else + if Contr.ClassName = 'TfqbEdit' then + begin + TcrTControl(Contr).Text := Selected.SubItems[Contr.Tag - 1]; + end; + Contr.Visible := true; +end; + +procedure TfqbGrid.fqbUpdate; +begin + if not (Assigned(FVisibleList) and Assigned(FWhereEditor) + and Assigned(FSortList) and Assigned(FFunctionList) + and Assigned(FGroupList)) then Exit; + fqbSetBounds(TControl(FVisibleList)); + fqbSetBounds(TControl(FWhereEditor)); + fqbSetBounds(TControl(FSortList)); + fqbSetBounds(TControl(FFunctionList)); + fqbSetBounds(TControl(FGroupList)); + FWhereEditor.Height := 18; +end; + +procedure TfqbGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + Selected := GetItemAt(5, Y); + ItemFocused := Selected +end; + +procedure TfqbGrid.RecalcColWidth; +var + i, n: Integer; + w, dw: Integer; + p: Real; +begin + if not Assigned(FVisibleList) then + Exit; + w:= 0; + n := Columns.Count - 1; + for i := 0 to n do + w := w + Columns[i].Width; + dw := 0; + for i := 0 to n do + begin + if (w = 0) then + p := Columns[i].Width + else + p := Columns[i].Width / w; + Columns[i].Width := Round(p * (Width - 4)); + dw := dw + Columns[i].Width; + end; + Columns[n].Width := Columns[n].Width + (Width - dw - 4); +end; + +procedure TfqbGrid.Resize; +begin + inherited; + RecalcColWidth; + fqbUpdate +end; + +procedure TfqbGrid.UpdateColumn; +var + i: Integer; +begin + for i:= 0 to Items.Count - 1 do + begin + Items[i].Caption := TGridColumn(Items[i].Data^).Field; + + if TGridColumn(Items[i].Data^).Visibl then + Items[i].SubItems[rowVisibility - 1] := '' + else + Items[i].SubItems[rowVisibility - 1] := FVisibleList.Items[1]; + + Items[i].SubItems[rowWhere - 1]:= TGridColumn(Items[i].Data^).Where; + + if TGridColumn(Items[i].Data^).Sort = 0 then + Items[i].SubItems[rowSort - 1]:= '' + else + Items[i].SubItems[rowSort - 1]:= FSortList.Items[TGridColumn(Items[i].Data^).Sort]; + + if TGridColumn(Items[i].Data^).Func = 0 then + Items[i].SubItems[rowFunction - 1]:= '' + else + Items[i].SubItems[rowFunction - 1]:= FFunctionList.Items[TGridColumn(Items[i].Data^).Func]; + + if TGridColumn(Items[i].Data^).Group = 0 then + Items[i].SubItems[rowGroup - 1]:= '' + else + Items[i].SubItems[rowGroup - 1]:= FGroupList.Items[TGridColumn(Items[i].Data^).Group]; + end +end; + +procedure TfqbGrid.WMNotify(var Msg: TWMNotify); +begin + inherited; + case Msg.NMHdr^.code of + HDN_ENDTRACK: + DoColumnResize(FindColumnIndex(Msg.NMHdr), FindColumnWidth(Msg.NMHdr)); + end +end; + +procedure TfqbGrid.WMVscroll(var Msg: TWMNotify); +begin + inherited; + fqbUpdate +end; + +{----------------------- TfqbEdit -----------------------} +constructor TfqbEdit.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FPanel := TPanel.Create(Self); + FPanel.Parent := Self; + FPanel.Align := alRight; + FPanel.Width := Height - 3; + FPanel.BevelOuter := bvNone; + + FButton := TSpeedButton.Create(Self); + FButton.Parent := FPanel; + FButton.Align := alClient; + FButton.OnClick := ButtonClick; +end; + +procedure TfqbEdit.ButtonClick(Sender: TObject); +begin + SetFocus; + if Assigned(FOnButtonClick) then + FOnButtonClick(Self); +end; + +procedure TfqbEdit.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + Params.Style := Params.Style or WS_CLIPCHILDREN; +end; + +procedure TfqbEdit.CreateWnd; +begin + inherited; + ShowButton := false; +end; + +procedure TfqbEdit.SetEditRect; +var + Rec: TRect; +begin + SendMessage(Handle, EM_GETRECT, 0, LongInt(@Rec)); + if ShowButton then + begin + Rec.Bottom := ClientHeight + 1; + Rec.Right := ClientWidth - FPanel.Width - 1 + end + else + begin + Rec.Bottom := ClientHeight + 1; + Rec.Right := ClientWidth; + end; + Rec.Top := 0; + Rec.Left := 0; + SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Rec)); +end; + +procedure TfqbEdit.SetShowButton(const Value: Boolean); +begin + FShowButton := Value; + FPanel.Visible := Value; + SetEditRect +end; + +procedure TfqbEdit.WMSize(var Message: TWMSize); +begin + inherited; + SetEditRect +end; + +procedure TfqbTable.CMRelease(var Message: TMessage); +begin + Free +end; + +initialization + RegisterClasses([TComboBox, TfqbEdit]); +{$IFDEF FQB_COM} + TComponentFactory.Create(ComServer, TfqbDialog, CLASS_FastQueryBuilder_, ciMultiInstance, tmApartment); +{$ENDIF} + +finalization + if FfqbCore <> nil then + FfqbCore.Free; + +end. diff --git a/official/4.8.11/FastQB/fqbDesign.dfm b/official/4.8.11/FastQB/fqbDesign.dfm new file mode 100644 index 0000000..f1289ce Binary files /dev/null and b/official/4.8.11/FastQB/fqbDesign.dfm differ diff --git a/official/4.8.11/FastQB/fqbDesign.lfm b/official/4.8.11/FastQB/fqbDesign.lfm new file mode 100644 index 0000000..039c609 --- /dev/null +++ b/official/4.8.11/FastQB/fqbDesign.lfm @@ -0,0 +1,680 @@ +object fqbDesigner: TfqbDesigner + Left = 213 + Top = 101 + Width = 828 + Height = 614 + Caption = 'Fast Query Builder Designer' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + Position = poDefaultPosOnly + ShowHint = True + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 96 + TextHeight = 13 + object ToolBar1: TToolBar + Left = 0 + Top = 0 + Width = 820 + Height = 28 + AutoSize = True + BorderWidth = 1 + EdgeBorders = [ebBottom] + Flat = True + Images = ImageList2 + Indent = 2 + TabOrder = 1 + object ToolButton3: TToolButton + Left = 2 + Top = 0 + Hint = 'Open' + ImageIndex = 0 + OnClick = ToolButton3Click + end + object ToolButton4: TToolButton + Left = 25 + Top = 0 + Hint = 'Save' + ImageIndex = 1 + OnClick = ToolButton4Click + end + object ToolButton5: TToolButton + Left = 48 + Top = 0 + Width = 8 + Caption = 'ToolButton5' + ImageIndex = 3 + Style = tbsSeparator + end + object ToolButton6: TToolButton + Left = 56 + Top = 0 + Hint = 'Clear' + ImageIndex = 2 + OnClick = ToolButton6Click + end + object ToolButton8: TToolButton + Left = 79 + Top = 0 + Width = 8 + Caption = 'ToolButton8' + ImageIndex = 7 + Style = tbsSeparator + end + object ToolButton10: TToolButton + Left = 87 + Top = 0 + Hint = 'Cancel' + ImageIndex = 3 + OnClick = ToolButton10Click + end + object ToolButton7: TToolButton + Left = 110 + Top = 0 + Hint = 'Ok' + ImageIndex = 4 + OnClick = ToolButton7Click + end + end + object PageControl1: TPageControl + Left = 0 + Top = 28 + Width = 820 + Height = 552 + ActivePage = TabSheet1 + Align = alClient + TabOrder = 0 + object TabSheet1: TTabSheet + Caption = 'Model' + object Splitter2: TSplitter + Left = 629 + Top = 0 + Width = 3 + Height = 524 + Cursor = crHSplit + Align = alRight + end + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 629 + Height = 524 + Align = alClient + BevelOuter = bvNone + Caption = 'Panel1' + TabOrder = 1 + object Splitter1: TSplitter + Left = 0 + Top = 360 + Width = 629 + Height = 3 + Cursor = crVSplit + Align = alBottom + end + object fqbTableArea1: TfqbTableArea + Left = 0 + Top = 0 + Width = 629 + Height = 360 + Align = alClient + BorderStyle = bsNone + Color = clAppWorkSpace + ParentColor = False + TabOrder = 0 + end + object fqbGrid1: TfqbGrid + Left = 0 + Top = 363 + Width = 629 + Height = 161 + Align = alBottom + BorderStyle = bsNone + Columns = < + item + Caption = 'Collumn' + Width = 104 + end + item + Caption = 'Visible' + Width = 104 + end + item + Caption = 'Where' + Width = 104 + end + item + Caption = 'Sort' + Width = 104 + end + item + Caption = 'Function' + Width = 104 + end + item + Caption = 'Group' + Width = 105 + end> + ColumnClick = False + DragMode = dmAutomatic + GridLines = True + HideSelection = False + ReadOnly = True + RowSelect = True + TabOrder = 1 + ViewStyle = vsReport + end + end + object fqbTableListBox1: TfqbTableListBox + Left = 632 + Top = 0 + Width = 180 + Height = 524 + Align = alRight + BorderStyle = bsNone + DragMode = dmAutomatic + ItemHeight = 18 + Style = lbOwnerDrawFixed + TabOrder = 0 + end + end + object TabSheet2: TTabSheet + Caption = 'SQL' + ImageIndex = 1 + OnShow = TabSheet2Show + object fqbSyntaxMemo1: TfqbSyntaxMemo + Left = 0 + Top = 0 + Width = 812 + Height = 524 + Cursor = crIBeam + Align = alClient + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Courier New' + Font.Style = [] + ParentColor = False + ParentFont = False + TabOrder = 0 + TabStop = True + BlockColor = clHighlight + BlockFontColor = clHighlightText + CommentAttr.Charset = DEFAULT_CHARSET + CommentAttr.Color = clNavy + CommentAttr.Height = -13 + CommentAttr.Name = 'Courier New' + CommentAttr.Style = [fsItalic] + KeywordAttr.Charset = DEFAULT_CHARSET + KeywordAttr.Color = clWindowText + KeywordAttr.Height = -13 + KeywordAttr.Name = 'Courier New' + KeywordAttr.Style = [fsBold] + StringAttr.Charset = DEFAULT_CHARSET + StringAttr.Color = clNavy + StringAttr.Height = -13 + StringAttr.Name = 'Courier New' + StringAttr.Style = [] + TextAttr.Charset = DEFAULT_CHARSET + TextAttr.Color = clWindowText + TextAttr.Height = -13 + TextAttr.Name = 'Courier New' + TextAttr.Style = [] + Lines.Strings = ( + '') + ReadOnly = True + SyntaxType = stSQL + ShowFooter = True + ShowGutter = True + end + end + object TabSheet3: TTabSheet + Caption = 'Result' + ImageIndex = 2 + OnHide = TabSheet3Hide + OnShow = TabSheet3Show + object DBGrid1: TDBGrid + Left = 0 + Top = 0 + Width = 812 + Height = 524 + Align = alClient + BorderStyle = bsNone + DataSource = DataSource1 + TabOrder = 0 + TitleFont.Charset = DEFAULT_CHARSET + TitleFont.Color = clWindowText + TitleFont.Height = -11 + TitleFont.Name = 'Tahoma' + TitleFont.Style = [] + end + end + end + object DataSource1: TDataSource + Left = 232 + Top = 72 + end + object OpenDialog1: TOpenDialog + DefaultExt = 'sql' + Filter = 'SQL files|*.sql' + Left = 264 + Top = 72 + end + object SaveDialog1: TSaveDialog + Tag = -1 + DefaultExt = 'sql' + Filter = 'SQL files|*.sql' + Left = 296 + Top = 72 + end + object ImageList2: TImageList + Left = 277 + Top = 156 + Bitmap = { + 494C010105000900040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000003000000001002000000000000030 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000E8C3E000D893E0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000001090 + 40000F8E3F000E8C3F000D8A3E00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000119542001192 + 41000F9040000F8E3F000E8B3F000D893E000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000149A4300139743001295 + 410000000000109040000F8E40000E8B3E000C893E0000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000159E4500159B4400139943000000 + 000000000000000000000F9041000F8D3F000D8B3E000C883E00000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000159D4500000000000000 + 00000000000000000000000000000F8F40000F8D3F000E8B3E000D883E000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000108F40000F8E3F000E8B3F000D88 + 3D00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000F8F40000E8D3F000E8A + 3E000D883E000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000F8F40000E8D + 3F000D8B3F000C883D0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000F8F + 3F000E8C3F000D8A3E000D883E00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000F8F40000E8C3F000D893E000C873D000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000F8F3F000E8C3F00000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000007088900060809000607880005070 + 8000506070004058600040485000303840002030300020203000101820001010 + 1000101020000000000000000000000000000000000000000000C0686000B058 + 5000A0505000A0505000A0505000904850009048400090484000804040008038 + 4000803840007038400070383000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000007088900090A0B00070B0D0000090 + D0000090D0000090D0000090C0001088C0001080B0001080B0002078A0002070 + 90002048600091A1A300000000000000000000000000D0687000F0909000E080 + 8000B048200040302000C0B8B000C0B8B000D0C0C000D0C8C00050505000A040 + 3000A0403000A038300070384000000000000000000000000000D5C0AE008070 + 6000907860009070600000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000B0ADD000A0A + D900000000000000000000000000000000000000000000000000000000000000 + 00000707BD000807BB0000000000000000008088900080C0D00090A8B00080E0 + FF0060D0FF0050C8FF0050C8FF0040C0F00030B0F00030A8F00020A0E0001090 + D00020688000545E6500000000000000000000000000D0707000FF98A000F088 + 8000E0808000705850004040300090787000F0E0E000F0E8E00090807000A040 + 3000A0404000A0403000803840000000000000000000A0807000A0887000D0B0 + A000D0B0A000C0B0A000B098800060483000ACA2990000000000000000000000 + 00000000000000000000000000000000000000000000000000000B0AE0000A0A + DD000A0AD9000000000000000000000000000000000000000000000000000708 + C1000708BF000708BD0000000000000000008090A00080D0F00090A8B00090C0 + D00070D8FF0060D0FF0060D0FF0050C8FF0050C0FF0040B8F00030B0F00030A8 + F0001088D00020486000B7C5C9000000000000000000D0787000FFA0A000F090 + 9000F0888000705850000000000040403000F0D8D000F0E0D00080786000B048 + 4000B0484000A04040008040400000000000C0988000E0C0B000D0C0B000E0D0 + C000F0E0E000FFF8F000B0988000A090800060483000ACA29900000000000000 + 0000000000000000000000000000000000000000000000000000000000000B0B + E1000A0BDD000A0AD900000000000000000000000000000000000809C8000808 + C5000808C1000000000000000000000000008090A00080D8F00080C8E00090A8 + B00080E0FF0070D0FF0060D8FF0060D0FF0060D0FF0050C8FF0040C0F00040B8 + F00030B0F00020688000658A99000000000000000000D0788000FFA8B000FFA0 + A000F0909000705850007058500070585000705850007060500080686000C058 + 5000B0505000B04840008040400000000000D0B0A000F0F0E000F0E8E000F0F0 + F000FFF8FF00FFF8F000FFFFFF00B0988000A090800060483000ACA299000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000B0AE0000A0ADC000A0AD90000000000000000000909CE000808CA000808 + C800000000000000000000000000000000008098A00090E0F00090E0FF0090A8 + B00090B8C00070D8FF0060D8FF0060D8FF0060D8FF0060D0FF0050D0FF0050C8 + FF0040B8F00030A0E00049677700C0CAD10000000000E0808000FFB0B000FFB0 + B000FFA0A000F0909000F0888000E0808000E0788000D0707000D0687000C060 + 6000C0585000B05050009048400000000000D0A89000FFF8FF00FFFFFF00FFFF + FF00F0F0F000F0E8E000F0E0E000FFFFFF00B0988000A090800060483000ACA2 + 9900000000000000000000000000000000000000000000000000000000000000 + 0000000000000A0AE1000A0ADD000A0AD9000A09D5000A0AD1000909CE000000 + 0000000000000000000000000000000000008098A00090E0F000A0E8FF0080C8 + E00090A8B00080E0FF0080E0FF0080E0FF0080E0FF0080E0FF0080E0FF0080E0 + FF0070D8FF0070D8FF0050A8D00085929D0000000000E0889000FFB8C000FFB8 + B000D0606000C0605000C0585000C0504000B0503000B0483000A0402000A038 + 1000C0606000C05850009048400000000000BECBCD00D0A89000FFFFFF00FFFF + FF00FFF8FF00F0F0F000F0E8E000F0E0E000FFFFFF00B0988000A09080006048 + 3000ACA299000000000000000000000000000000000000000000000000000000 + 000000000000000000000B0BE1000A0ADD000A0AD9000A0AD500000000000000 + 00000000000000000000000000000000000090A0A000A0E8F000A0E8FF00A0E8 + FF0090B0C00090B0C00090A8B00090A8B00080A0B00080A0B0008098A0008098 + A0008090A0008090A000808890007088900000000000E0909000FFC0C000D068 + 6000FFFFFF00FFFFFF00FFF8F000F0F0F000F0E8E000F0D8D000E0D0C000E0C8 + C000A0381000C0606000904850000000000000000000BECBCD00D0A89000FFFF + FF00FFFFFF00FFF8FF00F0F0F000F0E8E000F0E0E000FFFFFF00B0988000A090 + 8000604830000000000000000000000000000000000000000000000000000000 + 000000000000000000000B0BE4000B0BE0000A0ADC000A0AD900000000000000 + 00000000000000000000000000000000000090A0B000A0E8F000A0F0FF00A0E8 + FF00A0E8FF0080D8FF0060D8FF0060D8FF0060D8FF0060D8FF0060D8FF0060D8 + FF007088900000000000000000000000000000000000E098A000FFC0C000D070 + 7000FFFFFF00FFFFFF00FFFFFF00FFF8F000F0F0F000F0E8E000F0D8D000E0D0 + C000A0402000D0686000A0505000000000000000000000000000BECBCD00D0A8 + 9000FFFFFF00FFFFFF00FFF8FF00F0F0F000F0E8E000F0E0E000FFFFFF00B098 + 8000806050000000000000000000000000000000000000000000000000000000 + 0000000000000C0CEB000B0BE7000B0BE4000A0BE0000A0BDD000A0AD9000000 + 00000000000000000000000000000000000090A0B000A0F0F000B0F0F000A0F0 + FF00A0E8FF00A0E8FF0070D8FF0090A0A0008098A0008098A0008090A0008090 + 90007088900000000000000000000000000000000000F0A0A000FFC0C000E078 + 7000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFF8F000F0F0F000F0E8E000F0D8 + D000B0483000D0707000A050500000000000000000000000000000000000BECB + CD00D0A89000FFFFFF00FFFFFF00FFF8FF00F0F0F000F0E8E000F0E0E000FFFF + FF00A08070000000000000000000000000000000000000000000000000000000 + 00000C0CF1000C0CEE000B0CEB0000000000000000000B0BE0000A0ADD000A0A + D9000000000000000000000000000000000090A8B000A0D0E000B0F0F000B0F0 + F000A0F0FF00A0E8FF0090A0B000B2C9CF000000000000000000000000000000 + 00000000000090685000906850009068500000000000F0A8A000FFC0C000E080 + 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFF8F000F0F0F000F0E8 + E000B0503000E0788000A0505000000000000000000000000000000000000000 + 0000BECBCD00D0A89000FFFFFF00FFFFFF00FFF8FF00FFF0F000FFF8FF00E0D0 + C000B09080000000000000000000000000000000000000000000000000000C0C + F5000C0CF3000C0CF100000000000000000000000000000000000B0BE1000A0B + DD000A0AD900000000000000000000000000CBD7DC0090A8B00090A8B00090A8 + B00090A8B00090A8B000B5C6CC00000000000000000000000000000000000000 + 000000000000D0C8C800906850009068500000000000F0B0B000FFC0C000F088 + 9000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFF8F000F0F0 + F000C050400060303000B0585000000000000000000000000000000000000000 + 000000000000BECBCD00D0A89000FFFFFF00FFFFFF00FFF8FF00E0D0D000B088 + 7000BECBCD0000000000000000000000000000000000000000000D0CF7000D0D + F7000C0CF5000000000000000000000000000000000000000000000000000B0B + E0000A0ADD000A0AD90000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000090786000C7BCB5000000 + 000000000000A0908000D2CEC9009078600000000000F0B0B000FFC0C000FF90 + 9000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFF8 + F000C0585000B0586000B0586000000000000000000000000000000000000000 + 00000000000000000000BECBCD00D0A89000C0A09000B0907000B4938300BECB + CD000000000000000000000000000000000000000000000000000D0CF7000D0C + F700000000000000000000000000000000000000000000000000000000000000 + 00000B0BE0000A0BDD0000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000D8D9D600A0908000A088 + 8000B0988000C5BFB900000000000000000000000000F0B8B000F0B8B000F0B0 + B000F0B0B000F0A8B000F0A0A000E098A000E0909000E0909000E0889000E080 + 8000D0788000D0787000D0707000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000424D3E000000000000003E000000 + 2800000040000000300000000100010000000000800100000000000000000000 + 000000000000000000000000FFFFFF0000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000FFFF000000000000FFFF000000000000 + F3FF000000000000E1FF000000000000C0FF000000000000887F000000000000 + 1C3F000000000000BE1F000000000000FF0F000000000000FF87000000000000 + FFC3000000000000FFE1000000000000FFF0000000000000FFF9000000000000 + FFFF000000000000FFFF000000000000FFFFFFFFFFFFFFFF0007C001FFFFFFFF + 00038001C003CFF300038001807FC7E300018001003FE3C700018001001FF18F + 00008001000FF81F000080010007FC3F000080018007FC3F00078001C007F81F + 00078001E007F18F00F88001F007E3C701F88001F807C7E3FF988001FC0FCFF3 + FF838001FFFFFFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000 + 000000000000} + end +end diff --git a/official/4.8.11/FastQB/fqbDesign.lrs b/official/4.8.11/FastQB/fqbDesign.lrs new file mode 100644 index 0000000..057214d --- /dev/null +++ b/official/4.8.11/FastQB/fqbDesign.lrs @@ -0,0 +1,453 @@ +LazarusResources.Add('TfqbDesigner','FORMDATA',[ + 'TPF0'#12'TfqbDesigner'#11'fqbDesigner'#4'Left'#3#213#0#3'Top'#2'e'#5'Width'#3 + +'<'#3#6'Height'#3'f'#2#7'Caption'#6#28'Fast Query Builder Designer'#5'Color' + +#7#9'clBtnFace'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'c' + +'lWindowText'#11'Font.Height'#2#245#9'Font.Name'#6#6'Tahoma'#10'Font.Style' + +#11#0#8'Position'#7#16'poDefaultPosOnly'#8'ShowHint'#9#8'OnCreate'#7#10'Form' + +'Create'#9'OnDestroy'#7#11'FormDestroy'#13'PixelsPerInch'#2'`'#10'TextHeight' + +#2#13#0#8'TToolBar'#8'ToolBar1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3'4'#3#6'Hei' + +'ght'#2#28#8'AutoSize'#9#11'BorderWidth'#2#1#11'EdgeBorders'#11#8'ebBottom'#0 + +#4'Flat'#9#6'Images'#7#10'ImageList2'#6'Indent'#2#2#8'TabOrder'#2#1#0#11'TTo' + +'olButton'#11'ToolButton3'#4'Left'#2#2#3'Top'#2#0#4'Hint'#6#4'Open'#10'Image' + +'Index'#2#0#7'OnClick'#7#16'ToolButton3Click'#0#0#11'TToolButton'#11'ToolBut' + +'ton4'#4'Left'#2#25#3'Top'#2#0#4'Hint'#6#4'Save'#10'ImageIndex'#2#1#7'OnClic' + +'k'#7#16'ToolButton4Click'#0#0#11'TToolButton'#11'ToolButton5'#4'Left'#2'0'#3 + +'Top'#2#0#5'Width'#2#8#7'Caption'#6#11'ToolButton5'#10'ImageIndex'#2#3#5'Sty' + +'le'#7#12'tbsSeparator'#0#0#11'TToolButton'#11'ToolButton6'#4'Left'#2'8'#3'T' + +'op'#2#0#4'Hint'#6#5'Clear'#10'ImageIndex'#2#2#7'OnClick'#7#16'ToolButton6Cl' + +'ick'#0#0#11'TToolButton'#11'ToolButton8'#4'Left'#2'O'#3'Top'#2#0#5'Width'#2 + +#8#7'Caption'#6#11'ToolButton8'#10'ImageIndex'#2#7#5'Style'#7#12'tbsSeparato' + +'r'#0#0#11'TToolButton'#12'ToolButton10'#4'Left'#2'W'#3'Top'#2#0#4'Hint'#6#6 + +'Cancel'#10'ImageIndex'#2#3#7'OnClick'#7#17'ToolButton10Click'#0#0#11'TToolB' + +'utton'#11'ToolButton7'#4'Left'#2'n'#3'Top'#2#0#4'Hint'#6#2'Ok'#10'ImageInde' + +'x'#2#4#7'OnClick'#7#16'ToolButton7Click'#0#0#0#12'TPageControl'#12'PageCont' + +'rol1'#4'Left'#2#0#3'Top'#2#28#5'Width'#3'4'#3#6'Height'#3'('#2#10'ActivePag' + +'e'#7#9'TabSheet1'#5'Align'#7#8'alClient'#8'TabOrder'#2#0#0#9'TTabSheet'#9'T' + +'abSheet1'#7'Caption'#6#5'Model'#0#9'TSplitter'#9'Splitter2'#4'Left'#3'u'#2#3 + +'Top'#2#0#5'Width'#2#3#6'Height'#3#12#2#6'Cursor'#7#8'crHSplit'#5'Align'#7#7 + +'alRight'#0#0#6'TPanel'#6'Panel1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3'u'#2#6'H' + +'eight'#3#12#2#5'Align'#7#8'alClient'#10'BevelOuter'#7#6'bvNone'#7'Caption'#6 + +#6'Panel1'#8'TabOrder'#2#1#0#9'TSplitter'#9'Splitter1'#4'Left'#2#0#3'Top'#3 + +'h'#1#5'Width'#3'u'#2#6'Height'#2#3#6'Cursor'#7#8'crVSplit'#5'Align'#7#8'alB' + +'ottom'#0#0#13'TfqbTableArea'#13'fqbTableArea1'#4'Left'#2#0#3'Top'#2#0#5'Wid' + +'th'#3'u'#2#6'Height'#3'h'#1#5'Align'#7#8'alClient'#11'BorderStyle'#7#6'bsNo' + +'ne'#5'Color'#7#14'clAppWorkSpace'#11'ParentColor'#8#8'TabOrder'#2#0#0#0#8'T' + +'fqbGrid'#8'fqbGrid1'#4'Left'#2#0#3'Top'#3'k'#1#5'Width'#3'u'#2#6'Height'#3 + +#161#0#5'Align'#7#8'alBottom'#11'BorderStyle'#7#6'bsNone'#7'Columns'#14#1#7 + +'Caption'#6#7'Collumn'#5'Width'#2'h'#0#1#7'Caption'#6#7'Visible'#5'Width'#2 + +'h'#0#1#7'Caption'#6#5'Where'#5'Width'#2'h'#0#1#7'Caption'#6#4'Sort'#5'Width' + +#2'h'#0#1#7'Caption'#6#8'Function'#5'Width'#2'h'#0#1#7'Caption'#6#5'Group'#5 + +'Width'#2'i'#0#0#11'ColumnClick'#8#8'DragMode'#7#11'dmAutomatic'#9'GridLines' + +#9#13'HideSelection'#8#8'ReadOnly'#9#9'RowSelect'#9#8'TabOrder'#2#1#9'ViewSt' + +'yle'#7#8'vsReport'#0#0#0#16'TfqbTableListBox'#16'fqbTableListBox1'#4'Left'#3 + +'x'#2#3'Top'#2#0#5'Width'#3#180#0#6'Height'#3#12#2#5'Align'#7#7'alRight'#11 + +'BorderStyle'#7#6'bsNone'#8'DragMode'#7#11'dmAutomatic'#10'ItemHeight'#2#18#5 + +'Style'#7#16'lbOwnerDrawFixed'#8'TabOrder'#2#0#0#0#0#9'TTabSheet'#9'TabSheet' + +'2'#7'Caption'#6#3'SQL'#10'ImageIndex'#2#1#6'OnShow'#7#13'TabSheet2Show'#0#14 + +'TfqbSyntaxMemo'#14'fqbSyntaxMemo1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3','#3#6 + +'Height'#3#12#2#6'Cursor'#7#7'crIBeam'#5'Align'#7#8'alClient'#12'Font.Charse' + +'t'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2 + +#243#9'Font.Name'#6#11'Courier New'#10'Font.Style'#11#0#11'ParentColor'#8#10 + +'ParentFont'#8#8'TabOrder'#2#0#7'TabStop'#9#10'BlockColor'#7#11'clHighlight' + +#14'BlockFontColor'#7#15'clHighlightText'#19'CommentAttr.Charset'#7#15'DEFAU' + +'LT_CHARSET'#17'CommentAttr.Color'#7#6'clNavy'#18'CommentAttr.Height'#2#243 + +#16'CommentAttr.Name'#6#11'Courier New'#17'CommentAttr.Style'#11#8'fsItalic' + +#0#19'KeywordAttr.Charset'#7#15'DEFAULT_CHARSET'#17'KeywordAttr.Color'#7#12 + +'clWindowText'#18'KeywordAttr.Height'#2#243#16'KeywordAttr.Name'#6#11'Courie' + +'r New'#17'KeywordAttr.Style'#11#6'fsBold'#0#18'StringAttr.Charset'#7#15'DEF' + +'AULT_CHARSET'#16'StringAttr.Color'#7#6'clNavy'#17'StringAttr.Height'#2#243 + +#15'StringAttr.Name'#6#11'Courier New'#16'StringAttr.Style'#11#0#16'TextAttr' + +'.Charset'#7#15'DEFAULT_CHARSET'#14'TextAttr.Color'#7#12'clWindowText'#15'Te' + +'xtAttr.Height'#2#243#13'TextAttr.Name'#6#11'Courier New'#14'TextAttr.Style' + +#11#0#13'Lines.Strings'#1#6#0#0#8'ReadOnly'#9#10'SyntaxType'#7#5'stSQL'#10'S' + +'howFooter'#9#10'ShowGutter'#9#0#0#0#9'TTabSheet'#9'TabSheet3'#7'Caption'#6#6 + +'Result'#10'ImageIndex'#2#2#6'OnHide'#7#13'TabSheet3Hide'#6'OnShow'#7#13'Tab' + +'Sheet3Show'#0#7'TDBGrid'#7'DBGrid1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3','#3#6 + ,'Height'#3#12#2#5'Align'#7#8'alClient'#11'BorderStyle'#7#6'bsNone'#10'DataSo' + +'urce'#7#11'DataSource1'#8'TabOrder'#2#0#17'TitleFont.Charset'#7#15'DEFAULT_' + +'CHARSET'#15'TitleFont.Color'#7#12'clWindowText'#16'TitleFont.Height'#2#245 + +#14'TitleFont.Name'#6#6'Tahoma'#15'TitleFont.Style'#11#0#0#0#0#0#11'TDataSou' + +'rce'#11'DataSource1'#4'Left'#3#232#0#3'Top'#2'H'#0#0#11'TOpenDialog'#11'Ope' + +'nDialog1'#10'DefaultExt'#6#3'sql'#6'Filter'#6#15'SQL files|*.sql'#4'Left'#3 + +#8#1#3'Top'#2'H'#0#0#11'TSaveDialog'#11'SaveDialog1'#3'Tag'#2#255#10'Default' + +'Ext'#6#3'sql'#6'Filter'#6#15'SQL files|*.sql'#4'Left'#3'('#1#3'Top'#2'H'#0#0 + +#10'TImageList'#10'ImageList2'#4'Left'#3#21#1#3'Top'#3#156#0#6'Bitmap'#10'&2' + +#0#0'IL'#1#1#5#0#9#0#4#0#16#0#16#0#255#255#255#255#255#16#255#255#255#255#255 + +#255#255#255'BM6'#0#0#0#0#0#0#0'6'#0#0#0'('#0#0#0'@'#0#0#0'0'#0#0#0#1#0' '#0 + +#0#0#0#0#0'0'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#14#140'>'#0#13#137'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#16#144'@'#0#15#142'?'#0#14#140'?'#0#13#138'>'#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#17#149 + +'B'#0#17#146'A'#0#15#144'@'#0#15#142'?'#0#14#139'?'#0#13#137'>'#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#20#154'C'#0 + +#19#151'C'#0#18#149'A'#0#0#0#0#0#16#144'@'#0#15#142'@'#0#14#139'>'#0#12#137 + +'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#21#158'E'#0 + +#21#155'D'#0#19#153'C'#0#0#0#0#0#0#0#0#0#0#0#0#0#15#144'A'#0#15#141'?'#0#13 + +#139'>'#0#12#136'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#21#157'E'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#143'@'#0#15#141 + +'?'#0#14#139'>'#0#13#136'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#16#143'@'#0#15 + +#142'?'#0#14#139'?'#0#13#136'='#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#143'@'#0 + +#14#141'?'#0#14#138'>'#0#13#136'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#143 + +'@'#0#14#141'?'#0#13#139'?'#0#12#136'='#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15 + +#143'?'#0#14#140'?'#0#13#138'>'#0#13#136'>'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#15#143'@'#0#14#140'?'#0#13#137'>'#0#12#135'='#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#15#143'?'#0#14#140'?'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'p'#136#144#0'`'#128 + +#144#0'`x'#128#0'Pp'#128#0'P`p'#0'@X`'#0'@HP'#0'08@'#0' 00'#0' 0'#0#16#24' ' + +#0#16#16#16#0#16#16' '#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#192'h`'#0 + +#176'XP'#0#160'PP'#0#160'PP'#0#160'PP'#0#144'HP'#0#144'H@'#0#144'H@'#0#128'@' + +'@'#0#128'8@'#0#128'8@'#0'p8@'#0'p80'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'p' + +#136#144#0#144#160#176#0'p'#176#208#0#0#144#208#0#0#144#208#0#0#144#208#0#0 + +#144#192#0#16#136#192#0#16#128#176#0#16#128#176#0' x'#160#0' p'#144#0' H`'#0 + +#145#161#163#0#0#0#0#0#0#0#0#0#0#0#0#0#208'hp'#0#240#144#144#0#224#128#128#0 + +#176'H '#0'@0 '#0#192#184#176#0#192#184#176#0#208#192#192#0#208#200#192#0'PP' + +'P'#0#160'@0'#0#160'@0'#0#160'80'#0'p8@'#0#0#0#0#0#0#0#0#0#0#0#0#0#213#192 + +#174#0#128'p`'#0#144'x`'#0#144'p`'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#11#10#221#0#10#10 + +#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#7 + +#189#0#8#7#187#0#0#0#0#0#0#0#0#0#128#136#144#0#128#192#208#0#144#168#176#0 + +#128#224#255#0'`'#208#255#0'P'#200#255#0'P'#200#255#0'@'#192#240#0'0'#176#240 + +#0'0'#168#240#0' '#160#224#0#16#144#208#0' h'#128#0'T^e'#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#208'pp'#0#255#152#160#0#240#136#128#0#224#128#128#0'pXP'#0'@@0'#0#144 + ,'xp'#0#240#224#224#0#240#232#224#0#144#128'p'#0#160'@0'#0#160'@@'#0#160'@0'#0 + +#128'8@'#0#0#0#0#0#0#0#0#0#160#128'p'#0#160#136'p'#0#208#176#160#0#208#176 + +#160#0#192#176#160#0#176#152#128#0'`H0'#0#172#162#153#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#11#10#224#0#10#10#221#0#10 + +#10#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#8#193#0#7#8#191#0 + +#7#8#189#0#0#0#0#0#0#0#0#0#128#144#160#0#128#208#240#0#144#168#176#0#144#192 + +#208#0'p'#216#255#0'`'#208#255#0'`'#208#255#0'P'#200#255#0'P'#192#255#0'@' + +#184#240#0'0'#176#240#0'0'#168#240#0#16#136#208#0' H`'#0#183#197#201#0#0#0#0 + +#0#0#0#0#0#208'xp'#0#255#160#160#0#240#144#144#0#240#136#128#0'pXP'#0#0#0#0#0 + +'@@0'#0#240#216#208#0#240#224#208#0#128'x`'#0#176'H@'#0#176'H@'#0#160'@@'#0 + +#128'@@'#0#0#0#0#0#192#152#128#0#224#192#176#0#208#192#176#0#224#208#192#0 + +#240#224#224#0#255#248#240#0#176#152#128#0#160#144#128#0'`H0'#0#172#162#153#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#11 + +#11#225#0#10#11#221#0#10#10#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#9#200#0#8 + +#8#197#0#8#8#193#0#0#0#0#0#0#0#0#0#0#0#0#0#128#144#160#0#128#216#240#0#128 + +#200#224#0#144#168#176#0#128#224#255#0'p'#208#255#0'`'#216#255#0'`'#208#255#0 + +'`'#208#255#0'P'#200#255#0'@'#192#240#0'@'#184#240#0'0'#176#240#0' h'#128#0 + +'e'#138#153#0#0#0#0#0#0#0#0#0#208'x'#128#0#255#168#176#0#255#160#160#0#240 + +#144#144#0'pXP'#0'pXP'#0'pXP'#0'pXP'#0'p`P'#0#128'h`'#0#192'XP'#0#176'PP'#0 + +#176'H@'#0#128'@@'#0#0#0#0#0#208#176#160#0#240#240#224#0#240#232#224#0#240 + +#240#240#0#255#248#255#0#255#248#240#0#255#255#255#0#176#152#128#0#160#144 + +#128#0'`H0'#0#172#162#153#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#11#10#224#0#10#10#220#0#10#10#217#0#0#0#0#0#0#0#0#0#9 + +#9#206#0#8#8#202#0#8#8#200#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#152#160#0 + +#144#224#240#0#144#224#255#0#144#168#176#0#144#184#192#0'p'#216#255#0'`'#216 + +#255#0'`'#216#255#0'`'#216#255#0'`'#208#255#0'P'#208#255#0'P'#200#255#0'@' + +#184#240#0'0'#160#224#0'Igw'#0#192#202#209#0#0#0#0#0#224#128#128#0#255#176 + +#176#0#255#176#176#0#255#160#160#0#240#144#144#0#240#136#128#0#224#128#128#0 + +#224'x'#128#0#208'pp'#0#208'hp'#0#192'``'#0#192'XP'#0#176'PP'#0#144'H@'#0#0#0 + +#0#0#208#168#144#0#255#248#255#0#255#255#255#0#255#255#255#0#240#240#240#0 + +#240#232#224#0#240#224#224#0#255#255#255#0#176#152#128#0#160#144#128#0'`H0'#0 + +#172#162#153#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#10#10#225#0#10#10#221#0#10#10#217#0#10#9#213#0#10#10#209#0#9#9#206 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#152#160#0#144#224#240#0#160 + +#232#255#0#128#200#224#0#144#168#176#0#128#224#255#0#128#224#255#0#128#224 + +#255#0#128#224#255#0#128#224#255#0#128#224#255#0#128#224#255#0'p'#216#255#0 + +'p'#216#255#0'P'#168#208#0#133#146#157#0#0#0#0#0#224#136#144#0#255#184#192#0 + +#255#184#176#0#208'``'#0#192'`P'#0#192'XP'#0#192'P@'#0#176'P0'#0#176'H0'#0 + +#160'@ '#0#160'8'#16#0#192'``'#0#192'XP'#0#144'H@'#0#0#0#0#0#190#203#205#0 + +#208#168#144#0#255#255#255#0#255#255#255#0#255#248#255#0#240#240#240#0#240 + +#232#224#0#240#224#224#0#255#255#255#0#176#152#128#0#160#144#128#0'`H0'#0#172 + +#162#153#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#11#11#225#0#10#10#221#0#10#10#217#0#10#10#213#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#144#160#160#0#160#232#240#0#160#232#255#0#160#232 + +#255#0#144#176#192#0#144#176#192#0#144#168#176#0#144#168#176#0#128#160#176#0 + +#128#160#176#0#128#152#160#0#128#152#160#0#128#144#160#0#128#144#160#0#128 + +#136#144#0'p'#136#144#0#0#0#0#0#224#144#144#0#255#192#192#0#208'h`'#0#255#255 + +#255#0#255#255#255#0#255#248#240#0#240#240#240#0#240#232#224#0#240#216#208#0 + +#224#208#192#0#224#200#192#0#160'8'#16#0#192'``'#0#144'HP'#0#0#0#0#0#0#0#0#0 + +#190#203#205#0#208#168#144#0#255#255#255#0#255#255#255#0#255#248#255#0#240 + +#240#240#0#240#232#224#0#240#224#224#0#255#255#255#0#176#152#128#0#160#144 + +#128#0'`H0'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#11#11#228#0#11#11#224#0#10#10#220#0#10#10#217#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#160#176#0#160#232#240#0#160#240#255#0#160 + +#232#255#0#160#232#255#0#128#216#255#0'`'#216#255#0'`'#216#255#0'`'#216#255#0 + +'`'#216#255#0'`'#216#255#0'`'#216#255#0'p'#136#144#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#224#152#160#0#255#192#192#0#208'pp'#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#248#240#0#240#240#240#0#240#232#224#0#240#216#208#0#224 + +#208#192#0#160'@ '#0#208'h`'#0#160'PP'#0#0#0#0#0#0#0#0#0#0#0#0#0#190#203#205 + +#0#208#168#144#0#255#255#255#0#255#255#255#0#255#248#255#0#240#240#240#0#240 + +#232#224#0#240#224#224#0#255#255#255#0#176#152#128#0#128'`P'#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#12#12#235#0#11#11#231#0#11 + +#11#228#0#10#11#224#0#10#11#221#0#10#10#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#144#160#176#0#160#240#240#0#176#240#240#0#160#240#255#0#160#232#255 + ,#0#160#232#255#0'p'#216#255#0#144#160#160#0#128#152#160#0#128#152#160#0#128 + +#144#160#0#128#144#144#0'p'#136#144#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#160 + +#160#0#255#192#192#0#224'xp'#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#248#240#0#240#240#240#0#240#232#224#0#240#216#208#0#176'H0'#0 + +#208'pp'#0#160'PP'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#190#203#205#0#208#168 + +#144#0#255#255#255#0#255#255#255#0#255#248#255#0#240#240#240#0#240#232#224#0 + +#240#224#224#0#255#255#255#0#160#128'p'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#12#12#241#0#12#12#238#0#11#12#235#0#0#0#0#0#0#0#0#0#11 + +#11#224#0#10#10#221#0#10#10#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#168#176 + +#0#160#208#224#0#176#240#240#0#176#240#240#0#160#240#255#0#160#232#255#0#144 + +#160#176#0#178#201#207#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144'hP'#0 + +#144'hP'#0#144'hP'#0#0#0#0#0#240#168#160#0#255#192#192#0#224#128#128#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#248 + +#240#0#240#240#240#0#240#232#224#0#176'P0'#0#224'x'#128#0#160'PP'#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#190#203#205#0#208#168#144#0#255#255#255#0#255 + +#255#255#0#255#248#255#0#255#240#240#0#255#248#255#0#224#208#192#0#176#144 + +#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#12#12#245#0#12#12#243 + +#0#12#12#241#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#11#11#225#0#10#11#221#0#10#10 + +#217#0#0#0#0#0#0#0#0#0#0#0#0#0#203#215#220#0#144#168#176#0#144#168#176#0#144 + +#168#176#0#144#168#176#0#144#168#176#0#181#198#204#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#208#200#200#0#144'hP'#0#144'hP'#0#0#0#0#0#240#176 + +#176#0#255#192#192#0#240#136#144#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#248#240#0#240#240#240#0#192'P' + +'@'#0'`00'#0#176'XP'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#190 + +#203#205#0#208#168#144#0#255#255#255#0#255#255#255#0#255#248#255#0#224#208 + +#208#0#176#136'p'#0#190#203#205#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#13 + +#12#247#0#13#13#247#0#12#12#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#11#11#224#0#10#10#221#0#10#10#217#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144'x`'#0#199#188#181#0 + +#0#0#0#0#0#0#0#0#160#144#128#0#210#206#201#0#144'x`'#0#0#0#0#0#240#176#176#0 + +#255#192#192#0#255#144#144#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#248#240#0#192'XP'#0 + +#176'X`'#0#176'X`'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#190#203#205#0#208#168#144#0#192#160#144#0#176#144'p'#0#180#147#131#0#190#203 + +#205#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#13#12#247#0#13#12#247 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#11#11#224 + +#0#10#11#221#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#216#217#214#0#160#144#128#0#160#136#128#0#176#152 + +#128#0#197#191#185#0#0#0#0#0#0#0#0#0#0#0#0#0#240#184#176#0#240#184#176#0#240 + +#176#176#0#240#176#176#0#240#168#176#0#240#160#160#0#224#152#160#0#224#144 + +#144#0#224#144#144#0#224#136#144#0#224#128#128#0#208'x'#128#0#208'xp'#0#208 + +'pp'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'BM>'#0#0#0#0#0#0#0'>'#0#0#0'('#0#0#0'@'#0#0#0'0'#0#0#0 + +#1#0#1#0#0#0#0#0#128#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255 + +#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#255#255#0#0#0#0#0#0 + +#243#255#0#0#0#0#0#0#225#255#0#0#0#0#0#0#192#255#0#0#0#0#0#0#136''#0#0#0#0#0 + +#0#28'?'#0#0#0#0#0#0#190#31#0#0#0#0#0#0#255#15#0#0#0#0#0#0#255#135#0#0#0#0#0 + +#0#255#195#0#0#0#0#0#0#255#225#0#0#0#0#0#0#255#240#0#0#0#0#0#0#255#249#0#0#0 + +#0#0#0#255#255#0#0#0#0#0#0#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#0#7#192#1#255#255#255#255#0#3#128#1#192#3#207#243#0#3#128#1#128''#199 + +#227#0#1#128#1#0'?'#227#199#0#1#128#1#0#31#241#143#0#0#128#1#0#15#248#31#0#0 + +#128#1#0#7#252'?'#0#0#128#1#128#7#252'?'#0#7#128#1#192#7#248#31#0#7#128#1#224 + ,#7#241#143#0#248#128#1#240#7#227#199#1#248#128#1#248#7#199#227#255#152#128#1 + +#252#15#207#243#255#131#128#1#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); diff --git a/official/4.8.11/FastQB/fqbDesign.pas b/official/4.8.11/FastQB/fqbDesign.pas new file mode 100644 index 0000000..add0a79 --- /dev/null +++ b/official/4.8.11/FastQB/fqbDesign.pas @@ -0,0 +1,214 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ } +{ Copyright (c) 2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbDesign; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, ToolWin, ComCtrls, StdCtrls, ExtCtrls, Grids, DBGrids, + ImgList, Buttons, Menus, DB +{$IFDEF Delphi6} + ,Variants +{$ENDIF} + ,fqbSynmemo, fqbClass; + +type + + TfqbDesigner = class(TForm) + DataSource1: TDataSource; + DBGrid1: TDBGrid; + fqbGrid1: TfqbGrid; + fqbSyntaxMemo1: TfqbSyntaxMemo; + fqbTableArea1: TfqbTableArea; + fqbTableListBox1: TfqbTableListBox; + ImageList2: TImageList; + OpenDialog1: TOpenDialog; + PageControl1: TPageControl; + Panel1: TPanel; + SaveDialog1: TSaveDialog; + Splitter1: TSplitter; + Splitter2: TSplitter; + TabSheet1: TTabSheet; + TabSheet2: TTabSheet; + TabSheet3: TTabSheet; + ToolBar1: TToolBar; + ToolButton10: TToolButton; + ToolButton3: TToolButton; + ToolButton4: TToolButton; + ToolButton5: TToolButton; + ToolButton6: TToolButton; + ToolButton7: TToolButton; + ToolButton8: TToolButton; + procedure FormCreate(Sender: TObject); + procedure TabSheet2Show(Sender: TObject); + procedure TabSheet3Hide(Sender: TObject); + procedure TabSheet3Show(Sender: TObject); + procedure ToolButton10Click(Sender: TObject); + procedure ToolButton3Click(Sender: TObject); + procedure ToolButton4Click(Sender: TObject); + procedure ToolButton6Click(Sender: TObject); + procedure ToolButton7Click(Sender: TObject); + procedure FormDestroy(Sender: TObject); + protected + procedure LoadPos; + procedure SavePos; + end; + + +var + fqbDesigner: TfqbDesigner; + +implementation + +{$R *.dfm} + +uses fqbUtils, fqbRes, Registry; + +type + THackWinControl = class(TWinControl); + + +{----------------------- TfqbDesigner -----------------------} +procedure TfqbDesigner.FormCreate(Sender: TObject); +begin + LoadPos; + + ToolButton7.Hint := fqbGet(1); + ToolButton10.Hint := fqbGet(2); + ToolButton6.Hint := fqbGet(1803); + ToolButton3.Hint := fqbGet(1805); + ToolButton4.Hint := fqbGet(1804); + TabSheet1.Caption := fqbGet(1806); + TabSheet2.Caption := fqbGet(1807); + TabSheet3.Caption := fqbGet(1808); + fqbGrid1.Column[0].Caption := fqbGet(1820); + fqbGrid1.Column[1].Caption := fqbGet(1821); + fqbGrid1.Column[2].Caption := fqbGet(1822); + fqbGrid1.Column[3].Caption := fqbGet(1823); + fqbGrid1.Column[4].Caption := fqbGet(1824); + fqbGrid1.Column[5].Caption := fqbGet(1825); + + THackWinControl(fqbTableArea1).BevelKind := bkFlat; + THackWinControl(fqbTableListBox1).BevelKind := bkFlat; + THackWinControl(fqbGrid1).BevelKind := bkFlat; + THackWinControl(fqbGrid1).BevelKind := bkFlat; + THackWinControl(fqbSyntaxMemo1).BevelKind := bkFlat; + THackWinControl(DBGrid1).BevelKind := bkFlat; + + PageControl1.ActivePage := PageControl1.Pages[0]; + DataSource1.DataSet := fqbCore.Engine.ResultDataSet; + fqbTableListBox1.Items.BeginUpdate; + fqbTableListBox1.Items.Clear; + fqbCore.Engine.ReadTableList(fqbTableListBox1.Items); + fqbTableListBox1.Items.EndUpdate; +end; + +procedure TfqbDesigner.TabSheet2Show(Sender: TObject); +begin + fqbSyntaxMemo1.Lines.BeginUpdate; + fqbSyntaxMemo1.Lines.Clear; + fqbSyntaxMemo1.Lines.Text := fqbCore.GenerateSQL; + fqbSyntaxMemo1.Lines.EndUpdate +end; + +procedure TfqbDesigner.TabSheet3Hide(Sender: TObject); +begin + fqbCore.Engine.ResultDataSet.Close; +end; + +procedure TfqbDesigner.TabSheet3Show(Sender: TObject); +var + s: string; +begin + s := fqbCore.GenerateSQL; + if s = '' then Exit; + fqbCore.Engine.ResultDataSet.Close; + fqbCore.Engine.SetSQL(s); + fqbCore.Engine.ResultDataSet.Open; +end; + +procedure TfqbDesigner.ToolButton10Click(Sender: TObject); +begin + ModalResult := mrCancel +end; + +procedure TfqbDesigner.ToolButton3Click(Sender: TObject); +begin + if OpenDialog1.Execute then + begin + fqbCore.Clear; + fqbCore.LoadFromFile(OpenDialog1.FileName); + end; +end; + +procedure TfqbDesigner.ToolButton4Click(Sender: TObject); +begin + if SaveDialog1.Execute then + fqbCore.SaveToFile(SaveDialog1.FileName); +end; + +procedure TfqbDesigner.ToolButton6Click(Sender: TObject); +begin + fqbCore.Clear; +end; + +procedure TfqbDesigner.ToolButton7Click(Sender: TObject); +begin + ModalResult := mrOk +end; + +procedure TfqbDesigner.FormDestroy(Sender: TObject); +begin + SavePos; +end; + +procedure TfqbDesigner.LoadPos; +var + Reg: TRegIniFile; + s: string; +begin + s := ChangeFileExt(ExtractFileName(Application.ExeName), ''); + Reg := TRegIniFile.Create('\Software\Fast Reports\FQBuilder\' + s); + try + Reg.RootKey := HKEY_CURRENT_USER; + Reg.OpenKey('\Software\Fast Reports\FQBuilder\' + s, True); + Top := Reg.ReadInteger(Name, 'Top', Top); + Left := Reg.ReadInteger(Name, 'Left', Left); + Height := Reg.ReadInteger(Name, 'Height', Height); + Width := Reg.ReadInteger(Name, 'Width', Width); + finally + Reg.Free; + end +end; + +procedure TfqbDesigner.SavePos; +var + Reg: TRegIniFile; + s: string; +begin + s := ChangeFileExt(ExtractFileName(Application.ExeName), ''); + Reg := TRegIniFile.Create('\Software\Fast Reports\FQBuilder\' + s); + try + Reg.RootKey := HKEY_CURRENT_USER; + Reg.OpenKey('\Software\Fast Reports\FQBuilder\' + s, True); + Reg.WriteInteger(Name, 'Top', Top); + Reg.WriteInteger(Name, 'Left', Left); + Reg.WriteInteger(Name, 'Height', Height); + Reg.WriteInteger(Name, 'Width', Width); + finally + Reg.Free; + end +end; + +end. + diff --git a/official/4.8.11/FastQB/fqbLinkForm.dfm b/official/4.8.11/FastQB/fqbLinkForm.dfm new file mode 100644 index 0000000..b14f10e Binary files /dev/null and b/official/4.8.11/FastQB/fqbLinkForm.dfm differ diff --git a/official/4.8.11/FastQB/fqbLinkForm.lfm b/official/4.8.11/FastQB/fqbLinkForm.lfm new file mode 100644 index 0000000..4380170 --- /dev/null +++ b/official/4.8.11/FastQB/fqbLinkForm.lfm @@ -0,0 +1,159 @@ +object fqbLinkForm: TfqbLinkForm + Left = 385 + Height = 193 + Top = 195 + Width = 369 + HorzScrollBar.Page = 368 + VertScrollBar.Page = 192 + ActiveControl = RadioOpt + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Link Options' + Font.CharSet = RUSSIAN_CHARSET + Font.Height = -11 + Font.Name = 'Tahoma' + object Label1: TLabel + Left = 2 + Height = 17 + Top = 7 + Width = 38 + Caption = 'Table 1' + Color = clNone + ParentColor = False + end + object Label2: TLabel + Left = 2 + Height = 17 + Top = 46 + Width = 38 + Caption = 'Table 2' + Color = clNone + ParentColor = False + end + object Label3: TLabel + Left = 3 + Height = 17 + Top = 24 + Width = 51 + Caption = 'Column 1' + Color = clNone + ParentColor = False + end + object Label4: TLabel + Left = 2 + Height = 17 + Top = 62 + Width = 51 + Caption = 'Column 2' + Color = clNone + ParentColor = False + end + object RadioOpt: TRadioGroup + Left = 3 + Height = 103 + Top = 85 + Width = 126 + Anchors = [akTop, akLeft, akBottom] + AutoFill = True + Caption = 'Join Operator' + ChildSizing.LeftRightSpacing = 6 + ChildSizing.TopBottomSpacing = 6 + ChildSizing.EnlargeHorizontal = crsHomogenousChildResize + ChildSizing.EnlargeVertical = crsHomogenousChildResize + ChildSizing.ShrinkHorizontal = crsScaleChilds + ChildSizing.ShrinkVertical = crsScaleChilds + ChildSizing.Layout = cclLeftToRightThenTopToBottom + ChildSizing.ControlsPerLine = 1 + ItemIndex = 0 + Items.Strings = ( + '=' + '<' + '>' + '<=' + '>=' + '<>' + ) + TabOrder = 0 + end + object RadioType: TRadioGroup + Left = 136 + Height = 103 + Top = 85 + Width = 139 + Anchors = [akTop, akLeft, akBottom] + AutoFill = True + Caption = 'Join Type' + ChildSizing.LeftRightSpacing = 6 + ChildSizing.TopBottomSpacing = 6 + ChildSizing.EnlargeHorizontal = crsHomogenousChildResize + ChildSizing.EnlargeVertical = crsHomogenousChildResize + ChildSizing.ShrinkHorizontal = crsScaleChilds + ChildSizing.ShrinkVertical = crsScaleChilds + ChildSizing.Layout = cclLeftToRightThenTopToBottom + ChildSizing.ControlsPerLine = 1 + ItemIndex = 0 + Items.Strings = ( + 'Inner' + 'Left Outer' + 'Right Outer' + 'Full Outer' + ) + TabOrder = 1 + end + object txtTable1: TStaticText + Left = 55 + Height = 16 + Top = 7 + Width = 308 + Anchors = [akTop, akLeft, akRight] + BorderStyle = sbsSunken + TabOrder = 2 + end + object txtTable2: TStaticText + Left = 55 + Height = 16 + Top = 46 + Width = 308 + Anchors = [akTop, akLeft, akRight] + BorderStyle = sbsSunken + TabOrder = 3 + end + object txtCol1: TStaticText + Left = 55 + Height = 16 + Top = 23 + Width = 308 + Anchors = [akTop, akLeft, akRight] + BorderStyle = sbsSunken + TabOrder = 4 + end + object txtCol2: TStaticText + Left = 55 + Height = 16 + Top = 62 + Width = 308 + Anchors = [akTop, akLeft, akRight] + BorderStyle = sbsSunken + TabOrder = 5 + end + object BitBtn1: TBitBtn + Left = 290 + Height = 25 + Top = 130 + Width = 75 + Anchors = [akRight, akBottom] + Kind = bkOK + NumGlyphs = 0 + TabOrder = 6 + end + object BitBtn2: TBitBtn + Left = 290 + Height = 25 + Top = 162 + Width = 75 + Anchors = [akRight, akBottom] + Kind = bkCancel + NumGlyphs = 0 + TabOrder = 7 + end +end diff --git a/official/4.8.11/FastQB/fqbLinkForm.lrs b/official/4.8.11/FastQB/fqbLinkForm.lrs new file mode 100644 index 0000000..99e0719 --- /dev/null +++ b/official/4.8.11/FastQB/fqbLinkForm.lrs @@ -0,0 +1,50 @@ +{ Это - файл ресурсов, автоматически созданный lazarus } + +LazarusResources.Add('TfqbLinkForm','FORMDATA',[ + 'TPF0'#12'TfqbLinkForm'#11'fqbLinkForm'#4'Left'#3#129#1#6'Height'#3#193#0#3'T' + +'op'#3#195#0#5'Width'#3'q'#1#18'HorzScrollBar.Page'#3'p'#1#18'VertScrollBar.' + +'Page'#3#192#0#13'ActiveControl'#7#8'RadioOpt'#11'BorderIcons'#11#12'biSyste' + +'mMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#12'Link Options'#12'Fon' + +'t.CharSet'#7#15'RUSSIAN_CHARSET'#11'Font.Height'#2#245#9'Font.Name'#6#6'Tah' + +'oma'#0#6'TLabel'#6'Label1'#4'Left'#2#2#6'Height'#2#17#3'Top'#2#7#5'Width'#2 + +'&'#7'Caption'#6#7'Table 1'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLa' + +'bel'#6'Label2'#4'Left'#2#2#6'Height'#2#17#3'Top'#2'.'#5'Width'#2'&'#7'Capti' + +'on'#6#7'Table 2'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Lab' + +'el3'#4'Left'#2#3#6'Height'#2#17#3'Top'#2#24#5'Width'#2'3'#7'Caption'#6#8'Co' + +'lumn 1'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Le' + +'ft'#2#2#6'Height'#2#17#3'Top'#2'>'#5'Width'#2'3'#7'Caption'#6#8'Column 2'#5 + +'Color'#7#6'clNone'#11'ParentColor'#8#0#0#11'TRadioGroup'#8'RadioOpt'#4'Left' + +#2#3#6'Height'#2'g'#3'Top'#2'U'#5'Width'#2'~'#7'Anchors'#11#5'akTop'#6'akLef' + +'t'#8'akBottom'#0#8'AutoFill'#9#7'Caption'#6#13'Join Operator'#28'ChildSizin' + +'g.LeftRightSpacing'#2#6#28'ChildSizing.TopBottomSpacing'#2#6#29'ChildSizing' + +'.EnlargeHorizontal'#7#24'crsHomogenousChildResize'#27'ChildSizing.EnlargeVe' + +'rtical'#7#24'crsHomogenousChildResize'#28'ChildSizing.ShrinkHorizontal'#7#14 + +'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsScaleChilds'#18'Chil' + +'dSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'ChildSizing.Controls' + +'PerLine'#2#1#9'ItemIndex'#2#0#13'Items.Strings'#1#6#1'='#6#1'<'#6#1'>'#6#2 + +'<='#6#2'>='#6#2'<>'#0#8'TabOrder'#2#0#0#0#11'TRadioGroup'#9'RadioType'#4'Le' + +'ft'#3#136#0#6'Height'#2'g'#3'Top'#2'U'#5'Width'#3#139#0#7'Anchors'#11#5'akT' + +'op'#6'akLeft'#8'akBottom'#0#8'AutoFill'#9#7'Caption'#6#9'Join Type'#28'Chil' + +'dSizing.LeftRightSpacing'#2#6#28'ChildSizing.TopBottomSpacing'#2#6#29'Child' + +'Sizing.EnlargeHorizontal'#7#24'crsHomogenousChildResize'#27'ChildSizing.Enl' + +'argeVertical'#7#24'crsHomogenousChildResize'#28'ChildSizing.ShrinkHorizonta' + +'l'#7#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsScaleChilds' + +#18'ChildSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'ChildSizing.C' + +'ontrolsPerLine'#2#1#9'ItemIndex'#2#0#13'Items.Strings'#1#6#5'Inner'#6#10'Le' + +'ft Outer'#6#11'Right Outer'#6#10'Full Outer'#0#8'TabOrder'#2#1#0#0#11'TStat' + +'icText'#9'txtTable1'#4'Left'#2'7'#6'Height'#2#16#3'Top'#2#7#5'Width'#3'4'#1 + +#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#11'BorderStyle'#7#9'sbsSunken' + +#8'TabOrder'#2#2#0#0#11'TStaticText'#9'txtTable2'#4'Left'#2'7'#6'Height'#2#16 + +#3'Top'#2'.'#5'Width'#3'4'#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#11 + +'BorderStyle'#7#9'sbsSunken'#8'TabOrder'#2#3#0#0#11'TStaticText'#7'txtCol1'#4 + +'Left'#2'7'#6'Height'#2#16#3'Top'#2#23#5'Width'#3'4'#1#7'Anchors'#11#5'akTop' + +#6'akLeft'#7'akRight'#0#11'BorderStyle'#7#9'sbsSunken'#8'TabOrder'#2#4#0#0#11 + +'TStaticText'#7'txtCol2'#4'Left'#2'7'#6'Height'#2#16#3'Top'#2'>'#5'Width'#3 + +'4'#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#11'BorderStyle'#7#9'sbsS' + +'unken'#8'TabOrder'#2#5#0#0#7'TBitBtn'#7'BitBtn1'#4'Left'#3'"'#1#6'Height'#2 + +#25#3'Top'#3#130#0#5'Width'#2'K'#7'Anchors'#11#7'akRight'#8'akBottom'#0#4'Ki' + +'nd'#7#4'bkOK'#9'NumGlyphs'#2#0#8'TabOrder'#2#6#0#0#7'TBitBtn'#7'BitBtn2'#4 + +'Left'#3'"'#1#6'Height'#2#25#3'Top'#3#162#0#5'Width'#2'K'#7'Anchors'#11#7'ak' + +'Right'#8'akBottom'#0#4'Kind'#7#8'bkCancel'#9'NumGlyphs'#2#0#8'TabOrder'#2#7 + +#0#0#0 +]); diff --git a/official/4.8.11/FastQB/fqbLinkForm.pas b/official/4.8.11/FastQB/fqbLinkForm.pas new file mode 100644 index 0000000..fcf4257 --- /dev/null +++ b/official/4.8.11/FastQB/fqbLinkForm.pas @@ -0,0 +1,40 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ } +{ Copyright (c) 2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbLinkForm; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls, Buttons; + +type + TfqbLinkForm = class(TForm) + RadioOpt: TRadioGroup; + RadioType: TRadioGroup; + txtTable1: TStaticText; + txtTable2: TStaticText; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + txtCol1: TStaticText; + Label4: TLabel; + txtCol2: TStaticText; + BitBtn1: TBitBtn; + BitBtn2: TBitBtn; + end; + +implementation + +{$R *.DFM} + +end. diff --git a/official/4.8.11/FastQB/fqbReg.pas b/official/4.8.11/FastQB/fqbReg.pas new file mode 100644 index 0000000..a0fe66b --- /dev/null +++ b/official/4.8.11/FastQB/fqbReg.pas @@ -0,0 +1,37 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ } +{ Copyright (c) 2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbReg; + +interface + +procedure Register; + +implementation + +uses + Windows, Messages, Classes +{$IFNDEF Delphi6} + ,DsgnIntf +{$ELSE} + ,DesignIntf, DesignEditors +{$ENDIF} + ,fqbClass, fqbSynMemo; + +{$R 'FQB.DCR'} + +procedure Register; +begin + RegisterComponents('FastQueryBuilder', [TfqbDialog, + TfqbTableArea, TfqbTableListBox, TfqbSyntaxMemo, TfqbGrid]); +end; + +end. diff --git a/official/4.8.11/FastQB/fqbRes.pas b/official/4.8.11/FastQB/fqbRes.pas new file mode 100644 index 0000000..1a06128 --- /dev/null +++ b/official/4.8.11/FastQB/fqbRes.pas @@ -0,0 +1,172 @@ +{******************************************} +{ } +{ FastReport v3.0 } +{ Language resources management } +{ } +{ Copyright (c) 1998-2005 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit fqbRes; + +interface + +{$I fqb.inc} + +uses + Windows, SysUtils, Classes, Controls, Graphics, Forms, ImgList, TypInfo +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfqbResources = class(TObject) + private + FNames: TStringList; + FValues: TStringList; + public + constructor Create; + destructor Destroy; override; + function Get(const StrName: String): String; + procedure Add(const Ref, Str: String); + procedure AddStrings(const Str: String); + procedure Clear; + procedure LoadFromFile(const FileName: String); + procedure LoadFromStream(Stream: TStream); + end; + +function fqbResources: TfqbResources; +function fqbGet(ID: Integer): String; + + +implementation + +var + FResources: TfqbResources = nil; + +{ TfrxResources } + +constructor TfqbResources.Create; +begin + inherited; + FNames := TStringList.Create; + FValues := TStringList.Create; + FNames.Sorted := True; +end; + +destructor TfqbResources.Destroy; +begin + FNames.Free; + FValues.Free; + inherited; +end; + +procedure TfqbResources.Add(const Ref, Str: String); +var + i: Integer; +begin + i := FNames.IndexOf(Ref); + if i = -1 then + begin + FNames.AddObject(Ref, Pointer(FValues.Count)); + FValues.Add(Str); + end + else + FValues[Integer(FNames.Objects[i])] := Str; +end; + +procedure TfqbResources.AddStrings(const Str: String); +var + i: Integer; + sl: TStringList; + nm, vl: String; +begin + sl := TStringList.Create; + sl.Text := Str; + for i := 0 to sl.Count - 1 do + begin +// nm := sl[i]; + nm := sl.Names[i];// Copy(nm, Pos('=', nm) + 1, MaxInt); + vl := sl.Values[nm];// Copy(nm, 1, Pos('=', nm) - 1); + if (nm <> '') and (vl <> '') then + Add(nm, vl); + end; + sl.Free; +end; + +procedure TfqbResources.Clear; +begin + FNames.Clear; + FValues.Clear; +end; + +function TfqbResources.Get(const StrName: String): String; +var + i: Integer; +begin + i := FNames.IndexOf(StrName); + if i <> -1 then + Result := FValues[Integer(FNames.Objects[i])] else + Result := StrName; +end; + +procedure TfqbResources.LoadFromFile(const FileName: String); +var + f: TFileStream; +begin + f := TFileStream.Create(FileName, fmOpenRead); + try + LoadFromStream(f); + finally + f.Free; + end; +end; + +procedure TfqbResources.LoadFromStream(Stream: TStream); +var + sl: TStringList; + i: Integer; + nm, vl: String; +begin + sl := TStringList.Create; + try + sl.LoadFromStream(Stream); + Clear; + for i := 0 to sl.Count - 1 do + begin + nm := sl[i]; + vl := Copy(nm, Pos('=', nm) + 1, MaxInt); + nm := Copy(nm, 1, Pos('=', nm) - 1); + if (nm <> '') and (vl <> '') then + Add(nm, vl); + end; + finally + sl.Free; + end +end; + + +function fqbResources: TfqbResources; +begin + if FResources = nil then + FResources := TfqbResources.Create; + Result := FResources; +end; + +function fqbGet(ID: Integer): String; +begin + Result := fqbResources.Get(IntToStr(ID)); +end; + + +initialization + +finalization + if FResources <> nil then + FResources.Free; + FResources := nil; + +end. diff --git a/official/4.8.11/FastQB/fqbSynmemo.dfm b/official/4.8.11/FastQB/fqbSynmemo.dfm new file mode 100644 index 0000000..05d74a8 Binary files /dev/null and b/official/4.8.11/FastQB/fqbSynmemo.dfm differ diff --git a/official/4.8.11/FastQB/fqbSynmemo.lfm b/official/4.8.11/FastQB/fqbSynmemo.lfm new file mode 100644 index 0000000..6640491 --- /dev/null +++ b/official/4.8.11/FastQB/fqbSynmemo.lfm @@ -0,0 +1,54 @@ +object fqbSynMemoSearch: TfqbSynMemoSearch + Left = 289 + Height = 50 + Top = 229 + Width = 243 + HorzScrollBar.Page = 242 + VertScrollBar.Page = 49 + ActiveControl = Edit1 + BorderStyle = bsToolWindow + Caption = 'Search' + Font.Height = -11 + Font.Name = 'MS Sans Serif' + KeyPreview = True + OnKeyPress = FormKeyPress + Position = poScreenCenter + object Label1: TLabel + Left = 6 + Height = 13 + Top = 7 + Width = 69 + AutoSize = False + Caption = 'Text to find' + Color = clNone + ParentColor = False + end + object Search: TButton + Left = 111 + Height = 17 + Top = 31 + Width = 58 + BorderSpacing.InnerBorder = 4 + Caption = 'Search' + ModalResult = 1 + TabOrder = 0 + end + object Button1: TButton + Left = 175 + Height = 17 + Top = 31 + Width = 61 + BorderSpacing.InnerBorder = 4 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + object Edit1: TEdit + Left = 80 + Height = 21 + Top = 4 + Width = 156 + TabOrder = 2 + end +end diff --git a/official/4.8.11/FastQB/fqbSynmemo.lrs b/official/4.8.11/FastQB/fqbSynmemo.lrs new file mode 100644 index 0000000..ff3cd6b --- /dev/null +++ b/official/4.8.11/FastQB/fqbSynmemo.lrs @@ -0,0 +1,18 @@ +{ Это - файл ресурсов, автоматически созданный lazarus } + +LazarusResources.Add('TfqbSynMemoSearch','FORMDATA',[ + 'TPF0'#17'TfqbSynMemoSearch'#16'fqbSynMemoSearch'#4'Left'#3'!'#1#6'Height'#2 + +'2'#3'Top'#3#229#0#5'Width'#3#243#0#18'HorzScrollBar.Page'#3#242#0#18'VertSc' + +'rollBar.Page'#2'1'#13'ActiveControl'#7#5'Edit1'#11'BorderStyle'#7#12'bsTool' + +'Window'#7'Caption'#6#6'Search'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS S' + +'ans Serif'#10'KeyPreview'#9#10'OnKeyPress'#7#12'FormKeyPress'#8'Position'#7 + +#14'poScreenCenter'#0#6'TLabel'#6'Label1'#4'Left'#2#6#6'Height'#2#13#3'Top'#2 + +#7#5'Width'#2'E'#8'AutoSize'#8#7'Caption'#6#12'Text to find'#5'Color'#7#6'cl' + +'None'#11'ParentColor'#8#0#0#7'TButton'#6'Search'#4'Left'#2'o'#6'Height'#2#17 + +#3'Top'#2#31#5'Width'#2':'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#6 + +'Search'#11'ModalResult'#2#1#8'TabOrder'#2#0#0#0#7'TButton'#7'Button1'#4'Lef' + +'t'#3#175#0#6'Height'#2#17#3'Top'#2#31#5'Width'#2'='#25'BorderSpacing.InnerB' + +'order'#2#4#6'Cancel'#9#7'Caption'#6#6'Cancel'#11'ModalResult'#2#2#8'TabOrde' + +'r'#2#1#0#0#5'TEdit'#5'Edit1'#4'Left'#2'P'#6'Height'#2#21#3'Top'#2#4#5'Width' + +#3#156#0#8'TabOrder'#2#2#0#0#0 +]); diff --git a/official/4.8.11/FastQB/fqbSynmemo.pas b/official/4.8.11/FastQB/fqbSynmemo.pas new file mode 100644 index 0000000..4cfbd37 --- /dev/null +++ b/official/4.8.11/FastQB/fqbSynmemo.pas @@ -0,0 +1,2014 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ Syntax memo control } +{ } +{ (c) 2003 by Alexander Tzyganenko, } +{ Fast Reports, Inc } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbSynmemo; + +interface + +uses + Windows, Messages, Classes, Controls, StdCtrls, Forms, Menus, Graphics, SysUtils; + +type + + TSyntaxType = (stPascal, stCpp, stSQL, stText); + TCharAttr = (caNone, caText, caBlock, caComment, caKeyword, caString); + TCharAttributes = set of TCharAttr; + + TfqbSyntaxMemo = class(TCustomControl) + private + FAllowLinesChange: Boolean; + FCharHeight: Integer; + FCharWidth: Integer; + FDoubleClicked: Boolean; + FDown: Boolean; + FGutterWidth: Integer; + FFooterHeight: Integer; + FIsMonoType: Boolean; + FKeywords: String; + FMaxLength: Integer; + FMessage: String; + FModified: Boolean; + FMoved: Boolean; + FOffset: TPoint; + FPos: TPoint; + FReadOnly: Boolean; + FSelEnd: TPoint; + FSelStart: TPoint; + FSynStrings: TStrings; + FSyntaxType: TSyntaxType; + FTempPos: TPoint; + FText: TStringList; + FKeywordAttr: TFont; + FStringAttr: TFont; + FTextAttr: TFont; + FCommentAttr: TFont; + FBlockColor: TColor; + FBlockFontColor: TColor; + FUndo: TStringList; + FUpdating: Boolean; + FUpdatingSyntax: Boolean; + FVScroll: TScrollBar; + FWindowSize: TPoint; + FPopupMenu: TPopupMenu; +{$IFDEF Delphi4} + KWheel: Integer; +{$ENDIF} + LastSearch: String; + FShowGutter: boolean; + FShowFooter: boolean; +{$IFDEF Delphi4} + Bookmarks: array of Integer; +{$ELSE} + Bookmarks: array [0..10] of Integer; +{$ENDIF} + FActiveLine: Integer; + function GetText: TStrings; + procedure SetText(Value: TStrings); + procedure SetSyntaxType(Value: TSyntaxType); + procedure SetShowGutter(Value: boolean); + procedure SetShowFooter(Value: boolean); + function FMemoFind(Text: String; var Position : TPoint): boolean; + function GetCharAttr(Pos: TPoint): TCharAttributes; + function GetLineBegin(Index: Integer): Integer; + function GetPlainTextPos(Pos: TPoint): Integer; + function GetPosPlainText(Pos: Integer): TPoint; + function GetSelText: String; + function LineAt(Index: Integer): String; + function LineLength(Index: Integer): Integer; + function Pad(n: Integer): String; + procedure AddSel; + procedure AddUndo; + procedure ClearSel; + procedure CreateSynArray; + procedure DoChange; + procedure EnterIndent; + procedure SetSelText(Value: String); + procedure ShiftSelected(ShiftRight: Boolean); + procedure ShowCaretPos; + procedure TabIndent; + procedure UnIndent; + procedure UpdateScrollBar; + procedure UpdateSyntax; + procedure DoLeft; + procedure DoRight; + procedure DoUp; + procedure DoDown; + procedure DoHome(Ctrl: Boolean); + procedure DoEnd(Ctrl: Boolean); + procedure DoPgUp; + procedure DoPgDn; + procedure DoChar(Ch: Char); + procedure DoReturn; + procedure DoDel; + procedure DoBackspace; + procedure DoCtrlI; + procedure DoCtrlU; + procedure DoCtrlR; + procedure DoCtrlL; + procedure ScrollClick(Sender: TObject); + procedure ScrollEnter(Sender: TObject); + procedure LinesChange(Sender: TObject); + procedure ShowPos; + procedure BookmarkDraw(Y :integer; line : integer); + procedure ActiveLineDraw(Y :integer; line : integer); + procedure CorrectBookmark(Line : integer; delta : integer); + procedure SetKeywordAttr(Value: TFont); + procedure SetStringAttr(Value: TFont); + procedure SetTextAttr(Value: TFont); + procedure SetCommentAttr(Value: TFont); + + protected + { Windows-specific stuff } + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + { End of stuff } + procedure SetParent(Value: TWinControl); override; + function GetClientRect: TRect; override; + procedure DblClick; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + procedure CopyPopup(Sender: TObject); + procedure PastePopup(Sender: TObject); + procedure CutPopup(Sender: TObject); +{$IFDEF Delphi4} + procedure MouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure MouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +{$ENDIF} + procedure DOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); + procedure DDrop(Sender, Source: TObject; X, Y: Integer); + + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + procedure Paint; override; + procedure CopyToClipboard; + procedure CutToClipboard; + procedure PasteFromClipboard; + procedure SetPos(x, y: Integer); + procedure ShowMessage(s: String); + procedure Undo; + procedure UpdateView; + function GetPos: TPoint; + function Find(Text: String): boolean; + property Modified: Boolean read FModified write FModified; + property SelText: String read GetSelText write SetSelText; + function IsBookmark(Line : integer): integer; + procedure AddBookmark(Line, Number : integer); + procedure DeleteBookmark(Number : integer); + procedure GotoBookmark(Number : integer); + procedure SetActiveLine(Line : Integer); + function GetActiveLine: Integer; + + published + property Align; +{$IFDEF Delphi4} + property Anchors; + property BiDiMode; + property Constraints; + property DragKind; + property ParentBiDiMode; +{$ENDIF} + property Color; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Width; + property Height; + property Visible; + property BlockColor: TColor read FBlockColor write FBlockColor; + property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor; + property CommentAttr: TFont read FCommentAttr write SetCommentAttr; + property KeywordAttr: TFont read FKeywordAttr write SetKeywordAttr; + property StringAttr: TFont read FStringAttr write SetStringAttr; + property TextAttr: TFont read FTextAttr write SetTextAttr; + property Lines: TStrings read GetText write SetText; + property ReadOnly: Boolean read FReadOnly write FReadOnly; + property SyntaxType: TSyntaxType read FSyntaxType write SetSyntaxType; + property ShowFooter: boolean read FShowFooter write SetShowFooter; + property ShowGutter: boolean read FShowGutter write SetShowGutter; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + + TfqbSynMemoSearch = class(TForm) + Search: TButton; + Button1: TButton; + Label1: TLabel; + Edit1: TEdit; + procedure FormKeyPress(Sender: TObject; var Key: Char); + private + { Private declarations } + public + { Public declarations } + end; + +var + fqbSynMemoSearch: TfqbSynMemoSearch; + +procedure Register; + +implementation + +{$R *.DFM} + +uses Clipbrd, comctrls; + +procedure Register; +begin + RegisterComponents('FastQB2', [TfqbSyntaxMemo]) +end; + +const + PasKeywords = + 'and,array,begin,case,const,div,do,downto,else,end,except,finally,'+ + 'for,function,if,in,is,mod,nil,not,of,or,procedure,program,repeat,shl,'+ + 'shr,string,then,to,try,until,uses,var,while,with,xor'; + + CppKeywords = + 'bool,break,case,char,continue,define,default,delete,do,double,else,'+ + 'except,finally,float,for,if,include,int,is,new,return,string,switch,try,'+ + 'variant,void,while'; + + SQLKeywords = + 'active,after,all,alter,and,any,as,asc,ascending,at,auto,' + + 'base_name,before,begin,between,by,cache,cast,check,column,commit,' + + 'committed,computed,conditional,constraint,containing,count,create,' + + 'current,cursor,database,debug,declare,default,delete,desc,descending,' + + 'distinct,do,domain,drop,else,end,entry_point,escape,exception,execute,' + + 'exists,exit,external,extract,filter,for,foreign,from,full,function,' + + 'generator,grant,group,having,if,in,inactive,index,inner,insert,into,is,' + + 'isolation,join,key,left,level,like,merge,names,no,not,null,of,on,only,' + + 'or,order,outer,parameter,password,plan,position,primary,privileges,' + + 'procedure,protected,read,retain,returns,revoke,right,rollback,schema,' + + 'select,set,shadow,shared,snapshot,some,suspend,table,then,to,' + + 'transaction,trigger,uncommitted,union,unique,update,user,using,view,' + + 'wait,when,where,while,with,work'; + + WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_']; + +type + THackScrollBar = class(TScrollBar) + end; + +{ TfrSyntaxMemo } + +constructor TfqbSyntaxMemo.Create(AOwner: TComponent); +var + m: TMenuItem; + i: integer; +begin + inherited Create(AOwner); + + FVScroll := TScrollBar.Create(Self); + + FCommentAttr := TFont.Create; + FCommentAttr.Color := clNavy; + FCommentAttr.Style := [fsItalic]; + + FKeywordAttr := TFont.Create; + FKeywordAttr.Color := clWindowText; + FKeywordAttr.Style := [fsBold]; + + FStringAttr := TFont.Create; + FStringAttr.Color := clNavy; + FStringAttr.Style := []; + + FTextAttr := TFont.Create; + FTextAttr.Color := clWindowText; + FTextAttr.Style := []; + + + if AOwner is TWinControl then + Parent := AOwner as TWinControl; + + OnDragOver := DOver; + OnDragDrop := DDrop; + +{$IFDEF Delphi4} + OnMouseWheelUp := MouseWheelUp; + OnMouseWheelDown := MouseWheelDown; + KWheel := 1; +{$ENDIF} + + FText := TStringList.Create; + FUndo := TStringList.Create; + FSynStrings := TStringList.Create; + FText.Add(''); + FText.OnChange := LinesChange; + FMaxLength := 1024; + SyntaxType := stPascal; + FMoved := True; + SetPos(1, 1); + + Cursor := crIBeam; + FBlockColor := clHighlight; + FBlockFontColor := clHighlightText; + + Font.Size := 10; + Font.Name := 'Courier New'; + + FPopupMenu := TPopupMenu.Create(Self); + m := TMenuItem.Create(FPopupMenu); + m.Caption := 'Cut'; + m.OnClick := CutPopup; + FPopupMenu.Items.Add(m); + m := TMenuItem.Create(FPopupMenu); + m.Caption := 'Copy'; + m.OnClick := CopyPopup; + FPopupMenu.Items.Add(m); + m := TMenuItem.Create(FPopupMenu); + m.Caption := 'Paste'; + m.OnClick := PastePopup; + FPopupMenu.Items.Add(m); + + LastSearch := ''; +{$IFDEF Delphi4} + Setlength(Bookmarks, 10); + for i := 0 to Length(Bookmarks)-1 do +{$ELSE} + for i := 0 to 9 do +{$ENDIF} + Bookmarks[i] := -1; + + FActiveLine := -1; + + Height := 200; + Width := 200; + +end; + +destructor TfqbSyntaxMemo.Destroy; +begin + FPopupMenu.Free; + FCommentAttr.Free; + FKeywordAttr.Free; + FStringAttr.Free; + FTextAttr.Free; + FText.Free; + FUndo.Free; + FSynStrings.Free; + FVScroll.Free; + inherited; +end; + +{ Windows-specific stuff } + +procedure TfqbSyntaxMemo.WMKillFocus(var Msg: TWMKillFocus); +begin + inherited; + HideCaret(Handle); + DestroyCaret; +end; + +procedure TfqbSyntaxMemo.WMSetFocus(var Msg: TWMSetFocus); +begin + inherited; + CreateCaret(Handle, 0, 2, FCharHeight); + ShowCaretPos; +end; + +procedure TfqbSyntaxMemo.ShowCaretPos; +begin + SetCaretPos(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, + FCharHeight * (FPos.Y - 1 - FOffset.Y)); + ShowCaret(Handle); + ShowPos; +end; + +procedure TfqbSyntaxMemo.ShowPos; +begin + if FFooterHeight > 0 then + with Canvas do + begin + Font.Name := 'Tahoma'; + Font.Color := clBlack; + Font.Style := []; + Font.Size := 8; + Brush.Color := clBtnFace; + TextOut(FGutterWidth + 4, Height - TextHeight('|') - 5, IntToStr(FPos.y) + ' : ' + IntToStr(FPos.x) + ' '); + end; +end; + +procedure TfqbSyntaxMemo.WMGetDlgCode(var Message: TWMGetDlgCode); +begin + Message.Result := DLGC_WANTARROWS or DLGC_WANTTAB; +end; + +procedure TfqbSyntaxMemo.CMFontChanged(var Message: TMessage); +var + b: TBitmap; +begin + FCommentAttr.Size := Font.Size; + FCommentAttr.Name := Font.Name; + FKeywordAttr.Size := Font.Size; + FKeywordAttr.Name := Font.Name; + FStringAttr.Size := Font.Size; + FStringAttr.Name := Font.Name; + FTextAttr.Size := Font.Size; + FTextAttr.Name := Font.Name; + + b := TBitmap.Create; + with b.Canvas do + begin + Font.Assign(Self.Font); + Font.Style := [fsBold]; + FCharHeight := TextHeight('Wg'); + FCharWidth := TextWidth('W'); + FIsMonoType := Pos('COURIER NEW', AnsiUppercase(Self.Font.Name)) <> 0; + end; + b.Free; +end; + +{ End of stuff } + +procedure TfqbSyntaxMemo.SetParent(Value: TWinControl); +begin + inherited SetParent(Value); + if (Parent = nil) or (csDestroying in ComponentState) then Exit; + + ShowGutter := True; + ShowFooter := True; + FVScroll.Parent := Self; + FVScroll.Kind := sbVertical; + FVScroll.OnChange := ScrollClick; + FVScroll.OnEnter := ScrollEnter; + FVScroll.Ctl3D := False; + Color := clWindow; + TabStop := True; + +end; + + +function TfqbSyntaxMemo.GetClientRect: TRect; +begin + if FVScroll.Visible then + Result := Bounds(0, 0, Width - FVScroll.Width - 4, Height) else + Result := inherited GetClientRect; +end; + +procedure TfqbSyntaxMemo.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited; + if FCharWidth = 0 then exit; + FWindowSize := Point((ClientWidth - FGutterWidth) div FCharWidth, + (Height - FFooterHeight) div FCharHeight ); + FVScroll.SetBounds(Width - FVScroll.Width - 4, 0, FVScroll.Width, Height - 4); + UpdateScrollBar; +end; + +procedure TfqbSyntaxMemo.UpdateSyntax; +begin + CreateSynArray; + Repaint; +end; + +procedure TfqbSyntaxMemo.UpdateScrollBar; +begin + with FVScroll do + begin +// prevent OnScroll event + FUpdating := True; + Position := 0; +{$IFDEF Delphi4} + PageSize := 0; +{$ENDIF} + if Assigned(FText) then + Max := FText.Count + else + Max := 0; + SmallChange := 1; + if FWindowSize.Y < Max then + begin + Visible := True; +{$IFDEF Delphi4} + PageSize := FWindowSize.Y; +{$ENDIF} + end + else + Visible := False; + LargeChange := FWindowSize.Y; + Position := FOffset.Y; + +// need to do this due to bug in the VCL +// THackScrollBar(FVScroll).RecreateWnd; + FUpdating := False; + end; +end; + +function TfqbSyntaxMemo.GetText: TStrings; +var + i: Integer; +begin + for i := 0 to FText.Count - 1 do + FText[i] := LineAt(i); + Result := FText; + FAllowLinesChange := True; +end; + +procedure TfqbSyntaxMemo.SetText(Value: TStrings); +begin + FAllowLinesChange := True; + FText.Assign(Value); +end; + +procedure TfqbSyntaxMemo.SetSyntaxType(Value: TSyntaxType); +begin + FSyntaxType := Value; + if Value = stPascal then + FKeywords := PasKeywords + else if Value = stCpp then + FKeywords := CppKeywords + else if Value = stSQL then + FKeywords := SQLKeywords + else + FKeywords := ''; + UpdateSyntax; +end; + +function TfqbSyntaxMemo.GetPos: TPoint; +begin + Result := FPos; +end; + +procedure TfqbSyntaxMemo.DoChange; +begin + FModified := True; +end; + +procedure TfqbSyntaxMemo.LinesChange(Sender: TObject); +begin + if FAllowLinesChange then + begin + UpdateSyntax; + FAllowLinesChange := False; + if FText.Count = 0 then + FText.Add(''); + FMoved := True; + FUndo.Clear; + FPos := Point(1, 1); + FOffset := Point(0, 0); + ClearSel; + ShowCaretPos; + UpdateScrollBar; + end; +end; + +procedure TfqbSyntaxMemo.ShowMessage(s: String); +begin + FMessage := s; + Repaint; +end; + +procedure TfqbSyntaxMemo.CopyToClipboard; +begin + if FSelStart.X <> 0 then + Clipboard.AsText := SelText; +end; + +procedure TfqbSyntaxMemo.CutToClipboard; +begin + if not FReadOnly then + begin + if FSelStart.X <> 0 then + begin + Clipboard.AsText := SelText; + SelText := ''; + end; + CorrectBookmark(FSelStart.Y, FSelStart.Y - FSelEnd.Y); + Repaint; + end; +end; + +procedure TfqbSyntaxMemo.PasteFromClipboard; +begin + if not FReadOnly then + SelText := Clipboard.AsText; +end; + +function TfqbSyntaxMemo.LineAt(Index: Integer): String; +begin + if Index < FText.Count then + Result := TrimRight(FText[Index]) + else + Result := ''; +end; + +function TfqbSyntaxMemo.LineLength(Index: Integer): Integer; +begin + Result := Length(LineAt(Index)); +end; + +function TfqbSyntaxMemo.Pad(n: Integer): String; +{$IFDEF Delphi12} +var + i: Integer; +{$ENDIF} +begin + result := ''; + SetLength(result, n); +{$IFDEF Delphi12} + for i:= 1 to n do result[i] := ' '; +{$ELSE} + FillChar(result[1], n, ' '); +{$ENDIF} + +end; + +procedure TfqbSyntaxMemo.AddUndo; +begin + if not FMoved then exit; + FUndo.Add(Format('%5d%5d', [FPos.X, FPos.Y]) + FText.Text); + if FUndo.Count > 32 then + FUndo.Delete(0); +end; + +procedure TfqbSyntaxMemo.Undo; +var + s: String; +begin + FMoved := True; + if FUndo.Count = 0 then exit; + s := FUndo[FUndo.Count - 1]; + FPos.X := StrToInt(Copy(s, 1, 5)); + FPos.Y := StrToInt(Copy(s, 6, 5)); + FText.Text := Copy(s, 11, Length(s) - 10); + FUndo.Delete(FUndo.Count - 1); + SetPos(FPos.X, FPos.Y); + UpdateSyntax; + DoChange; +end; + +function TfqbSyntaxMemo.GetPlainTextPos(Pos: TPoint): Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Pos.Y - 2 do + Result := Result + Length(FText[i]) + 2; + Result := Result + Pos.X; +end; + +function TfqbSyntaxMemo.GetPosPlainText(Pos: Integer): TPoint; +var + i: Integer; + s: String; +begin + Result := Point(0, 1); + s := FText.Text; + i := 1; + while i <= Pos do + if s[i] = #13 then + begin + Inc(i, 2); + if i <= Pos then + begin + Inc(Result.Y); + Result.X := 0; + end + else + Inc(Result.X); + end + else + begin + Inc(i); + Inc(Result.X); + end; +end; + +function TfqbSyntaxMemo.GetLineBegin(Index: Integer): Integer; +var + s: String; +begin + s := FText[Index]; + Result := 1; + if Trim(s) <> '' then + for Result := 1 to Length(s) do + if s[Result] <> ' ' then + break; +end; + +procedure TfqbSyntaxMemo.TabIndent; +var + i, n, res: Integer; + s: String; +begin + res := FPos.X; + i := FPos.Y - 2; + + while i >= 0 do + begin + res := FPos.X; + s := FText[i]; + n := LineLength(i); + + if res > n then + Dec(i) + else + begin + if s[res] = ' ' then + begin + while s[res] = ' ' do + Inc(res); + end + else + begin + while (res <= n) and (s[res] <> ' ') do + Inc(res); + + while (res <= n) and (s[res] = ' ') do + Inc(res); + end; + break; + end; + end; + + SelText := Pad(res - FPos.X); +end; + +procedure TfqbSyntaxMemo.EnterIndent; +var + res: Integer; +begin + if Trim(FText[FPos.Y - 1]) = '' then + res := FPos.X else + res := GetLineBegin(FPos.Y - 1); + + CorrectBookmark(FPos.Y, 1); + + FPos := Point(1, FPos.Y + 1); + SelText := Pad(res - 1); +end; + +procedure TfqbSyntaxMemo.UnIndent; +var + i, res: Integer; +begin + i := FPos.Y - 2; + res := FPos.X - 1; + CorrectBookmark(FPos.Y, -1); + while i >= 0 do + begin + res := GetLineBegin(i); + if (res < FPos.X) and (Trim(FText[i]) <> '') then + break else + Dec(i); + end; + FSelStart := FPos; + FSelEnd := FPos; + Dec(FSelEnd.X, FPos.X - res); + SelText := ''; +end; + +procedure TfqbSyntaxMemo.ShiftSelected(ShiftRight: Boolean); +var + i, ib, ie: Integer; + s: String; + Shift: Integer; +begin + if FReadOnly then exit; + AddUndo; + if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + ib := FSelStart.Y - 1; + ie := FSelEnd.Y - 1; + end + else + begin + ib := FSelEnd.Y - 1; + ie := FSelStart.Y - 1; + end; + if FSelEnd.X = 1 then + Dec(ie); + + Shift := 2; + if not ShiftRight then + for i := ib to ie do + begin + s := FText[i]; + if (Trim(s) <> '') and (GetLineBegin(i) - 1 < Shift) then + Shift := GetLineBegin(i) - 1; + end; + + for i := ib to ie do + begin + s := FText[i]; + if ShiftRight then + s := Pad(Shift) + s + else if Trim(s) <> '' then + Delete(s, 1, Shift); + FText[i] := s; + end; + UpdateSyntax; + DoChange; +end; + +function TfqbSyntaxMemo.GetSelText: String; +var + p1, p2: TPoint; + i: Integer; +begin + if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + p1 := FSelStart; + p2 := FSelEnd; + Dec(p2.X); + end + else + begin + p1 := FSelEnd; + p2 := FSelStart; + Dec(p2.X); + end; + + if LineLength(p1.Y - 1) < p1.X then + begin + Inc(p1.Y); + p1.X := 1; + end; + if LineLength(p2.Y - 1) < p2.X then + p2.X := LineLength(p2.Y - 1); + + i := GetPlainTextPos(p1); + Result := Copy(FText.Text, i, GetPlainTextPos(p2) - i + 1); +end; + +procedure TfqbSyntaxMemo.SetSelText(Value: String); +var + p1, p2, p3: TPoint; + i: Integer; + s: String; +begin + if FReadOnly then exit; + AddUndo; + if FSelStart.X = 0 then + begin + p1 := FPos; + p2 := p1; + Dec(p2.X); + end + else if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + p1 := FSelStart; + p2 := FSelEnd; + Dec(p2.X); + end + else + begin + p1 := FSelEnd; + p2 := FSelStart; + Dec(p2.X); + end; + + if LineLength(p1.Y - 1) < p1.X then + FText[p1.Y - 1] := FText[p1.Y - 1] + Pad(p1.X - LineLength(p1.Y - 1) + 1); + if LineLength(p2.Y - 1) < p2.X then + p2.X := LineLength(p2.Y - 1); + + i := GetPlainTextPos(p1); + s := FText.Text; + Delete(s, i, GetPlainTextPos(p2) - i + 1); + Insert(Value, s, i); + FText.Text := s; + p3 := GetPosPlainText(i + Length(Value)); + + CorrectBookmark(FPos.Y, p3.y-FPos.Y); + + SetPos(p3.X, p3.Y); + FSelStart.X := 0; + DoChange; + UpdateSyntax; +end; + +procedure TfqbSyntaxMemo.ClearSel; +begin + if FSelStart.X <> 0 then + begin + FSelStart := Point(0, 0); + Repaint; + end; +end; + +procedure TfqbSyntaxMemo.AddSel; +begin + if FSelStart.X = 0 then + FSelStart := FTempPos; + FSelEnd := FPos; + Repaint; +end; + +procedure TfqbSyntaxMemo.SetPos(x, y: Integer); +begin + if FMessage <> '' then + begin + FMessage := ''; + Repaint; + end; + + if x > FMaxLength then x := FMaxLength; + if x < 1 then x := 1; + if y > FText.Count then y := FText.Count; + if y < 1 then y := 1; + + FPos := Point(x, y); + if (FWindowSize.X = 0) or (FWindowSize.Y = 0) then exit; + + if FOffset.Y >= FText.Count then + FOffset.Y := FText.Count - 1; + + if FPos.X > FOffset.X + FWindowSize.X then + begin + Inc(FOffset.X, FPos.X - (FOffset.X + FWindowSize.X)); + Repaint; + end + else if FPos.X <= FOffset.X then + begin + Dec(FOffset.X, FOffset.X - FPos.X + 1); + Repaint; + end + else if FPos.Y > FOffset.Y + FWindowSize.Y then + begin + Inc(FOffset.Y, FPos.Y - (FOffset.Y + FWindowSize.Y)); + Repaint; + end + else if FPos.Y <= FOffset.Y then + begin + Dec(FOffset.Y, FOffset.Y - FPos.Y + 1); + Repaint; + end; + + ShowCaretPos; + UpdateScrollBar; + +end; + +procedure TfqbSyntaxMemo.ScrollClick(Sender: TObject); +begin + if FUpdating then exit; + FOffset.Y := FVScroll.Position; + if FOffset.Y > FText.Count then + FOffset.Y := FText.Count; + ShowCaretPos; + Repaint; +end; + +procedure TfqbSyntaxMemo.ScrollEnter(Sender: TObject); +begin + SetFocus; +end; + +procedure TfqbSyntaxMemo.DblClick; +var + s: String; +begin + FDoubleClicked := True; + DoCtrlL; + FSelStart := FPos; + s := LineAt(FPos.Y - 1); + if s <> '' then + while s[FPos.X] in WordChars do + Inc(FPos.X); + FSelEnd := FPos; + Repaint; +end; + +procedure TfqbSyntaxMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + if FDoubleClicked then + begin + FDoubleClicked := False; + Exit; + end; + if (Button = mbRight) and (PopupMenu = nil) then +{$IFDEF Delphi4} + FPopUpMenu.Popup(Mouse.CursorPos.x, Mouse.CursorPos.y) +{$ENDIF} + else + begin + FMoved := True; + if not Focused then + SetFocus; + FDown := True; + SetPos((X - FGutterWidth) div FCharWidth + 1 + FOffset.X, + Y div FCharHeight + 1 + FOffset.Y); + ClearSel; + end; +end; + +procedure TfqbSyntaxMemo.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + if FDown then + begin + FTempPos := FPos; + FPos.X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; + FPos.Y := Y div FCharHeight + 1 + FOffset.Y; + if (FPos.X <> FTempPos.X) or (FPos.Y <> FTempPos.Y) then + begin + SetPos(FPos.X, FPos.Y); + AddSel; + end; + end; +end; + +procedure TfqbSyntaxMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + FDown := False; +end; + +procedure TfqbSyntaxMemo.KeyDown(var Key: Word; Shift: TShiftState); +var + MyKey: Boolean; +begin + inherited; + FAllowLinesChange := False; + + FTempPos := FPos; + MyKey := True; + case Key of + vk_Left: + if ssCtrl in Shift then + DoCtrlL else + DoLeft; + + vk_Right: + if ssCtrl in Shift then + DoCtrlR else + DoRight; + + vk_Up: + DoUp; + + vk_Down: + DoDown; + + vk_Home: + DoHome(ssCtrl in Shift); + + vk_End: + DoEnd(ssCtrl in Shift); + + vk_Prior: + DoPgUp; + + vk_Next: + DoPgDn; + + vk_Return: + if Shift = [] then + DoReturn; + + vk_Delete: + if ssShift in Shift then + CutToClipboard else + DoDel; + + vk_Back: + DoBackspace; + + vk_Insert: + if ssCtrl in Shift then + CopyToClipboard + else if ssShift in Shift then + PasteFromClipboard; + + vk_Tab: + TabIndent; + + vk_F3: + Find(LastSearch); // F3 Repeat search + + else + MyKey := False; + end; + + if Shift = [ssCtrl] then + if Key = 65 then // Ctrl+A Select all + begin + SetPos(0, 0); + FSelStart := FPos; + SetPos(LineLength(FText.Count - 1) + 1, FText.Count); + FSelEnd := FPos; + Repaint; + end + else + if Key = 70 then // Ctrl+F Search + begin + fqbSynMemoSearch := TfqbSynMemoSearch.Create(nil); + if fqbSynMemoSearch.ShowModal = mrOk then + Find(fqbSynMemoSearch.Edit1.Text); + LastSearch := fqbSynMemoSearch.Edit1.Text; + fqbSynMemoSearch.Free; + end + else + if Key = 89 then // Ctrl+Y Delete line + begin + if FText.Count > FPos.Y then + begin + FMoved := True; + AddUndo; + FText.Delete(FPos.Y - 1); + CorrectBookmark(FPos.Y, -1); + UpdateSyntax; + end + else + if FText.Count = FPos.Y then + begin + FMoved := True; + AddUndo; + FText[FPos.Y - 1] := ''; + FPos.X := 1; + SetPos(FPos.X, FPos.Y); + UpdateSyntax; + end + end + else + if Key in [48..57] then + GotoBookmark(Key-48); + + if Shift = [ssCtrl, ssShift] then + if Key in [48..57] then + if IsBookmark(FPos.Y - 1) < 0 then + AddBookmark(FPos.Y - 1, Key-48) + else + if IsBookmark(FPos.Y - 1) = (Key-48) then + DeleteBookmark(Key-48); + + + if Key in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Home, vk_End, vk_Prior, vk_Next] then + begin + FMoved := True; + if ssShift in Shift then + AddSel else + ClearSel; + end + else if Key in [vk_Return, vk_Delete, vk_Back, vk_Insert, vk_Tab] then + FMoved := True; + + if MyKey then + Key := 0; +end; + +procedure TfqbSyntaxMemo.KeyPress(var Key: Char); +var + MyKey: Boolean; +begin + inherited; + + MyKey := True; + case Key of + #3: + CopyToClipboard; + + #9: + DoCtrlI; + + #21: + DoCtrlU; + + #22: + PasteFromClipboard; + + #24: + CutToClipboard; + + #26: + Undo; + + #32..#255: + begin + DoChar(Key); + FMoved := True; + end; + else + MyKey := False; + end; + + if MyKey then + Key := #0; +end; + +procedure TfqbSyntaxMemo.DoLeft; +begin + Dec(FPos.X); + if FPos.X < 1 then + FPos.X := 1; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoRight; +begin + Inc(FPos.X); + if FPos.X > FMaxLength then + FPos.X := FMaxLength; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoUp; +begin + Dec(FPos.Y); + if FPos.Y < 1 then + FPos.Y := 1; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoDown; +begin + Inc(FPos.Y); + if FPos.Y > FText.Count then + FPos.Y := FText.Count; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoHome(Ctrl: Boolean); +begin + if Ctrl then + SetPos(1, 1) else + SetPos(1, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoEnd(Ctrl: Boolean); +begin + if Ctrl then + SetPos(LineLength(FText.Count - 1) + 1, FText.Count) else + SetPos(LineLength(FPos.Y - 1) + 1, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoPgUp; +begin + if FOffset.Y > FWindowSize.Y then + begin + Dec(FOffset.Y, FWindowSize.Y - 1); + Dec(FPos.Y, FWindowSize.Y - 1); + end + else + begin + if FOffset.Y > 0 then + begin + Dec(FPos.Y, FOffset.Y); + FOffset.Y := 0; + end + else + FPos.Y := 1; + end; + SetPos(FPos.X, FPos.Y); + Repaint; +end; + +procedure TfqbSyntaxMemo.DoPgDn; +begin + if FOffset.Y + FWindowSize.Y < FText.Count then + begin + Inc(FOffset.Y, FWindowSize.Y - 1); + Inc(FPos.Y, FWindowSize.Y - 1); + end + else + begin + FOffset.Y := FText.Count; + FPos.Y := FText.Count; + end; + SetPos(FPos.X, FPos.Y); + Repaint; +end; + +procedure TfqbSyntaxMemo.DoReturn; +var + s: String; +begin + if FReadOnly then exit; + s := LineAt(FPos.Y - 1); + FText[FPos.Y - 1] := Copy(s, 1, FPos.X - 1); + FText.Insert(FPos.Y, Copy(s, FPos.X, FMaxLength)); + EnterIndent; +end; + +procedure TfqbSyntaxMemo.DoDel; +var + s: String; +begin + if FReadOnly then exit; + FMessage := ''; + if FSelStart.X <> 0 then + SelText := '' + else + begin + s := FText[FPos.Y - 1]; + AddUndo; + if FPos.X <= LineLength(FPos.Y - 1) then + begin + Delete(s, FPos.X, 1); + FText[FPos.Y - 1] := s; + end + else if FPos.Y < FText.Count then + begin + s := s + Pad(FPos.X - Length(s) - 1) + LineAt(FPos.Y); + FText[FPos.Y - 1] := s; + FText.Delete(FPos.Y); + CorrectBookmark(FSelStart.Y, -1); + end; + UpdateScrollBar; + UpdateSyntax; + DoChange; + end; +end; + +procedure TfqbSyntaxMemo.DoBackspace; +var + s: String; +begin + if FReadOnly then exit; + FMessage := ''; + if FSelStart.X <> 0 then + SelText := '' + else + begin + s := FText[FPos.Y - 1]; + if FPos.X > 1 then + begin + if (GetLineBegin(FPos.Y - 1) = FPos.X) or (Trim(s) = '') then + UnIndent + else + begin + AddUndo; + if Trim(s) <> '' then + begin + Delete(s, FPos.X - 1, 1); + FText[FPos.Y - 1] := s; + DoLeft; + end + else + DoHome(False); + UpdateSyntax; + DoChange; + end; + end + else if FPos.Y > 1 then + begin + AddUndo; + CorrectBookmark(FPos.Y, -1); + s := LineAt(FPos.Y - 2); + FText[FPos.Y - 2] := s + FText[FPos.Y - 1]; + FText.Delete(FPos.Y - 1); + SetPos(Length(s) + 1, FPos.Y - 1); + UpdateSyntax; + DoChange; + end; + end; +end; + +procedure TfqbSyntaxMemo.DoCtrlI; +begin + if FSelStart.X <> 0 then + ShiftSelected(True); +end; + +procedure TfqbSyntaxMemo.DoCtrlU; +begin + if FSelStart.X <> 0 then + ShiftSelected(False); +end; + +procedure TfqbSyntaxMemo.DoCtrlL; +var + i: Integer; + s: String; +begin + s := FText.Text; + i := Length(LineAt(FPos.Y - 1)); + if FPos.X > i then + FPos.X := i; + + i := GetPlainTextPos(FPos); + + Dec(i); + while (i > 0) and not (s[i] in WordChars) do + if s[i] = #13 then + break else + Dec(i); + while (i > 0) and (s[i] in WordChars) do + Dec(i); + Inc(i); + + FPos := GetPosPlainText(i); + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoCtrlR; +var + i: Integer; + s: String; +begin + s := FText.Text; + i := Length(LineAt(FPos.Y - 1)); + if FPos.X > i then + begin + DoDown; + DoHome(False); + FPos.X := 0; + end; + + i := GetPlainTextPos(FPos); + + while (i < Length(s)) and (s[i] in WordChars) do + Inc(i); + while (i < Length(s)) and not (s[i] in WordChars) do + if s[i] = #13 then + break else + Inc(i); + + FPos := GetPosPlainText(i); + SetPos(FPos.X, FPos.Y); +end; + +procedure TfqbSyntaxMemo.DoChar(Ch: Char); +begin + SelText := Ch; +end; + +function TfqbSyntaxMemo.GetCharAttr(Pos: TPoint): TCharAttributes; + + function IsBlock: Boolean; + var + p1, p2, p3: Integer; + begin + Result := False; + if FSelStart.X = 0 then exit; + + p1 := FSelStart.X + FSelStart.Y * FMaxLength; + p2 := FSelEnd.X + FSelEnd.Y * FMaxLength; + if p1 > p2 then + begin + p3 := p1; + p1 := p2; + p2 := p3; + end; + p3 := Pos.X + Pos.Y * FMaxLength; + Result := (p3 >= p1) and (p3 < p2); + end; + + function CharAttr: TCharAttr; + var + s: String; + begin + if Pos.Y - 1 < FSynStrings.Count then + begin + s := FSynStrings[Pos.Y - 1]; + if Pos.X <= Length(s) then + Result := TCharAttr(Ord(s[Pos.X])) else + Result := caText; + end + else + Result := caText; + end; + +begin + Result := [CharAttr]; + if IsBlock then + Result := Result + [caBlock]; +end; + +procedure TfqbSyntaxMemo.Paint; +var + i, j, j1: Integer; + a, a1: TCharAttributes; + s: String; + + procedure SetAttr(a: TCharAttributes); + begin + with Canvas do + begin + Brush.Color := Color; + + if caText in a then + Font.Assign(FTextAttr); + + if caComment in a then + Font.Assign(FCommentAttr); + + if caKeyword in a then + Font.Assign(FKeywordAttr); + + if caString in a then + Font.Assign(FStringAttr); + + if caBlock in a then + begin + Brush.Color := FBlockColor; + Font.Color := FBlockFontColor; + end; + + Font.Charset := Self.Font.Charset; + end; + end; + + procedure MyTextOut(x, y: Integer; const s: String); + var + i: Integer; + begin + if FIsMonoType then + Canvas.TextOut(x, y, s) + else + with Canvas do + begin + FillRect(Rect(x, y, x + Length(s) * FCharWidth, y + FCharHeight)); + for i := 1 to Length(s) do + TextOut(x + (i - 1) * FCharWidth, y, s[i]); + MoveTo(x + Length(s) * FCharWidth, y); + end; + end; + +begin + with Canvas do + begin + Brush.Color := clBtnFace; + FillRect(Rect(0, 0, FGutterWidth - 2, Height - FFooterHeight)); + FillRect(Rect(0, Height - FFooterHeight, Width, Height)); + Pen.Color := clBtnHighlight; + MoveTo(FGutterWidth - 4, 0); + LineTo(FGutterWidth - 4, Height - FFooterHeight + 1); + if FFooterHeight > 0 then + LineTo(Width, Height - FFooterHeight + 1); + + if FUpdatingSyntax then Exit; + + for i := FOffset.Y to FOffset.Y + FWindowSize.Y - 1 do + begin + if i >= FText.Count then break; + + s := FText[i]; + PenPos := Point(FGutterWidth, (i - FOffset.Y) * FCharHeight); + j1 := FOffset.X + 1; + a := GetCharAttr(Point(j1, i + 1)); + a1 := a; + + for j := j1 to FOffset.X + FWindowSize.X do + begin + if j > Length(s) then break; + + a1 := GetCharAttr(Point(j, i + 1)); + if a1 <> a then + begin + SetAttr(a); + MyTextOut(PenPos.X, PenPos.Y, Copy(FText[i], j1, j - j1)); + a := a1; + j1 := j; + end; + end; + + SetAttr(a); + MyTextOut(PenPos.X, PenPos.Y, Copy(s, j1, FMaxLength)); + if caBlock in GetCharAttr(Point(1, i + 1)) then + MyTextOut(PenPos.X, PenPos.Y, Pad(FWindowSize.X - Length(s) - FOffset.X + 3)); + + BookmarkDraw(PenPos.Y, i); + ActiveLineDraw(PenPos.Y, i); + end; + + if FMessage <> '' then + begin + Font.Name := 'Tahoma'; + Font.Color := clWhite; + Font.Style := [fsBold]; + Font.Size := 8; + Brush.Color := clMaroon; + FillRect(Rect(0, Height - TextHeight('|') - 6, Width, Height)); + TextOut(6, Height - TextHeight('|') - 5, FMessage); + end + else + ShowPos; + end; +end; + +procedure TfqbSyntaxMemo.CreateSynArray; +var + i, n, Pos: Integer; + ch: Char; + FSyn: String; + + procedure SkipSpaces; + begin + while (Pos <= Length(FSyn)) and + ((FSyn[Pos] in [#1..#32]) or + not (FSyn[Pos] in ['_', 'A'..'Z', 'a'..'z', '''', '"', '/', '{', '(', '-'])) do + Inc(Pos); + end; + + function IsKeyWord(const s: String): Boolean; + begin + Result := False; + if FKeywords = '' then exit; + + if FKeywords[1] <> ',' then + FKeywords := ',' + FKeywords; + if FKeywords[Length(FKeywords)] <> ',' then + FKeywords := FKeywords + ','; + + Result := System.Pos(',' + AnsiLowerCase(s) + ',', FKeywords) <> 0; + end; + + function GetIdent: TCharAttr; + var + i: Integer; + cm1, cm2, cm3, cm4, st1: Char; + begin + i := Pos; + Result := caText; + + if FSyntaxType = stPascal then + begin + cm1 := '/'; + cm2 := '{'; + cm3 := '('; + cm4 := ')'; + st1 := ''''; + end + else if FSyntaxType = stCpp then + begin + cm1 := '/'; + cm2 := ' '; + cm3 := '/'; + cm4 := '/'; + st1 := '"'; + end + else if FSyntaxType = stSQL then + begin + cm1 := '-'; + cm2 := ' '; + cm3 := '/'; + cm4 := '/'; + st1 := '"'; + end + else + begin + cm1 := ' '; + cm2 := ' '; + cm3 := ' '; + cm4 := ' '; + st1 := ' '; + end; + + if FSyn[Pos] in ['_', 'A'..'Z', 'a'..'z'] then + begin + while FSyn[Pos] in ['_', 'A'..'Z', 'a'..'z', '0'..'9'] do + Inc(Pos); + if IsKeyWord(Copy(FSyn, i, Pos - i)) then + Result := caKeyword; + Dec(Pos); + end + else if (FSyn[Pos] = cm1) and (FSyn[Pos + 1] = cm1) then + begin + while (Pos <= Length(FSyn)) and not (FSyn[Pos] in [#10, #13]) do + Inc(Pos); + Result := caComment; + end + else if FSyn[Pos] = cm2 then + begin + while (Pos <= Length(FSyn)) and (FSyn[Pos] <> '}') do + Inc(Pos); + Result := caComment; + end + else if (FSyn[Pos] = cm3) and (FSyn[Pos + 1] = '*') then + begin + while (Pos < Length(FSyn)) and not ((FSyn[Pos] = '*') and (FSyn[Pos + 1] = cm4)) do + Inc(Pos); + Inc(Pos, 2); + Result := caComment; + end + else if FSyn[Pos] = st1 then + begin + Inc(Pos); + while (Pos < Length(FSyn)) and (FSyn[Pos] <> st1) and not (FSyn[Pos] in [#10, #13]) do + Inc(Pos); + Result := caString; + end; + Inc(Pos); + end; + +begin + FSyn := FText.Text + #0#0#0#0#0#0#0#0#0#0#0; + FAllowLinesChange := False; + Pos := 1; + + while Pos < Length(FSyn) do + begin + n := Pos; + SkipSpaces; + for i := n to Pos - 1 do + if FSyn[i] > #31 then + FSyn[i] := Chr(Ord(caText)); + + n := Pos; + ch := Chr(Ord(GetIdent)); + for i := n to Pos - 1 do + if FSyn[i] > #31 then + FSyn[i] := ch; + end; + + FUpdatingSyntax := True; + FSynStrings.Text := FSyn; + FSynStrings.Add(' '); + FUpdatingSyntax := False; +end; + +procedure TfqbSyntaxMemo.UpdateView; +begin + UpdateSyntax; + Invalidate; +end; + +procedure TfqbSyntaxMemo.CopyPopup(Sender: TObject); +begin + CopyToClipboard; +end; + +procedure TfqbSyntaxMemo.PastePopup(Sender: TObject); +begin + PasteFromClipboard; +end; + +procedure TfqbSyntaxMemo.CutPopup(Sender: TObject); +begin + CutToClipboard; +end; + +{$IFDEF Delphi4} +procedure TfqbSyntaxMemo.MouseWheelUp(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + FVScroll.Position := FVScroll.Position - FVScroll.SmallChange * KWheel; +end; + +procedure TfqbSyntaxMemo.MouseWheelDown(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + FVScroll.Position := FVScroll.Position + FVScroll.SmallChange * KWheel; +end; +{$ENDIF} + +procedure TfqbSyntaxMemo.SetShowGutter(Value: boolean); +begin + FShowGutter := Value; + if Value then + FGutterWidth := 20 + else + FGutterWidth := 0; + Repaint; +end; + +procedure TfqbSyntaxMemo.SetShowFooter(Value: boolean); +begin + FShowFooter := Value; + if Value then + FFooterHeight := 20 + else + FFooterHeight := 0; + Repaint; +end; + +function TfqbSyntaxMemo.FMemoFind(Text: String; var Position : TPoint): boolean; +var + i, j : integer; +begin + j := 0; + result := False; + if FText.Count > 1 then + begin + Text := UpperCase(Text); + for i := Position.Y to FText.Count - 1 do + begin + j := Pos( Text, UpperCase(FText[i])); + if j > 0 then + begin + Result := True; + break; + end + end; + Position.X := j; + Position.Y := i + 1; + end; +end; + +function TfqbSyntaxMemo.Find(Text: String): boolean; +var + Position: TPoint; +begin + Position := FPos; + if FMemoFind(Text, Position) then + begin + SetPos(Position.X, Position.Y); + result := true; + end + else + begin + ShowMessage('Text "'+Text+'" not found.'); + result := false; + end; +end; + +procedure TfqbSyntaxMemo.ActiveLineDraw(Y : integer; line : integer); +begin + if ShowGutter then + with Canvas do + if line = FActiveLine then + begin + Brush.Color := clRed; + Pen.Color := clBlack; + Ellipse(4, Y+4, 11, Y+11); + end; +end; + +procedure TfqbSyntaxMemo.BookmarkDraw(Y : integer; line : integer); +var + bm : integer; +begin + if ShowGutter then + with Canvas do + begin + bm := IsBookmark(Line); + if bm >= 0 then + begin + Brush.Color := clBlack; + FillRect(Rect(3, Y + 1, 13, Y + 12)); + Brush.Color := clGreen; + FillRect(Rect(2, Y + 2, 12, Y + 13)); + Font.Name := 'Tahoma'; + Font.Color := clWhite; + Font.Style := [fsBold]; + Font.Size := 7; + TextOut(4, Y + 2, IntToStr(bm)); + end + else + begin + Brush.Color := clBtnFace; + FillRect(Rect(2, Y + 2, 13, Y + 13)); + end; + end; +end; + +function TfqbSyntaxMemo.IsBookmark(Line : integer): integer; +var + Pos : integer; +begin + Result := -1; +{$IFDEF Delphi4} + for Pos := 0 to Length(Bookmarks) - 1 do +{$ELSE} + for Pos := 0 to 9 do +{$ENDIF} + if Bookmarks[Pos] = Line then + begin + Result := Pos; + break; + end; +end; + +procedure TfqbSyntaxMemo.AddBookmark(Line, Number : integer); +begin +{$IFDEF Delphi4} + if Number < Length(Bookmarks) then +{$ELSE} + if Number < 10 then +{$ENDIF} + begin + Bookmarks[Number] := Line; + Repaint; + end; +end; + +procedure TfqbSyntaxMemo.DeleteBookmark(Number : integer); +begin +{$IFDEF Delphi4} + if Number < Length(Bookmarks) then +{$ELSE} + if Number < 10 then +{$ENDIF} + begin + Bookmarks[Number] := -1; + Repaint; + end; +end; + +procedure TfqbSyntaxMemo.CorrectBookmark(Line : integer; delta : integer); +var + i : integer; +begin +{$IFDEF Delphi4} + for i := 0 to Length(Bookmarks) - 1 do +{$ELSE} + for i := 0 to 9 do +{$ENDIF} + if Bookmarks[i] >= Line then + Inc(Bookmarks[i], Delta); +end; + +procedure TfqbSyntaxMemo.GotoBookmark(Number : integer); +begin +{$IFDEF Delphi4} + if Number < Length(Bookmarks) then +{$ELSE} + if Number < 10 then +{$ENDIF} + if Bookmarks[Number] >= 0 then + SetPos(0, Bookmarks[Number] + 1); +end; + +procedure TfqbSyntaxMemo.DOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); +begin + Accept := Source is TTreeView; +end; + +procedure TfqbSyntaxMemo.DDrop(Sender, Source: TObject; X, Y: Integer); +begin + if Source is TTreeView then + begin + SetPos((X - FGutterWidth) div FCharWidth + 1 + FOffset.X, + Y div FCharHeight + 1 + FOffset.Y); + SetSelText(TTreeView(Source).Selected.Text); + end; +end; + +procedure TfqbSyntaxMemo.SetKeywordAttr(Value: TFont); +begin + FKeywordAttr.Assign(Value); + UpdateSyntax; +end; + +procedure TfqbSyntaxMemo.SetStringAttr(Value: TFont); +begin + FStringAttr.Assign(Value); + UpdateSyntax; +end; + +procedure TfqbSyntaxMemo.SetTextAttr(Value: TFont); +begin + FTextAttr.Assign(Value); + UpdateSyntax; +end; + +procedure TfqbSyntaxMemo.SetCommentAttr(Value: TFont); +begin + FCommentAttr.Assign(Value); + UpdateSyntax; +end; + +procedure TfqbSyntaxMemo.SetActiveLine(Line : Integer); +begin + FActiveLine := Line; + Repaint; +end; + +function TfqbSyntaxMemo.GetActiveLine: Integer; +begin + Result := FActiveLine; +end; + +// + +procedure TfqbSynMemoSearch.FormKeyPress(Sender: TObject; var Key: Char); +begin + if Key = #13 then + ModalResult := mrOk; +end; + +end. + diff --git a/official/4.8.11/FastQB/fqbUtils.pas b/official/4.8.11/FastQB/fqbUtils.pas new file mode 100644 index 0000000..1602fa6 --- /dev/null +++ b/official/4.8.11/FastQB/fqbUtils.pas @@ -0,0 +1,346 @@ +{*******************************************} +{ } +{ FastQueryBuilder 1.03 } +{ } +{ Copyright (c) 2005 } +{ Fast Reports Inc. } +{ } +{*******************************************} + +{$I fqb.inc} + +unit fqbUtils; + +interface + +uses Windows, Messages, Classes, SysUtils, fqbZLib; + +function fqbStringCRC32(const Str: Ansistring): Cardinal; +function fqbGetUniqueFileName(const Prefix: String): string; +function fqbTrim(const Input: string; EArray: TSysCharSet):string; +function fqbParse(Char, S: string; Count: Integer; Last: Boolean = False): string; +function fqbBase64Decode(const S: AnsiString): AnsiString; +function fqbBase64Encode(const S: AnsiString): AnsiString; +function fqbCompress(const S: String): String; +function fqbDeCompress(const S: String): String; +procedure fqbDeflateStream(Source, Dest: TStream; Compression: TZCompressionLevel = zcDefault); +procedure fqbInflateStream(Source, Dest: TStream); + + +implementation + +const + Base64Charset = AnsiString('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'); + + CRCTable: array [0..255] of Cardinal = ( + 0000000000, 1996959894, 3993919788, 2567524794, + 0124634137, 1886057615, 3915621685, 2657392035, + 0249268274, 2044508324, 3772115230, 2547177864, + 0162941995, 2125561021, 3887607047, 2428444049, + 0498536548, 1789927666, 4089016648, 2227061214, + 0450548861, 1843258603, 4107580753, 2211677639, + 0325883990, 1684777152, 4251122042, 2321926636, + 0335633487, 1661365465, 4195302755, 2366115317, + 0997073096, 1281953886, 3579855332, 2724688242, + 1006888145, 1258607687, 3524101629, 2768942443, + 0901097722, 1119000684, 3686517206, 2898065728, + 0853044451, 1172266101, 3705015759, 2882616665, + 0651767980, 1373503546, 3369554304, 3218104598, + 0565507253, 1454621731, 3485111705, 3099436303, + 0671266974, 1594198024, 3322730930, 2970347812, + 0795835527, 1483230225, 3244367275, 3060149565, + 1994146192, 0031158534, 2563907772, 4023717930, + 1907459465, 0112637215, 2680153253, 3904427059, + 2013776290, 0251722036, 2517215374, 3775830040, + 2137656763, 0141376813, 2439277719, 3865271297, + 1802195444, 0476864866, 2238001368, 4066508878, + 1812370925, 0453092731, 2181625025, 4111451223, + 1706088902, 0314042704, 2344532202, 4240017532, + 1658658271, 0366619977, 2362670323, 4224994405, + 1303535960, 0984961486, 2747007092, 3569037538, + 1256170817, 1037604311, 2765210733, 3554079995, + 1131014506, 0879679996, 2909243462, 3663771856, + 1141124467, 0855842277, 2852801631, 3708648649, + 1342533948, 0654459306, 3188396048, 3373015174, + 1466479909, 0544179635, 3110523913, 3462522015, + 1591671054, 0702138776, 2966460450, 3352799412, + 1504918807, 0783551873, 3082640443, 3233442989, + 3988292384, 2596254646, 0062317068, 1957810842, + 3939845945, 2647816111, 0081470997, 1943803523, + 3814918930, 2489596804, 0225274430, 2053790376, + 3826175755, 2466906013, 0167816743, 2097651377, + 4027552580, 2265490386, 0503444072, 1762050814, + 4150417245, 2154129355, 0426522225, 1852507879, + 4275313526, 2312317920, 0282753626, 1742555852, + 4189708143, 2394877945, 0397917763, 1622183637, + 3604390888, 2714866558, 0953729732, 1340076626, + 3518719985, 2797360999, 1068828381, 1219638859, + 3624741850, 2936675148, 0906185462, 1090812512, + 3747672003, 2825379669, 0829329135, 1181335161, + 3412177804, 3160834842, 0628085408, 1382605366, + 3423369109, 3138078467, 0570562233, 1426400815, + 3317316542, 2998733608, 0733239954, 1555261956, + 3268935591, 3050360625, 0752459403, 1541320221, + 2607071920, 3965973030, 1969922972, 0040735498, + 2617837225, 3943577151, 1913087877, 0083908371, + 2512341634, 3803740692, 2075208622, 0213261112, + 2463272603, 3855990285, 2094854071, 0198958881, + 2262029012, 4057260610, 1759359992, 0534414190, + 2176718541, 4139329115, 1873836001, 0414664567, + 2282248934, 4279200368, 1711684554, 0285281116, + 2405801727, 4167216745, 1634467795, 0376229701, + 2685067896, 3608007406, 1308918612, 0956543938, + 2808555105, 3495958263, 1231636301, 1047427035, + 2932959818, 3654703836, 1088359270, 0936918000, + 2847714899, 3736837829, 1202900863, 0817233897, + 3183342108, 3401237130, 1404277552, 0615818150, + 3134207493, 3453421203, 1423857449, 0601450431, + 3009837614, 3294710456, 1567103746, 0711928724, + 3020668471, 3272380065, 1510334235, 0755167117); + + +function fqbStringCRC32(const Str: Ansistring): Cardinal; + var + i: Integer; + b: Byte; + c: Cardinal; +begin + c := $ffffffff; + for i := 1 to Length(Str) do + begin + b := Byte(Str[i]); + c := CrcTable[(c xor Cardinal(b)) and $ff] xor (c shr 8) + end; + Result := c xor $ffffffff +end; + +function fqbGetUniqueFileName(const Prefix: String): string; + var +{$IFDEF Delphi12} + TempPath, FileName: WideString; +{$ELSE} + TempPath: array[0..MAX_PATH] of Char; + FileName: String[255]; +{$ENDIF} +begin +{$IFDEF Delphi12} + SetLength(TempPath, 255); + SetLength(FileName, 255); + GetTempPath(255, @TempPath[1]); + GetTempFileName(@TempPath[1], PChar(Prefix), 0, @FileName[1]); + Result := StrPas(PWideChar(@FileName[1])) +{$ELSE} + GetTempPath(SizeOf(TempPath) - 1, TempPath); + GetTempFileName(TempPath, PChar(Prefix), 0, @FileName[1]); + Result := StrPas(@FileName[1]) +{$ENDIF} +end; + +function fqbTrim(const Input: string; EArray: TSysCharSet):string; + var + tmp: string; +begin + Result := ''; + tmp := Input; + while Length(tmp) <> 0 do + if tmp[1] in EArray then + Delete(tmp, 1, 1) + else + begin + Result := Result + tmp[1]; + Delete(tmp, 1, 1) + end; + repeat + if Pos(' ', Result) > 0 then + Delete(Result, Pos(' ', Result) + 1, 1) + until Pos(' ', Result) = 0; +end; + +function fqbParse(Char, S: string; Count: Integer; Last: Boolean = False): string; + var + i: Integer; + t: string; +begin + if S[Length(S)] <> Char then + S := S + Char; + for i := 1 to Count do + begin + if Last then + t := Copy(S, 0, Length(S) - 1) + else + t := Copy(S, 0, Pos(Char, S) - 1); + S := Copy(S, Pos(Char, S) + 1, Length(S)) + end; + Result := t +end; + + +function fqbBase64Decode(const S: AnsiString): AnsiString; + var + F, L, M, P: Integer; + B, OutPos: Byte; + OutB: Array[1..3] of Byte; + Lookup: Array[AnsiChar] of Byte; + R: PAnsiChar; +begin + L := Length(S); + P := 0; + while (L - P > 0) and (S[L - P] = '=') do Inc(P); + M := L - P; + if M <> 0 then + begin + SetLength(Result, (M * 3) div 4); + FillChar(Lookup, Sizeof(Lookup), #0); + for F := 0 to 63 do + Lookup[Base64Charset[F + 1]] := F; + R := Pointer(Result); + OutPos := 0; + for F := 1 to L - P do + begin + B := Lookup[S[F]]; + case OutPos of + 0 : OutB[1] := B shl 2; + 1 : begin + OutB[1] := OutB[1] or (B shr 4); + R^ := AnsiChar(OutB[1]); + Inc(R); + OutB[2] := (B shl 4) and $FF + end; + 2 : begin + OutB[2] := OutB[2] or (B shr 2); + R^ := AnsiChar(OutB[2]); + Inc(R); + OutB[3] := (B shl 6) and $FF + end; + 3 : begin + OutB[3] := OutB[3] or B; + R^ := AnsiChar(OutB[3]); + Inc(R) + end + end; + OutPos := (OutPos + 1) mod 4 + end; + if (OutPos > 0) and (P = 0) then + if OutB[OutPos] <> 0 then + Result := Result + AnsiChar(OutB[OutPos]) + end else + Result := '' +end; + +function fqbBase64Encode(const S: AnsiString): AnsiString; + var + R, C : Byte; + F, L, M, N, U : Integer; + P : PAnsiChar; +begin + L := Length(S); + if L > 0 then + begin + M := L mod 3; + N := (L div 3) * 4 + M; + if M > 0 then Inc(N); + U := N mod 4; + if U > 0 then + begin + U := 4 - U; + Inc(N, U) + end; + SetLength(Result, N); + P := Pointer(Result); + R := 0; + for F := 0 to L - 1 do + begin + C := Byte(S [F + 1]); + case F mod 3 of + 0 : begin + P^ := Base64Charset[C shr 2 + 1]; + Inc(P); + R := (C and 3) shl 4 + end; + 1 : begin + P^ := Base64Charset[C shr 4 + R + 1]; + Inc(P); + R := (C and $0F) shl 2 + end; + 2 : begin + P^ := Base64Charset[C shr 6 + R + 1]; + Inc(P); + P^ := Base64Charset[C and $3F + 1]; + Inc(P) + end + end + end; + if M > 0 then + begin + P^ := Base64Charset[R + 1]; + Inc(P) + end; + for F := 1 to U do + begin + P^ := '='; + Inc(P) + end; + end else + Result := '' +end; + +function fqbCompress(const S: String): String; + var + st, stres: TStringStream; +begin + st := TStringStream.Create(s); + stres := TStringStream.Create(''); + + fqbDeflateStream(st, stres, zcMax); + Result := fqbBase64Encode(stres.DataString); + + stres.Free; + st.Free +end; + +function fqbDeCompress(const S: String): String; + var + st, stres: TStringStream; +begin + + st := TStringStream.Create(fqbBase64Decode(s)); + stres := TStringStream.Create(AnsiString('')); + + fqbInflateStream(st, stres); + Result := stres.DataString; + + stres.Free; + st.Free +end; + +procedure fqbDeflateStream(Source, Dest: TStream; Compression: TZCompressionLevel = zcDefault); +var + Compressor: TZCompressionStream; +begin + Compressor := TZCompressionStream.Create(Dest, TZCompressionLevel(Compression)); + try + Compressor.CopyFrom(Source, 0) + finally + Compressor.Free + end +end; + +procedure fqbInflateStream(Source, Dest: TStream); +var + FTempStream: TMemoryStream; + UnknownPtr: Pointer; + NewSize: Integer; +begin + FTempStream := TMemoryStream.Create; + try + FTempStream.CopyFrom(Source, 0); + // uncompress data and save it to the Dest + ZDeCompress(FTempStream.Memory, FTempStream.Size, UnknownPtr, NewSize); + Dest.Write(UnknownPtr^, NewSize); + FreeMem(UnknownPtr, NewSize) + finally + FTempStream.Free + end +end; + +end. diff --git a/official/4.8.11/FastQB/fqbZLib.pas b/official/4.8.11/FastQB/fqbZLib.pas new file mode 100644 index 0000000..cf84498 --- /dev/null +++ b/official/4.8.11/FastQB/fqbZLib.pas @@ -0,0 +1,626 @@ +{***************************************************************************** +* ZLibEx.pas (zlib 1.2.1) * +* * +* copyright (c) 2002-2003 Roberto Della Pasqua (www.dellapasqua.com) * +* copyright (c) 2000-2002 base2 technologies (www.base2ti.com) * +* copyright (c) 1997 Borland International (www.borland.com) * +* * +* revision history * +* 2003.12.18 updated with latest zlib 1.2.1 (see www.zlib.org) * +* obj's compiled with fastest speed optimizations (bcc 5.6.4) * +* (hint:see basm newsgroup about a Move RTL fast replacement) * +* Thanks to Cosmin Truta for the pascal zlib reference * +* * +* 2002.11.02 ZSendToBrowser: deflate algorithm for HTTP1.1 compression * +* 2002.10.24 ZFastCompressString and ZFastDecompressString:300% faster * +* 2002.10.15 recompiled zlib 1.1.4 c sources with speed optimizations * +* (and targeting 686+ cpu) and changes to accomodate Borland * +* standards (C++ v5.6 compiler) * +* 2002.10.15 optimized move mem for not aligned structures (strings,etc)* +* 2002.10.15 little changes to avoid system unique string calls * +* * +* 2002.03.15 updated to zlib version 1.1.4 * +* 2001.11.27 enhanced TZDecompressionStream.Read to adjust source * +* stream position upon end of compression data * +* fixed endless loop in TZDecompressionStream.Read when * +* destination count was greater than uncompressed data * +* 2001.10.26 renamed unit to integrate "nicely" with delphi 6 * +* 2000.11.24 added soFromEnd condition to TZDecompressionStream.Seek * +* added ZCompressStream and ZDecompressStream * +* 2000.06.13 optimized, fixed, rewrote, and enhanced the zlib.pas unit * +* included on the delphi cd (zlib version 1.1.3) * +* * +* acknowledgements * +* erik turner Z*Stream routines * +* david bennion finding the nastly little endless loop quirk with the * +* TZDecompressionStream.Read method * +* burak kalayci informing me about the zlib 1.1.4 update * +*****************************************************************************} + +unit fqbZLib; + +interface + +{$I fqb.inc} + +uses + Windows, + Sysutils, + Classes; + +const + ZLIB_VERSION = '1.2.1'; + +type + TZAlloc = function(opaque: Pointer; items, size: Integer): Pointer; + TZFree = procedure(opaque, block: Pointer); + TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); + + {** TZStreamRec ***********************************************************} + + TZStreamRec = packed record + next_in: PByte;//AnsiChar; // next input byte + avail_in: Longint; // number of bytes available at next_in + total_in: Longint; // total nb of input bytes read so far + next_out: PByte;//AnsiChar; // next output byte should be put here + avail_out: Longint; // remaining free space at next_out + total_out: Longint; // total nb of bytes output so far + msg: PByte;//AnsiChar; // last error message, NULL if no error + state: Pointer; // not visible by applications + zalloc: TZAlloc; // used to allocate the internal state + zfree: TZFree; // used to free the internal state + opaque: Pointer; // private data object passed to zalloc and zfree + data_type: Integer; // best guess about the data type: ascii or binary + adler: Longint; // adler32 value of the uncompressed data + reserved: Longint; // reserved for future use + end; + + {** TCustomZStream ********************************************************} + + TCustomZStream = class(TStream) + private + FStream: TStream; + FStreamPos: Integer; + FOnProgress: TNotifyEvent; + FZStream: TZStreamRec; + FBuffer: array[Word] of Byte;//AnsiChar; + protected + constructor Create(stream: TStream); + procedure DoProgress; dynamic; + property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; + end; + + {** TZCompressionStream ***************************************************} + + TZCompressionStream = class(TCustomZStream) + private + function GetCompressionRate: Single; + public + constructor Create(dest: TStream; compressionLevel: TZCompressionLevel = zcDefault); + destructor Destroy; override; + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + property CompressionRate: Single read GetCompressionRate; + property OnProgress; + end; + + {** TZDecompressionStream *************************************************} + + TZDecompressionStream = class(TCustomZStream) + public + constructor Create(source: TStream); + destructor Destroy; override; + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + property OnProgress; + end; + +{** zlib public routines ****************************************************} + +{***************************************************************************** +* ZCompress * +* * +* pre-conditions * +* inBuffer = pointer to uncompressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* level = compression level * +* * +* post-conditions * +* outBuffer = pointer to compressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel = zcDefault); + +{***************************************************************************** +* ZDecompress * +* * +* pre-conditions * +* inBuffer = pointer to compressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* outEstimate = estimated size of uncompressed data (bytes) * +* * +* post-conditions * +* outBuffer = pointer to decompressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer = 0); + +{** utility routines ********************************************************} + +function adler32(adler: LongInt; const buf: PAnsiChar; len: Integer): LongInt; +function crc32(crc: LongInt; const buf: PAnsiChar; len: Integer): LongInt; +function compressBound(sourceLen: LongInt): LongInt; + +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; + recsize: Integer): Integer; forward; +function inflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function inflateEnd(var strm: TZStreamRec): Integer; forward; +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; + recsize: Integer): Integer; forward; +function deflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function deflateEnd(var strm: TZStreamRec): Integer; forward; +{****************************************************************************} + + +type + EZLibError = class(Exception); + EZCompressionError = class(EZLibError); + EZDecompressionError = class(EZLibError); + +implementation + +{** link zlib 1.2.1 **************************************************************} +{** bcc32 flags: -c -6 -O2 -Ve -X- -pr -a8 -b -d -k- -vi -tWM -r -RT- -DFASTEST **} + +{$L adler32.zobj} +{$L compress.zobj} +{$L crc32.zobj} +{$L deflate.zobj} +{$L infback.zobj} +{$L inffast.zobj} +{$L inflate.zobj} +{$L inftrees.zobj} +{$L trees.zobj} + +{***************************************************************************** +* note: do not reorder the above -- doing so will result in external * +* functions being undefined * +*****************************************************************************} + +const + {** flush constants *******************************************************} + + Z_NO_FLUSH = 0; + Z_FINISH = 4; + + {** return codes **********************************************************} + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); + + {** compression levels ****************************************************} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); + + {** compression methods ***************************************************} + + Z_DEFLATED = 8; + + {** return code messages **************************************************} + + _z_errmsg: array[0..9] of PChar = ( + 'need dictionary', // Z_NEED_DICT (2) + 'stream end', // Z_STREAM_END (1) + '', // Z_OK (0) + 'file error', // Z_ERRNO (-1) + 'stream error', // Z_STREAM_ERROR (-2) + 'data error', // Z_DATA_ERROR (-3) + 'insufficient memory', // Z_MEM_ERROR (-4) + 'buffer error', // Z_BUF_ERROR (-5) + 'incompatible version', // Z_VERSION_ERROR (-6) + '' + ); + + ZLevels: array[TZCompressionLevel] of Shortint = ( + Z_NO_COMPRESSION, + Z_BEST_SPEED, + Z_DEFAULT_COMPRESSION, + Z_BEST_COMPRESSION + ); + + SZInvalid = 'Invalid ZStream operation!'; + +{** deflate routines ********************************************************} + +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; + recsize: Integer): Integer; external; + +function deflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function deflateEnd(var strm: TZStreamRec): Integer; external; + +{** inflate routines ********************************************************} + +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; + recsize: Integer): Integer; external; + +function inflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function inflateEnd(var strm: TZStreamRec): Integer; external; + +function inflateReset(var strm: TZStreamRec): Integer; external; + +{** utility routines *******************************************************} + +function adler32; external; +function crc32; external; +function compressBound; external; + +{** zlib function implementations *******************************************} + +function zcalloc(opaque: Pointer; items, size: Integer): Pointer; +begin + GetMem(result, items * size); +end; + +procedure zcfree(opaque, block: Pointer); +begin + FreeMem(block); +end; + +{** c function implementations **********************************************} + +procedure _memset(p: Pointer; b: Byte; count: Integer); cdecl; +begin + FillChar(p^, count, b); +end; + +procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; +begin + Move(source^, dest^, count); +end; + +{** custom zlib routines ****************************************************} + +function DeflateInit(var stream: TZStreamRec; level: Integer): Integer; +begin + result := DeflateInit_(stream, level, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +function InflateInit(var stream: TZStreamRec): Integer; +begin + result := InflateInit_(stream, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +{****************************************************************************} + +function ZCompressCheck(code: Integer): Integer; +begin + result := code; + + if code < 0 then + begin + raise EZCompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +function ZDecompressCheck(code: Integer): Integer; +begin + Result := code; + + if code < 0 then + begin + raise EZDecompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel); +const + delta = 256; +var + zstream: TZStreamRec; +begin + FillChar(zstream, SizeOf(TZStreamRec), 0); + + outSize := ((inSize + (inSize div 10) + 12) + 255) and not 255; + GetMem(outBuffer, outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZCompressCheck(DeflateInit(zstream, ZLevels[level])); + + try + while ZCompressCheck(deflate(zstream, Z_FINISH)) <> Z_STREAM_END do + begin + Inc(outSize, delta); + ReallocMem(outBuffer, outSize); + + zstream.next_out := PByte{AnsiChar}(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZCompressCheck(deflateEnd(zstream)); + end; + + ReallocMem(outBuffer, zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer); +var + zstream: TZStreamRec; + delta: Integer; +begin + FillChar(zstream, SizeOf(TZStreamRec), 0); + + delta := (inSize + 255) and not 255; + + if outEstimate = 0 then outSize := delta + else outSize := outEstimate; + + GetMem(outBuffer, outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZDecompressCheck(InflateInit(zstream)); + + try + while ZDecompressCheck(inflate(zstream, Z_NO_FLUSH)) <> Z_STREAM_END do + begin + Inc(outSize, delta); + ReallocMem(outBuffer, outSize); + + zstream.next_out := PByte{AnsiChar}(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZDecompressCheck(inflateEnd(zstream)); + end; + + ReallocMem(outBuffer, zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +{** TCustomZStream **********************************************************} + +constructor TCustomZStream.Create(stream: TStream); +begin + inherited Create; + FStream := stream; + FStreamPos := stream.Position; +end; + +procedure TCustomZStream.DoProgress; +begin + if Assigned(FOnProgress) then FOnProgress(Self); +end; + +{** TZCompressionStream *****************************************************} + +constructor TZCompressionStream.Create(dest: TStream; + compressionLevel: TZCompressionLevel); +begin + inherited Create(dest); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + ZCompressCheck(DeflateInit(FZStream, ZLevels[compressionLevel])); +end; + +destructor TZCompressionStream.Destroy; +begin + FZStream.next_in := nil; + FZStream.avail_in := 0; + + try + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while ZCompressCheck(deflate(FZStream, Z_FINISH)) <> Z_STREAM_END do + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer) - FZStream.avail_out); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + end; + + if FZStream.avail_out < SizeOf(FBuffer) then + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer) - FZStream.avail_out); + end; + finally + deflateEnd(FZStream); + end; + + inherited Destroy; +end; + +function TZCompressionStream.Read(var buffer; count: Longint): Longint; +begin + raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.Write(const buffer; count: Longint): Longint; +begin + FZStream.next_in := @buffer; + FZStream.avail_in := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while FZStream.avail_in > 0 do + begin + ZCompressCheck(deflate(FZStream, Z_NO_FLUSH)); + + if FZStream.avail_out = 0 then + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer)); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + FStreamPos := FStream.Position; + + DoProgress; + end; + end; + + result := Count; +end; + +function TZCompressionStream.Seek(offset: Longint; origin: Word): Longint; +begin + if (offset = 0) and (origin = soFromCurrent) then + begin + result := FZStream.total_in; + end + else raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.GetCompressionRate: Single; +begin + if FZStream.total_in = 0 then result := 0 + else result := (1.0 - (FZStream.total_out / FZStream.total_in)) * 100.0; +end; + +{** TZDecompressionStream ***************************************************} + +constructor TZDecompressionStream.Create(source: TStream); +begin + inherited Create(source); + FZStream.next_in := @FBuffer; + FZStream.avail_in := 0; + ZDecompressCheck(InflateInit(FZStream)); +end; + +destructor TZDecompressionStream.Destroy; +begin + inflateEnd(FZStream); + inherited Destroy; +end; + +function TZDecompressionStream.Read(var buffer; count: Longint): Longint; +var + zresult: Integer; +begin + FZStream.next_out := @buffer; + FZStream.avail_out := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + zresult := Z_OK; + + while (FZStream.avail_out > 0) and (zresult <> Z_STREAM_END) do + begin + if FZStream.avail_in = 0 then + begin + FZStream.avail_in := FStream.Read(FBuffer, SizeOf(FBuffer)); + + if FZStream.avail_in = 0 then + begin + result := count - FZStream.avail_out; + + Exit; + end; + + FZStream.next_in := @FBuffer; + FStreamPos := FStream.Position; + + DoProgress; + end; + + zresult := ZDecompressCheck(inflate(FZStream, Z_NO_FLUSH)); + end; + + if (zresult = Z_STREAM_END) and (FZStream.avail_in > 0) then + begin + FStream.Position := FStream.Position - FZStream.avail_in; + FStreamPos := FStream.Position; + + FZStream.avail_in := 0; + end; + + result := count - FZStream.avail_out; +end; + +function TZDecompressionStream.Write(const Buffer; Count: Longint): Longint; +begin + raise EZDecompressionError.Create(SZInvalid); +end; + +function TZDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; +var + buf: array[0..8191] of AnsiChar; + i: Integer; +begin + if (offset = 0) and (origin = soFromBeginning) then + begin + ZDecompressCheck(inflateReset(FZStream)); + + FZStream.next_in := @FBuffer; + FZStream.avail_in := 0; + + FStream.Position := 0; + FStreamPos := 0; + end + else if ((offset >= 0) and (origin = soFromCurrent)) or + (((offset - FZStream.total_out) > 0) and (origin = soFromBeginning)) then + begin + if origin = soFromBeginning then Dec(offset, FZStream.total_out); + + if offset > 0 then + begin + for i := 1 to offset div SizeOf(buf) do ReadBuffer(buf, SizeOf(buf)); + ReadBuffer(buf, offset mod SizeOf(buf)); + end; + end + else if (offset = 0) and (origin = soFromEnd) then + begin + while Read(buf, SizeOf(buf)) > 0 do ; + end + else raise EZDecompressionError.Create(SZInvalid); + + result := FZStream.total_out; +end; + +end. + diff --git a/official/4.8.11/FastQB/fqbrcDesign.pas b/official/4.8.11/FastQB/fqbrcDesign.pas new file mode 100644 index 0000000..18b0839 --- /dev/null +++ b/official/4.8.11/FastQB/fqbrcDesign.pas @@ -0,0 +1,48 @@ +{******************************************} +{ } +{ FastQueryBuilder } +{ Language resource file } +{ } +{ Copyright (c) 1998-2005 } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit fqbrcDesign; + +interface + +implementation + +uses fqbRes; + +const resStr = +'1=Ok' + #13#10 + +'2=Cancel' + #13#10 + +'1803=Clear' + #13#10 + +'1804=Save to file' + #13#10 + +'1805=Load from file' + #13#10 + +'1806=Model' + #13#10 + +'1807=SQL' + #13#10 + +'1808=Result' + #13#10 + +'-------TfqbGrid-------' + #13#10 + +'1820=Collumn' + #13#10 + +'1821=Visible' + #13#10 + +'1822=Where' + #13#10 + +'1823=Sort' + #13#10 + +'1824=Function' + #13#10 + +'1825=Group' + #13#10 + +'1826=Move up' + #13#10 + +'1827=Move down' + #13#10 + +'1828=Visible' + #13#10 + +'1829=Not Visible' + #13#10 + +'1830=No' + #13#10 + +'1831=Ascending' + #13#10 + +'1832=Descending' + #13#10 + +'1833=Grouping' + #13#10 + +''; + +initialization + fqbResources.AddStrings(resStr); + +end. diff --git a/official/4.8.11/FastQB/images.res b/official/4.8.11/FastQB/images.res new file mode 100644 index 0000000..a3895b6 Binary files /dev/null and b/official/4.8.11/FastQB/images.res differ diff --git a/official/4.8.11/FastQB/infback.zobj b/official/4.8.11/FastQB/infback.zobj new file mode 100644 index 0000000..1f6ff57 Binary files /dev/null and b/official/4.8.11/FastQB/infback.zobj differ diff --git a/official/4.8.11/FastQB/inffast.zobj b/official/4.8.11/FastQB/inffast.zobj new file mode 100644 index 0000000..ba4ae54 Binary files /dev/null and b/official/4.8.11/FastQB/inffast.zobj differ diff --git a/official/4.8.11/FastQB/inflate.zobj b/official/4.8.11/FastQB/inflate.zobj new file mode 100644 index 0000000..0bf06b1 Binary files /dev/null and b/official/4.8.11/FastQB/inflate.zobj differ diff --git a/official/4.8.11/FastQB/inftrees.zobj b/official/4.8.11/FastQB/inftrees.zobj new file mode 100644 index 0000000..1da0225 Binary files /dev/null and b/official/4.8.11/FastQB/inftrees.zobj differ diff --git a/official/4.8.11/FastQB/trees.zobj b/official/4.8.11/FastQB/trees.zobj new file mode 100644 index 0000000..274284e Binary files /dev/null and b/official/4.8.11/FastQB/trees.zobj differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSADORTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSADORTTI.bmp new file mode 100644 index 0000000..f966d42 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSADORTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSBASIC.bmp b/official/4.8.11/FastScript/bitmaps/TFSBASIC.bmp new file mode 100644 index 0000000..13d4c8d Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSBASIC.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSBDERTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSBDERTTI.bmp new file mode 100644 index 0000000..49a8dbc Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSBDERTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSCHARTRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSCHARTRTTI.bmp new file mode 100644 index 0000000..d1f6f41 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSCHARTRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSCLASSESRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSCLASSESRTTI.bmp new file mode 100644 index 0000000..cf81c5b Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSCLASSESRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSCPP.bmp b/official/4.8.11/FastScript/bitmaps/TFSCPP.bmp new file mode 100644 index 0000000..0ce02dc Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSCPP.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSDBCTRLSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSDBCTRLSRTTI.bmp new file mode 100644 index 0000000..059d207 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSDBCTRLSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSDBRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSDBRTTI.bmp new file mode 100644 index 0000000..bbcbb34 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSDBRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSDIALOGSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSDIALOGSRTTI.bmp new file mode 100644 index 0000000..0b5a565 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSDIALOGSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSEXTCTRLSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSEXTCTRLSRTTI.bmp new file mode 100644 index 0000000..7e6fe4d Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSEXTCTRLSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSFORMSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSFORMSRTTI.bmp new file mode 100644 index 0000000..1075a16 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSFORMSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSGRAPHICSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSGRAPHICSRTTI.bmp new file mode 100644 index 0000000..46c7042 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSGRAPHICSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSIBXRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSIBXRTTI.bmp new file mode 100644 index 0000000..240339d Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSIBXRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSINIRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSINIRTTI.bmp new file mode 100644 index 0000000..3dd1e56 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSINIRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSJSCRIPT.bmp b/official/4.8.11/FastScript/bitmaps/TFSJSCRIPT.bmp new file mode 100644 index 0000000..24e7cd8 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSJSCRIPT.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSMENUSRTTI.bmp b/official/4.8.11/FastScript/bitmaps/TFSMENUSRTTI.bmp new file mode 100644 index 0000000..ad308c3 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSMENUSRTTI.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSPASCAL.bmp b/official/4.8.11/FastScript/bitmaps/TFSPASCAL.bmp new file mode 100644 index 0000000..aee07d9 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSPASCAL.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSSCRIPT.bmp b/official/4.8.11/FastScript/bitmaps/TFSSCRIPT.bmp new file mode 100644 index 0000000..df880d1 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSSCRIPT.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSSYNTAXMEMO.bmp b/official/4.8.11/FastScript/bitmaps/TFSSYNTAXMEMO.bmp new file mode 100644 index 0000000..f06f89f Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSSYNTAXMEMO.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/TFSTREE.bmp b/official/4.8.11/FastScript/bitmaps/TFSTREE.bmp new file mode 100644 index 0000000..9885c37 Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/TFSTREE.bmp differ diff --git a/official/4.8.11/FastScript/bitmaps/build_fstree.bat b/official/4.8.11/FastScript/bitmaps/build_fstree.bat new file mode 100644 index 0000000..660e124 --- /dev/null +++ b/official/4.8.11/FastScript/bitmaps/build_fstree.bat @@ -0,0 +1 @@ +lazres ..\fs_tree.lrs FSTREE.BMP diff --git a/official/4.8.11/FastScript/bitmaps/build_lrs.bat b/official/4.8.11/FastScript/bitmaps/build_lrs.bat new file mode 100644 index 0000000..ad44851 --- /dev/null +++ b/official/4.8.11/FastScript/bitmaps/build_lrs.bat @@ -0,0 +1 @@ +lazres ..\fs_ireg.lrs TFSADORTTI.bmp TFSBASIC.bmp TFSBDERTTI.bmp TFSCHARTRTTI.bmp TFSCLASSESRTTI.bmp TFSINIRTTI.bmp TFSMENUSRTTI.bmp TFSCPP.bmp TFSDBCTRLSRTTI.bmp TFSDBRTTI.bmp TFSDIALOGSRTTI.bmp TFSEXTCTRLSRTTI.bmp TFSFORMSRTTI.bmp TFSGRAPHICSRTTI.bmp TFSIBXRTTI.bmp TFSJSCRIPT.bmp TFSPASCAL.bmp TFSSCRIPT.bmp TFSSYNTAXMEMO.bmp TFSTREE.bmp diff --git a/official/4.8.11/FastScript/bitmaps/fstree.bmp b/official/4.8.11/FastScript/bitmaps/fstree.bmp new file mode 100644 index 0000000..3e3fcdf Binary files /dev/null and b/official/4.8.11/FastScript/bitmaps/fstree.bmp differ diff --git a/official/4.8.11/FastScript/dclfs10.bdsproj b/official/4.8.11/FastScript/dclfs10.bdsproj new file mode 100644 index 0000000..50df875 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfs10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfs10.dpk b/official/4.8.11/FastScript/dclfs10.dpk new file mode 100644 index 0000000..ee58326 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs10.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2006 + +package dclfs10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs11.bdsproj b/official/4.8.11/FastScript/dclfs11.bdsproj new file mode 100644 index 0000000..7a8513d --- /dev/null +++ b/official/4.8.11/FastScript/dclfs11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfs11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfs11.dpk b/official/4.8.11/FastScript/dclfs11.dpk new file mode 100644 index 0000000..ef818c5 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs11.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2007 + +package dclfs11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs12.bdsproj b/official/4.8.11/FastScript/dclfs12.bdsproj new file mode 100644 index 0000000..3af9c66 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfs12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfs12.dpk b/official/4.8.11/FastScript/dclfs12.dpk new file mode 100644 index 0000000..7a544bd --- /dev/null +++ b/official/4.8.11/FastScript/dclfs12.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfs12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs12.dproj b/official/4.8.11/FastScript/dclfs12.dproj new file mode 100644 index 0000000..a4848a7 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs12.dproj @@ -0,0 +1,102 @@ +п»ї + + {45671288-55FD-49C9-B147-4392E5B91012} + dclfs12.dpk + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + true + true + false + false + false + false + false + true + true + true + 00400000 + ..\..\..\RAD Studio\6.0\Bpl\dclfs12.bpl + FastScript 1.9 Components + x86 + + + 0 + false + false + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + + Base + + + + + Delphi.Personality + Package + + + dclfs12.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + diff --git a/official/4.8.11/FastScript/dclfs14.bdsproj b/official/4.8.11/FastScript/dclfs14.bdsproj new file mode 100644 index 0000000..cdefde5 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfs14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfs14.dpk b/official/4.8.11/FastScript/dclfs14.dpk new file mode 100644 index 0000000..aeebcf1 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs14.dpk @@ -0,0 +1,39 @@ +// Package file for Delphi 2008 + +package dclfs14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs4.dpk b/official/4.8.11/FastScript/dclfs4.dpk new file mode 100644 index 0000000..9858ea0 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs4.dpk @@ -0,0 +1,39 @@ +// Package file for Delphi 4 + +package dclfs4; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + fs4; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs5.dpk b/official/4.8.11/FastScript/dclfs5.dpk new file mode 100644 index 0000000..3cfbd14 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs5.dpk @@ -0,0 +1,39 @@ +// Package file for Delphi 5 + +package dclfs5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs6.dpk b/official/4.8.11/FastScript/dclfs6.dpk new file mode 100644 index 0000000..484be3f --- /dev/null +++ b/official/4.8.11/FastScript/dclfs6.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 6 + +package dclfs6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs7.dpk b/official/4.8.11/FastScript/dclfs7.dpk new file mode 100644 index 0000000..554e22b --- /dev/null +++ b/official/4.8.11/FastScript/dclfs7.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 7 + +package dclfs7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfs9.bdsproj b/official/4.8.11/FastScript/dclfs9.bdsproj new file mode 100644 index 0000000..8b1acd0 --- /dev/null +++ b/official/4.8.11/FastScript/dclfs9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfs9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfs9.dpk b/official/4.8.11/FastScript/dclfs9.dpk new file mode 100644 index 0000000..e64ed1e --- /dev/null +++ b/official/4.8.11/FastScript/dclfs9.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2005 + +package dclfs9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO10.bdsproj b/official/4.8.11/FastScript/dclfsADO10.bdsproj new file mode 100644 index 0000000..957918a --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsADO10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsADO10.dpk b/official/4.8.11/FastScript/dclfsADO10.dpk new file mode 100644 index 0000000..d21c660 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package dclfsADO10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10, + fsADO10; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO11.bdsproj b/official/4.8.11/FastScript/dclfsADO11.bdsproj new file mode 100644 index 0000000..3baa552 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsADO11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsADO11.dpk b/official/4.8.11/FastScript/dclfsADO11.dpk new file mode 100644 index 0000000..394cf98 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package dclfsADO11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11, + fsADO11; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO12.bdsproj b/official/4.8.11/FastScript/dclfsADO12.bdsproj new file mode 100644 index 0000000..a172597 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsADO12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsADO12.dpk b/official/4.8.11/FastScript/dclfsADO12.dpk new file mode 100644 index 0000000..f50794d --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package dclfsADO12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12, + fsADO12; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO14.bdsproj b/official/4.8.11/FastScript/dclfsADO14.bdsproj new file mode 100644 index 0000000..73c0fed --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsADO14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsADO14.dpk b/official/4.8.11/FastScript/dclfsADO14.dpk new file mode 100644 index 0000000..476b7b8 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfsADO14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14, + fsADO14; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO5.dpk b/official/4.8.11/FastScript/dclfsADO5.dpk new file mode 100644 index 0000000..83fa0f8 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO5.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 5 + +package dclfsADO5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5, + fsADO5; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO6.dpk b/official/4.8.11/FastScript/dclfsADO6.dpk new file mode 100644 index 0000000..5fa1b3f --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package dclfsADO6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6, + fsADO6; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO7.dpk b/official/4.8.11/FastScript/dclfsADO7.dpk new file mode 100644 index 0000000..654692b --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package dclfsADO7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7, + fsADO7; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsADO9.bdsproj b/official/4.8.11/FastScript/dclfsADO9.bdsproj new file mode 100644 index 0000000..42ee713 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsADO9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsADO9.dpk b/official/4.8.11/FastScript/dclfsADO9.dpk new file mode 100644 index 0000000..9ebdf0d --- /dev/null +++ b/official/4.8.11/FastScript/dclfsADO9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package dclfsADO9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 ADO Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9, + fsADO9; + +contains + fs_iadoreg in 'fs_iadoreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE10.bdsproj b/official/4.8.11/FastScript/dclfsBDE10.bdsproj new file mode 100644 index 0000000..bd86a0b --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsBDE10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsBDE10.dpk b/official/4.8.11/FastScript/dclfsBDE10.dpk new file mode 100644 index 0000000..bb801e1 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package dclfsBDE10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10, + fsBDE10; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE11.bdsproj b/official/4.8.11/FastScript/dclfsBDE11.bdsproj new file mode 100644 index 0000000..1b1f5aa --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsBDE11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsBDE11.dpk b/official/4.8.11/FastScript/dclfsBDE11.dpk new file mode 100644 index 0000000..c0c9f2e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package dclfsBDE11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11, + fsBDE11; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE12.bdsproj b/official/4.8.11/FastScript/dclfsBDE12.bdsproj new file mode 100644 index 0000000..59c5ec0 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsBDE12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsBDE12.dpk b/official/4.8.11/FastScript/dclfsBDE12.dpk new file mode 100644 index 0000000..58823c3 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package dclfsBDE12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12, + fsBDE12; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE14.bdsproj b/official/4.8.11/FastScript/dclfsBDE14.bdsproj new file mode 100644 index 0000000..b807a23 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsBDE14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsBDE14.dpk b/official/4.8.11/FastScript/dclfsBDE14.dpk new file mode 100644 index 0000000..97370db --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfsBDE14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14, + fsBDE14; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE4.dpk b/official/4.8.11/FastScript/dclfsBDE4.dpk new file mode 100644 index 0000000..50b1256 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE4.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 4 + +package dclfsBDE4; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + fs4, + fsBDE4; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE5.dpk b/official/4.8.11/FastScript/dclfsBDE5.dpk new file mode 100644 index 0000000..b800eea --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE5.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 5 + +package dclfsBDE5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5, + fsBDE5; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE6.dpk b/official/4.8.11/FastScript/dclfsBDE6.dpk new file mode 100644 index 0000000..32ff035 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package dclfsBDE6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6, + fsBDE6; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE7.dpk b/official/4.8.11/FastScript/dclfsBDE7.dpk new file mode 100644 index 0000000..2a4a41d --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package dclfsBDE7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7, + fsBDE7; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsBDE9.bdsproj b/official/4.8.11/FastScript/dclfsBDE9.bdsproj new file mode 100644 index 0000000..8ff5e78 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsBDE9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsBDE9.dpk b/official/4.8.11/FastScript/dclfsBDE9.dpk new file mode 100644 index 0000000..2a9fdc9 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsBDE9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package dclfsBDE9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 BDE Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9, + fsBDE9; + +contains + fs_ibdereg in 'fs_ibdereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB10.bdsproj b/official/4.8.11/FastScript/dclfsDB10.bdsproj new file mode 100644 index 0000000..4b0941c --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsDB10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsDB10.dpk b/official/4.8.11/FastScript/dclfsDB10.dpk new file mode 100644 index 0000000..94f1794 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package dclfsDB10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10, + fsDB10; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB11.bdsproj b/official/4.8.11/FastScript/dclfsDB11.bdsproj new file mode 100644 index 0000000..cf54521 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsDB11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsDB11.dpk b/official/4.8.11/FastScript/dclfsDB11.dpk new file mode 100644 index 0000000..0f6556c --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package dclfsDB11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11, + fsDB11; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB12.bdsproj b/official/4.8.11/FastScript/dclfsDB12.bdsproj new file mode 100644 index 0000000..0a0daba --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsDB12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsDB12.dpk b/official/4.8.11/FastScript/dclfsDB12.dpk new file mode 100644 index 0000000..9780517 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package dclfsDB12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12, + fsDB12; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB14.bdsproj b/official/4.8.11/FastScript/dclfsDB14.bdsproj new file mode 100644 index 0000000..eafa990 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsDB14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsDB14.dpk b/official/4.8.11/FastScript/dclfsDB14.dpk new file mode 100644 index 0000000..993aa8e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfsDB14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14, + fsDB14; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB4.dpk b/official/4.8.11/FastScript/dclfsDB4.dpk new file mode 100644 index 0000000..872a4b9 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB4.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 4 + +package dclfsDB4; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + fs4, + fsDB4; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB5.dpk b/official/4.8.11/FastScript/dclfsDB5.dpk new file mode 100644 index 0000000..01d155e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB5.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 5 + +package dclfsDB5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5, + fsDB5; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB6.dpk b/official/4.8.11/FastScript/dclfsDB6.dpk new file mode 100644 index 0000000..973438d --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package dclfsDB6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6, + fsDB6; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB7.dpk b/official/4.8.11/FastScript/dclfsDB7.dpk new file mode 100644 index 0000000..dcda2cb --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package dclfsDB7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7, + fsDB7; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsDB9.bdsproj b/official/4.8.11/FastScript/dclfsDB9.bdsproj new file mode 100644 index 0000000..c9a5e68 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsDB9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsDB9.dpk b/official/4.8.11/FastScript/dclfsDB9.dpk new file mode 100644 index 0000000..30844d6 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsDB9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package dclfsDB9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 DB Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9, + fsDB9; + +contains + fs_idbreg in 'fs_idbreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX10.bdsproj b/official/4.8.11/FastScript/dclfsIBX10.bdsproj new file mode 100644 index 0000000..706b834 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsIBX10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsIBX10.dpk b/official/4.8.11/FastScript/dclfsIBX10.dpk new file mode 100644 index 0000000..5209b7f --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package dclfsIBX10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10, + fsIBX10; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX11.bdsproj b/official/4.8.11/FastScript/dclfsIBX11.bdsproj new file mode 100644 index 0000000..79b6c8f --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsIBX11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsIBX11.dpk b/official/4.8.11/FastScript/dclfsIBX11.dpk new file mode 100644 index 0000000..d7acc37 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package dclfsIBX11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11, + fsIBX11; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX12.bdsproj b/official/4.8.11/FastScript/dclfsIBX12.bdsproj new file mode 100644 index 0000000..fd57c88 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsIBX12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsIBX12.dpk b/official/4.8.11/FastScript/dclfsIBX12.dpk new file mode 100644 index 0000000..5778eb4 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package dclfsIBX12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12, + fsIBX12; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX14.bdsproj b/official/4.8.11/FastScript/dclfsIBX14.bdsproj new file mode 100644 index 0000000..d409c23 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsIBX14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsIBX14.dpk b/official/4.8.11/FastScript/dclfsIBX14.dpk new file mode 100644 index 0000000..16ab70c --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfsIBX14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14, + fsIBX14; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX5.dpk b/official/4.8.11/FastScript/dclfsIBX5.dpk new file mode 100644 index 0000000..1c6e40b --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX5.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 5 + +package dclfsIBX5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5, + fsIBX5; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX6.dpk b/official/4.8.11/FastScript/dclfsIBX6.dpk new file mode 100644 index 0000000..5e09acd --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package dclfsIBX6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6, + fsIBX6; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX7.dpk b/official/4.8.11/FastScript/dclfsIBX7.dpk new file mode 100644 index 0000000..04ff045 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package dclfsIBX7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7, + fsIBX7; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsIBX9.bdsproj b/official/4.8.11/FastScript/dclfsIBX9.bdsproj new file mode 100644 index 0000000..e5dfa3d --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + dclfsIBX9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + FastScript 1.9 IBX Components + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/FastScript/dclfsIBX9.dpk b/official/4.8.11/FastScript/dclfsIBX9.dpk new file mode 100644 index 0000000..bda27bc --- /dev/null +++ b/official/4.8.11/FastScript/dclfsIBX9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package dclfsIBX9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 IBX Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9, + fsIBX9; + +contains + fs_iibxreg in 'fs_iibxreg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee10.bdsproj b/official/4.8.11/FastScript/dclfsTee10.bdsproj new file mode 100644 index 0000000..c61771e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsTee10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsTee10.dpk b/official/4.8.11/FastScript/dclfsTee10.dpk new file mode 100644 index 0000000..26394bf --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package dclfsTee10; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs10, + fsTee10; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee11.bdsproj b/official/4.8.11/FastScript/dclfsTee11.bdsproj new file mode 100644 index 0000000..613cb95 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsTee11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsTee11.dpk b/official/4.8.11/FastScript/dclfsTee11.dpk new file mode 100644 index 0000000..8521499 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package dclfsTee11; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs11, + fsTee11; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee12.bdsproj b/official/4.8.11/FastScript/dclfsTee12.bdsproj new file mode 100644 index 0000000..1f109a8 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsTee12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsTee12.dpk b/official/4.8.11/FastScript/dclfsTee12.dpk new file mode 100644 index 0000000..25124e5 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package dclfsTee12; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs12, + fsTee12; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee14.bdsproj b/official/4.8.11/FastScript/dclfsTee14.bdsproj new file mode 100644 index 0000000..35edb6e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsTee14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsTee14.dpk b/official/4.8.11/FastScript/dclfsTee14.dpk new file mode 100644 index 0000000..e15bd29 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package dclfsTee14; + +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs14, + fsTee14; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee4.dpk b/official/4.8.11/FastScript/dclfsTee4.dpk new file mode 100644 index 0000000..c38f46e --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee4.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 4 + +package dclfsTee4; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + fs4, + fsTee4; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee5.dpk b/official/4.8.11/FastScript/dclfsTee5.dpk new file mode 100644 index 0000000..d7c96c8 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee5.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 5 + +package dclfsTee5; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + fs5, + fsTee5; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee6.dpk b/official/4.8.11/FastScript/dclfsTee6.dpk new file mode 100644 index 0000000..2b187c0 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package dclfsTee6; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs6, + fsTee6; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee7.dpk b/official/4.8.11/FastScript/dclfsTee7.dpk new file mode 100644 index 0000000..a0bd3d5 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package dclfsTee7; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs7, + fsTee7; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsTee9.bdsproj b/official/4.8.11/FastScript/dclfsTee9.bdsproj new file mode 100644 index 0000000..06055e2 --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + dclfsTee9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/dclfsTee9.dpk b/official/4.8.11/FastScript/dclfsTee9.dpk new file mode 100644 index 0000000..98f07bd --- /dev/null +++ b/official/4.8.11/FastScript/dclfsTee9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package dclfsTee9; + +{$R 'fs_ireg.dcr'} + +{$DESCRIPTION 'FastScript 1.9 Tee Components'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + DESIGNIDE, + fs9, + fsTee9; + +contains + fs_iteereg in 'fs_iteereg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsx.dpk b/official/4.8.11/FastScript/dclfsx.dpk new file mode 100644 index 0000000..83340eb --- /dev/null +++ b/official/4.8.11/FastScript/dclfsx.dpk @@ -0,0 +1,46 @@ +// Package file for CLX + +package dclfsx; + +{$R *.res} +{$R 'fs_ireg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'FastScript 1.9 Components'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + designide, + visualclx, + fsx +{$IFNDEF LINUX} +, bdertl, + adortl, + tee +{$ENDIF}; + +contains + fs_ireg in 'fs_ireg.pas'; + +end. diff --git a/official/4.8.11/FastScript/dclfsx.res b/official/4.8.11/FastScript/dclfsx.res new file mode 100644 index 0000000..fa40de9 Binary files /dev/null and b/official/4.8.11/FastScript/dclfsx.res differ diff --git a/official/4.8.11/FastScript/fs.inc b/official/4.8.11/FastScript/fs.inc new file mode 100644 index 0000000..87e8ecc --- /dev/null +++ b/official/4.8.11/FastScript/fs.inc @@ -0,0 +1,190 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Include file } +{ } +{ (c) 2003, 2004 by Alexander Tzyganenko, } +{ Fast Reports, Inc } +{ } +{******************************************} + + +{$R-} {- Range-Checking } +{$H+} {- Use long strings by default } +{$B-} {- Complete Boolean Evaluation } +{$T-} {- Typed @ operator } +{$P+} {- Open string params } + +{$IFNDEF FPC} + {$V-} {- Var-String Checking } + {$X+} {- Extended syntax } + {$J+} {- Writeable structured consts } +{$ENDIF} + +{$IFDEF VER120} // Delphi 4.0 + {$DEFINE Delphi4} +{$ENDIF} + +{$IFDEF VER130} // Delphi 5.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} +{$ENDIF} + +{$IFDEF VER140} // Delphi 6.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} +{$ENDIF} + +{$IFDEF VER150} // Delphi 7.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} +{$ENDIF} + +{$IFDEF VER170} // Delphi 9.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER180} // Delphi 10.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER185} // Delphi 11.0 (Spacely) + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER190} // Delphi 11.0 (Highlander) + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF VER200} // Delphi 12.0 (Tiburon) + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$DEFINE Delphi12} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +// {$WARNINGS OFF} +{$ENDIF} + +{$IFDEF VER210} // Delphi 14.0 + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE Delphi7} + {$DEFINE Delphi9} + {$DEFINE Delphi10} + {$DEFINE Delphi11} + {$DEFINE Delphi12} + {$DEFINE Delphi14} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + + +{$IFDEF VER125} // Borland C++ Builder 4.0 + {$DEFINE Delphi4} + {$ObjExportAll on} +{$ENDIF} + +{$IFDEF VER130} // Borland C++ Builder 5.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER140} // Borland C++ Builder 6.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$ENDIF} +{$ENDIF} + +{$IFDEF VER150} // Borland C++ Builder 7.0 + {$IFDEF BCB} + {$ObjExportAll on} + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} // Free pascal compiler + {$MODE DELPHI} + + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} +{$ELSE} + {$IFDEF LINUX} // KYLIX + {$DEFINE Delphi4} + {$DEFINE Delphi5} + {$DEFINE Delphi6} + {$DEFINE CLX} + {$IFDEF BCB} + {$DEFINE CLXCPP} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} + {$DEFINE CROSS_COMPILE} +{$ENDIF} + +{$IFDEF CLX} + {$DEFINE CROSS_COMPILE} +{$ENDIF} + +// Uncomment below line for CLX compilation +//{$DEFINE CLX} + +// include ole dispatch module +{$IFNDEF CROSS_COMPILE} + {$DEFINE OLE} +{$ENDIF} diff --git a/official/4.8.11/FastScript/fs10.bdsproj b/official/4.8.11/FastScript/fs10.bdsproj new file mode 100644 index 0000000..78c733f --- /dev/null +++ b/official/4.8.11/FastScript/fs10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fs10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fs10.dpk b/official/4.8.11/FastScript/fs10.dpk new file mode 100644 index 0000000..44f0b04 --- /dev/null +++ b/official/4.8.11/FastScript/fs10.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 2006 + +package fs10; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fs11.bdsproj b/official/4.8.11/FastScript/fs11.bdsproj new file mode 100644 index 0000000..b3494e9 --- /dev/null +++ b/official/4.8.11/FastScript/fs11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fs11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fs11.dpk b/official/4.8.11/FastScript/fs11.dpk new file mode 100644 index 0000000..b993ab0 --- /dev/null +++ b/official/4.8.11/FastScript/fs11.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 2007 + +package fs11; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fs12.bdsproj b/official/4.8.11/FastScript/fs12.bdsproj new file mode 100644 index 0000000..3c0a4aa --- /dev/null +++ b/official/4.8.11/FastScript/fs12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fs12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fs12.dpk b/official/4.8.11/FastScript/fs12.dpk new file mode 100644 index 0000000..64851c6 --- /dev/null +++ b/official/4.8.11/FastScript/fs12.dpk @@ -0,0 +1,61 @@ +// Package file for Delphi 2008 + +package fs12; + +{$I fs.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + +end. diff --git a/official/4.8.11/FastScript/fs12.dproj b/official/4.8.11/FastScript/fs12.dproj new file mode 100644 index 0000000..577a8eb --- /dev/null +++ b/official/4.8.11/FastScript/fs12.dproj @@ -0,0 +1,120 @@ +п»ї + + {BF4C56D6-8223-4F77-B027-AD7EB8012DD3} + fs12.dpk + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + true + true + false + false + false + false + false + true + true + 00400000 + ..\..\..\RAD Studio\6.0\Bpl\fs12.bpl + true + x86 + + + 0 + false + false + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + Base + + + + + Delphi.Personality + Package + + + fs12.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + diff --git a/official/4.8.11/FastScript/fs14.bdsproj b/official/4.8.11/FastScript/fs14.bdsproj new file mode 100644 index 0000000..a897f6e --- /dev/null +++ b/official/4.8.11/FastScript/fs14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fs14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fs14.dpk b/official/4.8.11/FastScript/fs14.dpk new file mode 100644 index 0000000..8ba2f2b --- /dev/null +++ b/official/4.8.11/FastScript/fs14.dpk @@ -0,0 +1,61 @@ +// Package file for Delphi 2008 + +package fs14; + +{$I fs.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + +end. diff --git a/official/4.8.11/FastScript/fs4.bpk b/official/4.8.11/FastScript/fs4.bpk new file mode 100644 index 0000000..fd7b16a --- /dev/null +++ b/official/4.8.11/FastScript/fs4.bpk @@ -0,0 +1,187 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = FS4.bpl +OBJFILES = fs_iReg.obj FS4.obj fs_iconst.obj +RESFILES = FS4.res fs_iReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +PACKAGES = vcl40.bpi vclx40.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"FastScript 1.9 Components" -aa -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fs4.cpp b/official/4.8.11/FastScript/fs4.cpp new file mode 100644 index 0000000..43953d6 --- /dev/null +++ b/official/4.8.11/FastScript/fs4.cpp @@ -0,0 +1,19 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("FS4.res"); +USEPACKAGE("vcl40.bpi"); +USEPACKAGE("vclx40.bpi"); +USEUNIT("fs_iReg.pas"); +USEUNIT("fs_iconst.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fs4.dpk b/official/4.8.11/FastScript/fs4.dpk new file mode 100644 index 0000000..0397c54 --- /dev/null +++ b/official/4.8.11/FastScript/fs4.dpk @@ -0,0 +1,65 @@ +// Package file for Delphi 4 + +package fs4; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + VCLX40; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fs4.res b/official/4.8.11/FastScript/fs4.res new file mode 100644 index 0000000..eb2597a Binary files /dev/null and b/official/4.8.11/FastScript/fs4.res differ diff --git a/official/4.8.11/FastScript/fs5.bpk b/official/4.8.11/FastScript/fs5.bpk new file mode 100644 index 0000000..8b10919 --- /dev/null +++ b/official/4.8.11/FastScript/fs5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fs5.cpp b/official/4.8.11/FastScript/fs5.cpp new file mode 100644 index 0000000..daadee8 --- /dev/null +++ b/official/4.8.11/FastScript/fs5.cpp @@ -0,0 +1,23 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vclx50.bpi"); +USEUNIT("fs_ireg.pas"); +USEUNIT("fs_iconst.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fs5.dpk b/official/4.8.11/FastScript/fs5.dpk new file mode 100644 index 0000000..c803adb --- /dev/null +++ b/official/4.8.11/FastScript/fs5.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 5 + +package fs5; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLX50; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fs5.res b/official/4.8.11/FastScript/fs5.res new file mode 100644 index 0000000..da3d366 Binary files /dev/null and b/official/4.8.11/FastScript/fs5.res differ diff --git a/official/4.8.11/FastScript/fs6.bpk b/official/4.8.11/FastScript/fs6.bpk new file mode 100644 index 0000000..822a6d2 --- /dev/null +++ b/official/4.8.11/FastScript/fs6.bpk @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] +d:\delphi\builder6\Projects\Bpl\FR6.bpl=FastReport 2.4 Components + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fs6.cpp b/official/4.8.11/FastScript/fs6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fs6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fs6.dpk b/official/4.8.11/FastScript/fs6.dpk new file mode 100644 index 0000000..425a1b9 --- /dev/null +++ b/official/4.8.11/FastScript/fs6.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 6 + +package fs6; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fs6.res b/official/4.8.11/FastScript/fs6.res new file mode 100644 index 0000000..2bbdbc1 Binary files /dev/null and b/official/4.8.11/FastScript/fs6.res differ diff --git a/official/4.8.11/FastScript/fs7.dpk b/official/4.8.11/FastScript/fs7.dpk new file mode 100644 index 0000000..623a47e --- /dev/null +++ b/official/4.8.11/FastScript/fs7.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 7 + +package fs7; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fs9.bdsproj b/official/4.8.11/FastScript/fs9.bdsproj new file mode 100644 index 0000000..6cd3ca1 --- /dev/null +++ b/official/4.8.11/FastScript/fs9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fs9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fs9.dpk b/official/4.8.11/FastScript/fs9.dpk new file mode 100644 index 0000000..7dfd9b9 --- /dev/null +++ b/official/4.8.11/FastScript/fs9.dpk @@ -0,0 +1,66 @@ +// Package file for Delphi 2005 + +package fs9; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLX; + + +contains + fs_ipascal in 'fs_ipascal.pas', + fs_icpp in 'fs_icpp.pas', + fs_ijs in 'fs_ijs.pas', + fs_ibasic in 'fs_ibasic.pas', + + fs_iclassesrtti in 'fs_iclassesrtti.pas', + fs_iconst in 'fs_iconst.pas', + fs_idialogsrtti in 'fs_idialogsrtti.pas', +{$IFDEF OLE} + fs_idisp in 'fs_idisp.pas', +{$ENDIF} + fs_ievents in 'fs_ievents.pas', + fs_iexpression in 'fs_iexpression.pas', + fs_iextctrlsrtti in 'fs_iextctrlsrtti.pas', + fs_iformsrtti in 'fs_iformsrtti.pas', + fs_igraphicsrtti in 'fs_igraphicsrtti.pas', + fs_iilparser in 'fs_iilparser.pas', + fs_iinirtti in 'fs_iinirtti.pas', + fs_iinterpreter in 'fs_iinterpreter.pas', + fs_iparser in 'fs_iparser.pas', + fs_isysrtti in 'fs_isysrtti.pas', + fs_imenusrtti in 'fs_imenusrtti.pas', + fs_itools in 'fs_itools.pas', + fs_xml in 'fs_xml.pas', + fs_synmemo in 'fs_synmemo.pas', + fs_tree in 'fs_tree.pas'; + + + +end. diff --git a/official/4.8.11/FastScript/fsADO10.bdsproj b/official/4.8.11/FastScript/fsADO10.bdsproj new file mode 100644 index 0000000..34727e5 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsADO10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsADO10.dpk b/official/4.8.11/FastScript/fsADO10.dpk new file mode 100644 index 0000000..d44b469 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO10.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2006 + +package fsADO10; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs10, + fsDB10; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO11.bdsproj b/official/4.8.11/FastScript/fsADO11.bdsproj new file mode 100644 index 0000000..79495ed --- /dev/null +++ b/official/4.8.11/FastScript/fsADO11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsADO11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsADO11.dpk b/official/4.8.11/FastScript/fsADO11.dpk new file mode 100644 index 0000000..3a61b1e --- /dev/null +++ b/official/4.8.11/FastScript/fsADO11.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2007 + +package fsADO11; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs11, + fsDB11; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO12.bdsproj b/official/4.8.11/FastScript/fsADO12.bdsproj new file mode 100644 index 0000000..203ebb0 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsADO12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsADO12.dpk b/official/4.8.11/FastScript/fsADO12.dpk new file mode 100644 index 0000000..85acbca --- /dev/null +++ b/official/4.8.11/FastScript/fsADO12.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2008 + +package fsADO12; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs12, + fsDB12; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO14.bdsproj b/official/4.8.11/FastScript/fsADO14.bdsproj new file mode 100644 index 0000000..081e8cf --- /dev/null +++ b/official/4.8.11/FastScript/fsADO14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsADO14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsADO14.dpk b/official/4.8.11/FastScript/fsADO14.dpk new file mode 100644 index 0000000..ef80848 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package fsADO14; + +{$I fs.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs14, + fsDB14; + +contains + fs_iadortti in 'fs_iadortti.pas'; + +end. diff --git a/official/4.8.11/FastScript/fsADO5.bpk b/official/4.8.11/FastScript/fsADO5.bpk new file mode 100644 index 0000000..5aa3c2b --- /dev/null +++ b/official/4.8.11/FastScript/fsADO5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsADO5.cpp b/official/4.8.11/FastScript/fsADO5.cpp new file mode 100644 index 0000000..1701cde --- /dev/null +++ b/official/4.8.11/FastScript/fsADO5.cpp @@ -0,0 +1,25 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("vclado50.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("fsDB5.bpi"); +USEUNIT("fs_iadoreg.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsADO5.dpk b/official/4.8.11/FastScript/fsADO5.dpk new file mode 100644 index 0000000..9e0732a --- /dev/null +++ b/official/4.8.11/FastScript/fsADO5.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 5 + +package fsADO5; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLDB50, + VCLADO50, + fs5, + fsDB5; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO6.bpk b/official/4.8.11/FastScript/fsADO6.bpk new file mode 100644 index 0000000..324e945 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO6.bpk @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsADO6.cpp b/official/4.8.11/FastScript/fsADO6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsADO6.dpk b/official/4.8.11/FastScript/fsADO6.dpk new file mode 100644 index 0000000..0397a08 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO6.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 6 + +package fsADO6; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs6, + fsDB6; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO7.dpk b/official/4.8.11/FastScript/fsADO7.dpk new file mode 100644 index 0000000..3975c14 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO7.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 7 + +package fsADO7; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs7, + fsDB7; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsADO9.bdsproj b/official/4.8.11/FastScript/fsADO9.bdsproj new file mode 100644 index 0000000..9d0a211 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + fsADO9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/FastScript/fsADO9.dpk b/official/4.8.11/FastScript/fsADO9.dpk new file mode 100644 index 0000000..92811e4 --- /dev/null +++ b/official/4.8.11/FastScript/fsADO9.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2005 + +package fsADO9; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + ADORTL, + fs9, + fsDB9; + +contains + fs_iadortti in 'fs_iadortti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE10.bdsproj b/official/4.8.11/FastScript/fsBDE10.bdsproj new file mode 100644 index 0000000..f085ba5 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsBDE10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsBDE10.dpk b/official/4.8.11/FastScript/fsBDE10.dpk new file mode 100644 index 0000000..b731095 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE10.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2006 + +package fsBDE10; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs10, + fsDB10; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE11.bdsproj b/official/4.8.11/FastScript/fsBDE11.bdsproj new file mode 100644 index 0000000..7ec05f1 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsBDE11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsBDE11.dpk b/official/4.8.11/FastScript/fsBDE11.dpk new file mode 100644 index 0000000..999e182 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE11.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2007 + +package fsBDE11; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs11, + fsDB11; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE12.bdsproj b/official/4.8.11/FastScript/fsBDE12.bdsproj new file mode 100644 index 0000000..dd1aa15 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsBDE12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsBDE12.dpk b/official/4.8.11/FastScript/fsBDE12.dpk new file mode 100644 index 0000000..0d967f4 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE12.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2008 + +package fsBDE12; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs12, + fsDB12; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE14.bdsproj b/official/4.8.11/FastScript/fsBDE14.bdsproj new file mode 100644 index 0000000..f3cd618 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsBDE14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsBDE14.dpk b/official/4.8.11/FastScript/fsBDE14.dpk new file mode 100644 index 0000000..37720a0 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE14.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2008 + +package fsBDE14; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs14, + fsDB14; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE4.bpk b/official/4.8.11/FastScript/fsBDE4.bpk new file mode 100644 index 0000000..72be8ad --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE4.bpk @@ -0,0 +1,187 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = FSBDE4.bpl +OBJFILES = fs_iReg.obj FSBDE4.obj +RESFILES = FS4.res fs_iReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +PACKAGES = vcl40.bpi vcldb40.bpi fs4.bpi fsDB4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"FastScript 1.9 BDE Components" -aa -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsBDE4.cpp b/official/4.8.11/FastScript/fsBDE4.cpp new file mode 100644 index 0000000..cb7bb1d --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE4.cpp @@ -0,0 +1,20 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("FS4.res"); +USEPACKAGE("vcl40.bpi"); +USEPACKAGE("vcldb40.bpi"); +USEPACKAGE("fs4.bpi"); +USEPACKAGE("fsDB4.bpi"); +USEUNIT("fs_ibdereg.pas"); +USERES("fs_ireg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsBDE4.dpk b/official/4.8.11/FastScript/fsBDE4.dpk new file mode 100644 index 0000000..6047735 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE4.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 4 + +package fsBDE4; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + VCLDB40, + fs4, + fsDB4; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE5.bpk b/official/4.8.11/FastScript/fsBDE5.bpk new file mode 100644 index 0000000..17a4c8d --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsBDE5.cpp b/official/4.8.11/FastScript/fsBDE5.cpp new file mode 100644 index 0000000..b2619a0 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE5.cpp @@ -0,0 +1,25 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("vclbde50.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("fsDB5.bpi"); +USEUNIT("fs_ibdereg.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsBDE5.dpk b/official/4.8.11/FastScript/fsBDE5.dpk new file mode 100644 index 0000000..3953b88 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE5.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 5 + +package fsBDE5; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLDB50, + VCLBDE50, + fs5, + fsDB5; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE6.bpk b/official/4.8.11/FastScript/fsBDE6.bpk new file mode 100644 index 0000000..5db87d1 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE6.bpk @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] +d:\delphi\builder6\Projects\Bpl\FR6.bpl=FastReport 2.4 Components + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsBDE6.cpp b/official/4.8.11/FastScript/fsBDE6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsBDE6.dpk b/official/4.8.11/FastScript/fsBDE6.dpk new file mode 100644 index 0000000..df93c1c --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE6.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 6 + +package fsBDE6; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs6, + fsDB6; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE7.dpk b/official/4.8.11/FastScript/fsBDE7.dpk new file mode 100644 index 0000000..98314cb --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE7.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 7 + +package fsBDE7; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs7, + fsDB7; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsBDE9.bdsproj b/official/4.8.11/FastScript/fsBDE9.bdsproj new file mode 100644 index 0000000..acd77ea --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + fsBDE9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/FastScript/fsBDE9.dpk b/official/4.8.11/FastScript/fsBDE9.dpk new file mode 100644 index 0000000..8d1fc5b --- /dev/null +++ b/official/4.8.11/FastScript/fsBDE9.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2005 + +package fsBDE9; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + BDERTL, + fs9, + fsDB9; + +contains + fs_ibdertti in 'fs_ibdertti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB10.bdsproj b/official/4.8.11/FastScript/fsDB10.bdsproj new file mode 100644 index 0000000..7627517 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsDB10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsDB10.dpk b/official/4.8.11/FastScript/fsDB10.dpk new file mode 100644 index 0000000..b313981 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB10.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2006 + +package fsDB10; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs10; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB11.bdsproj b/official/4.8.11/FastScript/fsDB11.bdsproj new file mode 100644 index 0000000..d69a33c --- /dev/null +++ b/official/4.8.11/FastScript/fsDB11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsDB11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsDB11.dpk b/official/4.8.11/FastScript/fsDB11.dpk new file mode 100644 index 0000000..118eaf9 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB11.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2007 + +package fsDB11; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs11; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB12.bdsproj b/official/4.8.11/FastScript/fsDB12.bdsproj new file mode 100644 index 0000000..9aef766 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsDB12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsDB12.dpk b/official/4.8.11/FastScript/fsDB12.dpk new file mode 100644 index 0000000..64f6326 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB12.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2008 + +package fsDB12; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs12; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB14.bdsproj b/official/4.8.11/FastScript/fsDB14.bdsproj new file mode 100644 index 0000000..e95648b --- /dev/null +++ b/official/4.8.11/FastScript/fsDB14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsDB14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsDB14.dpk b/official/4.8.11/FastScript/fsDB14.dpk new file mode 100644 index 0000000..90b7946 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB14.dpk @@ -0,0 +1,39 @@ +// Package file for Delphi 2008 + +package fsDB14; + +{$I fs.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs14; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + +end. diff --git a/official/4.8.11/FastScript/fsDB4.bpk b/official/4.8.11/FastScript/fsDB4.bpk new file mode 100644 index 0000000..a4df936 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB4.bpk @@ -0,0 +1,187 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = FSDB4.bpl +OBJFILES = fs_iReg.obj FSDB4.obj +RESFILES = FS4.res fs_iReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +PACKAGES = vcl40.bpi vcldb40.bpi fs4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"FastScript 1.9 DB Components" -aa -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsDB4.cpp b/official/4.8.11/FastScript/fsDB4.cpp new file mode 100644 index 0000000..4fe67af --- /dev/null +++ b/official/4.8.11/FastScript/fsDB4.cpp @@ -0,0 +1,19 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("FS4.res"); +USEPACKAGE("vcl40.bpi"); +USEPACKAGE("vcldb40.bpi"); +USEPACKAGE("fs4.bpi"); +USEUNIT("fs_idbreg.pas"); +USERES("fs_ireg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsDB4.dpk b/official/4.8.11/FastScript/fsDB4.dpk new file mode 100644 index 0000000..e5e5f62 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB4.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 4 + +package fsDB4; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + VCLDB40, + fs4; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB5.bpk b/official/4.8.11/FastScript/fsDB5.bpk new file mode 100644 index 0000000..f12ab61 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsDB5.cpp b/official/4.8.11/FastScript/fsDB5.cpp new file mode 100644 index 0000000..d782c17 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB5.cpp @@ -0,0 +1,23 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("fs5.bpi"); +USEUNIT("fs_idbreg.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsDB5.dpk b/official/4.8.11/FastScript/fsDB5.dpk new file mode 100644 index 0000000..d9761da --- /dev/null +++ b/official/4.8.11/FastScript/fsDB5.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 5 + +package fsDB5; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLDB50, + fs5; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB6.bpk b/official/4.8.11/FastScript/fsDB6.bpk new file mode 100644 index 0000000..8a6dc71 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB6.bpk @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] +d:\delphi\builder6\Projects\Bpl\FR6.bpl=FastReport 2.4 Components + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsDB6.cpp b/official/4.8.11/FastScript/fsDB6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsDB6.dpk b/official/4.8.11/FastScript/fsDB6.dpk new file mode 100644 index 0000000..8c41f34 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB6.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 6 + +package fsDB6; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs6; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB7.dpk b/official/4.8.11/FastScript/fsDB7.dpk new file mode 100644 index 0000000..672282e --- /dev/null +++ b/official/4.8.11/FastScript/fsDB7.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 7 + +package fsDB7; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs7; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsDB9.bdsproj b/official/4.8.11/FastScript/fsDB9.bdsproj new file mode 100644 index 0000000..4f121f2 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsDB9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsDB9.dpk b/official/4.8.11/FastScript/fsDB9.dpk new file mode 100644 index 0000000..4769461 --- /dev/null +++ b/official/4.8.11/FastScript/fsDB9.dpk @@ -0,0 +1,41 @@ +// Package file for Delphi 2005 + +package fsDB9; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + fs9; + +contains + fs_idbctrlsrtti in 'fs_idbctrlsrtti.pas', + fs_idbrtti in 'fs_idbrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX10.bdsproj b/official/4.8.11/FastScript/fsIBX10.bdsproj new file mode 100644 index 0000000..4e8e760 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsIBX10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsIBX10.dpk b/official/4.8.11/FastScript/fsIBX10.dpk new file mode 100644 index 0000000..6281b11 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX10.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2006 + +package fsIBX10; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs10, + fsDB10; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX11.bdsproj b/official/4.8.11/FastScript/fsIBX11.bdsproj new file mode 100644 index 0000000..1cbf2d6 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsIBX11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsIBX11.dpk b/official/4.8.11/FastScript/fsIBX11.dpk new file mode 100644 index 0000000..1b0d14f --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX11.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2007 + +package fsIBX11; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs11, + fsDB11; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX12.bdsproj b/official/4.8.11/FastScript/fsIBX12.bdsproj new file mode 100644 index 0000000..cc4e574 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsIBX12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsIBX12.dpk b/official/4.8.11/FastScript/fsIBX12.dpk new file mode 100644 index 0000000..b7ff17a --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX12.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2008 + +package fsIBX12; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs12, + fsDB12; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX14.bdsproj b/official/4.8.11/FastScript/fsIBX14.bdsproj new file mode 100644 index 0000000..19f9ab3 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsIBX14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsIBX14.dpk b/official/4.8.11/FastScript/fsIBX14.dpk new file mode 100644 index 0000000..244aca1 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX14.dpk @@ -0,0 +1,40 @@ +// Package file for Delphi 2008 + +package fsIBX14; + +{$I fs.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs14, + fsDB14; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + +end. diff --git a/official/4.8.11/FastScript/fsIBX5.bpk b/official/4.8.11/FastScript/fsIBX5.bpk new file mode 100644 index 0000000..f58100b --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsIBX5.cpp b/official/4.8.11/FastScript/fsIBX5.cpp new file mode 100644 index 0000000..3b8be05 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX5.cpp @@ -0,0 +1,26 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vcldb50.bpi"); +USEPACKAGE("vclib50.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("fsDB5.bpi"); +USEUNIT("fs_iibxreg.pas"); +USEUNIT("fs_iibxrtti.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsIBX5.dpk b/official/4.8.11/FastScript/fsIBX5.dpk new file mode 100644 index 0000000..c3f4244 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX5.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 5 + +package fsIBX5; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + VCLDB50, + VCLIB50, + fs5, + fsDB5; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX6.bpk b/official/4.8.11/FastScript/fsIBX6.bpk new file mode 100644 index 0000000..3ece52b --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX6.bpk @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsIBX6.cpp b/official/4.8.11/FastScript/fsIBX6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsIBX6.dpk b/official/4.8.11/FastScript/fsIBX6.dpk new file mode 100644 index 0000000..2961327 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX6.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 6 + +package fsIBX6; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs6, + fsDB6; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX7.dpk b/official/4.8.11/FastScript/fsIBX7.dpk new file mode 100644 index 0000000..6ec8ab0 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX7.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 7 + +package fsIBX7; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs7, + fsDB7; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsIBX9.bdsproj b/official/4.8.11/FastScript/fsIBX9.bdsproj new file mode 100644 index 0000000..013ea63 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX9.bdsproj @@ -0,0 +1,168 @@ +п»ї + + + + + + + + + + + fsIBX9.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + + + + + False + + + + + + False + + + + + + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/official/4.8.11/FastScript/fsIBX9.dpk b/official/4.8.11/FastScript/fsIBX9.dpk new file mode 100644 index 0000000..bdc5c57 --- /dev/null +++ b/official/4.8.11/FastScript/fsIBX9.dpk @@ -0,0 +1,42 @@ +// Package file for Delphi 2005 + +package fsIBX9; + +{$I fs.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + VCLDB, + IBXPRESS, + fs9, + fsDB9; + +contains + fs_iibxrtti in 'fs_iibxrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee10.bdsproj b/official/4.8.11/FastScript/fsTee10.bdsproj new file mode 100644 index 0000000..49aba99 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsTee10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsTee10.dpk b/official/4.8.11/FastScript/fsTee10.dpk new file mode 100644 index 0000000..2cd3283 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee10.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 2006 + +package fsTee10; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE710, {$ENDIF} +{$IFDEF TeeChartStd8}TEE810, {$ENDIF} +{$IFDEF TeeChart4} TEE410, {$ENDIF} +{$IFDEF TeeChart5} TEE510, {$ENDIF} +{$IFDEF TeeChart6} TEE610, {$ENDIF} +{$IFDEF TeeChart7} TEE710, {$ENDIF} +{$IFDEF TeeChart8} TEE810, {$ENDIF} + VCLX, + fs10; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee11.bdsproj b/official/4.8.11/FastScript/fsTee11.bdsproj new file mode 100644 index 0000000..4526b0a --- /dev/null +++ b/official/4.8.11/FastScript/fsTee11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsTee11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsTee11.dpk b/official/4.8.11/FastScript/fsTee11.dpk new file mode 100644 index 0000000..2c9bc56 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee11.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 2007 + +package fsTee11; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE711, {$ENDIF} +{$IFDEF TeeChartStd8}TEE811, {$ENDIF} +{$IFDEF TeeChart4} TEE411, {$ENDIF} +{$IFDEF TeeChart5} TEE511, {$ENDIF} +{$IFDEF TeeChart6} TEE611, {$ENDIF} +{$IFDEF TeeChart7} TEE711, {$ENDIF} +{$IFDEF TeeChart8} TEE811, {$ENDIF} + VCLX, + fs11; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee12.bdsproj b/official/4.8.11/FastScript/fsTee12.bdsproj new file mode 100644 index 0000000..90c284f --- /dev/null +++ b/official/4.8.11/FastScript/fsTee12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsTee12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsTee12.dpk b/official/4.8.11/FastScript/fsTee12.dpk new file mode 100644 index 0000000..9c49768 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee12.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 2008 + +package fsTee12; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE712, {$ENDIF} +{$IFDEF TeeChartStd8}TEE812, {$ENDIF} +{$IFDEF TeeChart4} TEE412, {$ENDIF} +{$IFDEF TeeChart5} TEE512, {$ENDIF} +{$IFDEF TeeChart6} TEE612, {$ENDIF} +{$IFDEF TeeChart7} TEE712, {$ENDIF} +{$IFDEF TeeChart8} TEE812, {$ENDIF} + VCLX, + fs12; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee12.dproj b/official/4.8.11/FastScript/fsTee12.dproj new file mode 100644 index 0000000..cedf422 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee12.dproj @@ -0,0 +1,94 @@ +п»ї + + {5E18CE7A-A8EC-4D30-BB89-F6A53E7DE91C} + fsTee12.dpk + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + true + true + true + true + 00400000 + ..\..\..\RAD Studio\6.0\Bpl\fsTee12.bpl + true + + + 0 + false + false + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + Base + + + + + Delphi.Personality + Package + + + fsTee12.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + diff --git a/official/4.8.11/FastScript/fsTee14.bdsproj b/official/4.8.11/FastScript/fsTee14.bdsproj new file mode 100644 index 0000000..f310b5a --- /dev/null +++ b/official/4.8.11/FastScript/fsTee14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsTee14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsTee14.dpk b/official/4.8.11/FastScript/fsTee14.dpk new file mode 100644 index 0000000..489060d --- /dev/null +++ b/official/4.8.11/FastScript/fsTee14.dpk @@ -0,0 +1,47 @@ +// Package file for Delphi 2010 + +package fsTee14; + +{$I fs.inc} +{$I tee.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE714, {$ENDIF} +{$IFDEF TeeChartStd8}TEE814, {$ENDIF} +{$IFDEF TeeChart4} TEE414, {$ENDIF} +{$IFDEF TeeChart5} TEE514, {$ENDIF} +{$IFDEF TeeChart6} TEE614, {$ENDIF} +{$IFDEF TeeChart7} TEE714, {$ENDIF} +{$IFDEF TeeChart8} TEE814, {$ENDIF} + VCLX, + fs14; + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + +end. diff --git a/official/4.8.11/FastScript/fsTee4.bpk b/official/4.8.11/FastScript/fsTee4.bpk new file mode 100644 index 0000000..cd082cc --- /dev/null +++ b/official/4.8.11/FastScript/fsTee4.bpk @@ -0,0 +1,187 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = FSTee4.bpl +OBJFILES = fs_iteereg.obj FSTee4.obj fs_ichartrtti.obj +RESFILES = FS4.res fs_iReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +PACKAGES = vcl40.bpi vclx40.bpi tee40.bpi fs4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"FastScript 1.9 Tee Components" -aa -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsTee4.cpp b/official/4.8.11/FastScript/fsTee4.cpp new file mode 100644 index 0000000..396b5fd --- /dev/null +++ b/official/4.8.11/FastScript/fsTee4.cpp @@ -0,0 +1,21 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("FS4.res"); +USEPACKAGE("vcl40.bpi"); +USEPACKAGE("vclx40.bpi"); +USEPACKAGE("tee40.bpi"); +USEPACKAGE("fs4.bpi"); +USEUNIT("fs_iteeReg.pas"); +USEUNIT("fs_ichartrtti.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsTee4.dpk b/official/4.8.11/FastScript/fsTee4.dpk new file mode 100644 index 0000000..9608249 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee4.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 4 + +package fsTee4; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, +{$IFDEF TeeChartStd} TEE40, {$ENDIF} +{$IFDEF TeeChart4} TEE44, {$ENDIF} +{$IFDEF TeeChart5} TEE54, {$ENDIF} +{$IFDEF TeeChart6} TEE64, {$ENDIF} +{$IFDEF TeeChart7} TEE74, {$ENDIF} +{$IFDEF TeeChart8} TEE84, {$ENDIF} + VCLX40, + fs4; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee5.bpk b/official/4.8.11/FastScript/fsTee5.bpk new file mode 100644 index 0000000..9d99ff5 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee5.bpk @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=9 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsTee5.cpp b/official/4.8.11/FastScript/fsTee5.cpp new file mode 100644 index 0000000..1f8f0ba --- /dev/null +++ b/official/4.8.11/FastScript/fsTee5.cpp @@ -0,0 +1,25 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +USERES("FS5.res"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vclx50.bpi"); +USEPACKAGE("tee50.bpi"); +USEPACKAGE("fs5.bpi"); +USEUNIT("fs_iteereg.pas"); +USEUNIT("fs_ichartrtti.pas"); +USERES("fs_iReg.dcr"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/FastScript/fsTee5.dpk b/official/4.8.11/FastScript/fsTee5.dpk new file mode 100644 index 0000000..52a5644 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee5.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 5 + +package fsTee5; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, +{$IFDEF TeeChartStd} TEE50, {$ENDIF} +{$IFDEF TeeChart4} TEE45, {$ENDIF} +{$IFDEF TeeChart5} TEE55, {$ENDIF} +{$IFDEF TeeChart6} TEE65, {$ENDIF} +{$IFDEF TeeChart7} TEE75, {$ENDIF} +{$IFDEF TeeChart8} TEE85, {$ENDIF} + VCLX50, + fs5; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee6.bpk b/official/4.8.11/FastScript/fsTee6.bpk new file mode 100644 index 0000000..fdd2636 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee6.bpk @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=9 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Excluded Packages] +d:\delphi\builder6\Projects\Bpl\FR6.bpl=FastReport 2.4 Components + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsTee6.cpp b/official/4.8.11/FastScript/fsTee6.cpp new file mode 100644 index 0000000..59b8711 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee6.cpp @@ -0,0 +1,17 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/FastScript/fsTee6.dpk b/official/4.8.11/FastScript/fsTee6.dpk new file mode 100644 index 0000000..f3edf8c --- /dev/null +++ b/official/4.8.11/FastScript/fsTee6.dpk @@ -0,0 +1,48 @@ +// Package file for Delphi 6 + +package fsTee6; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChart4} TEE46, {$ENDIF} +{$IFDEF TeeChart5} TEE56, {$ENDIF} +{$IFDEF TeeChart6} TEE66, {$ENDIF} +{$IFDEF TeeChart7} TEE76, {$ENDIF} +{$IFDEF TeeChart8} TEE86, {$ENDIF} + VCLX, + fs6; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee7.dpk b/official/4.8.11/FastScript/fsTee7.dpk new file mode 100644 index 0000000..ef23cd2 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee7.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 7 + +package fsTee7; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE77, {$ENDIF} +{$IFDEF TeeChartStd8}TEE87, {$ENDIF} +{$IFDEF TeeChart4} TEE47, {$ENDIF} +{$IFDEF TeeChart5} TEE57, {$ENDIF} +{$IFDEF TeeChart6} TEE67, {$ENDIF} +{$IFDEF TeeChart7} TEE77, {$ENDIF} +{$IFDEF TeeChart8} TEE87, {$ENDIF} + VCLX, + fs7; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fsTee9.bdsproj b/official/4.8.11/FastScript/fsTee9.bdsproj new file mode 100644 index 0000000..5baa922 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + fsTee9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/FastScript/fsTee9.dpk b/official/4.8.11/FastScript/fsTee9.dpk new file mode 100644 index 0000000..b0f7be1 --- /dev/null +++ b/official/4.8.11/FastScript/fsTee9.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 2005 + +package fsTee9; + +{$I fs.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} + +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, {$ENDIF} +{$IFDEF TeeChartStd7}TEE79, {$ENDIF} +{$IFDEF TeeChartStd8}TEE89, {$ENDIF} +{$IFDEF TeeChart4} TEE49, {$ENDIF} +{$IFDEF TeeChart5} TEE59, {$ENDIF} +{$IFDEF TeeChart6} TEE69, {$ENDIF} +{$IFDEF TeeChart7} TEE79, {$ENDIF} +{$IFDEF TeeChart8} TEE89, {$ENDIF} + VCLX, + fs9; + + +contains + fs_ichartrtti in 'fs_ichartrtti.pas'; + + +end. diff --git a/official/4.8.11/FastScript/fs_iadoreg.pas b/official/4.8.11/FastScript/fs_iadoreg.pas new file mode 100644 index 0000000..ed795c1 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iadoreg.pas @@ -0,0 +1,39 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Registration unit } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iadoreg; + +{$i fs.inc} + +interface + + +procedure Register; + +implementation + +uses + Classes +{$IFNDEF Delphi6} +, DsgnIntf +{$ELSE} +, DesignIntf +{$ENDIF} +, fs_iadortti; + +{-----------------------------------------------------------------------} + +procedure Register; +begin + RegisterComponents('FastScript', [TfsADORTTI]); +end; + +end. diff --git a/official/4.8.11/FastScript/fs_iadortti.pas b/official/4.8.11/FastScript/fs_iadortti.pas new file mode 100644 index 0000000..cf204c9 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iadortti.pas @@ -0,0 +1,126 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ ADO classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iadortti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_idbrtti, + DB, ADODB, ADOInt; + +type + TfsADORTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddType('TDataType', fvtInt); + AddClass(TADOConnection, 'TComponent'); + AddClass(TParameter, 'TCollectionItem'); + with AddClass(TParameters, 'TCollection') do + begin + AddMethod('function AddParameter: TParameter', CallMethod); + AddDefaultProperty('Items', 'Integer', 'TParameter', CallMethod, True); + end; + with AddClass(TCustomADODataSet, 'TDataSet') do + begin + AddProperty('Sort', 'WideString', GetProp, SetProp); + end; + AddClass(TADOTable, 'TCustomADODataSet'); + with AddClass(TADOQuery, 'TCustomADODataSet') do + AddMethod('procedure ExecSQL', CallMethod); + with AddClass(TADOStoredProc, 'TCustomADODataSet') do + AddMethod('procedure ExecProc', CallMethod); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TParameters then + begin + if MethodName = 'ADDPARAMETER' then + Result := Integer(TParameters(Instance).AddParameter) + else if MethodName = 'ITEMS.GET' then + Result := Integer(TParameters(Instance).Items[Caller.Params[0]]) + end + else if ClassType = TADOQuery then + begin + if MethodName = 'EXECSQL' then + TADOQuery(Instance).ExecSQL + end + else if ClassType = TADOStoredProc then + begin + if MethodName = 'EXECPROC' then + TADOStoredProc(Instance).ExecProc + end +end; + + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TCustomADODataSet then + begin + if PropName = 'SORT' then + Result := TCustomADODataSet(Instance).Sort; + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + + if ClassType = TCustomADODataSet then + begin + if PropName = 'SORT' then + TCustomADODataSet(Instance).Sort := Value; + end + +end; + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. + diff --git a/official/4.8.11/FastScript/fs_ibasic.pas b/official/4.8.11/FastScript/fs_ibasic.pas new file mode 100644 index 0000000..48e3a50 --- /dev/null +++ b/official/4.8.11/FastScript/fs_ibasic.pas @@ -0,0 +1,171 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Basic grammar } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ibasic; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_itools; + +type + TfsBasic = class(TComponent); + + +implementation + +const + BASIC_GRAMMAR = + '' + + '<' + + '/keywords>' + + '<' + + 'string add="file" err="err1"/><' + + 'char text="(" add="op"/><' + + '/sequence>' + + '' + + '<' + + 'keyword text="OR" add="op" addtext="or"/><' + + 'char text="[" add="node"/>' + + '<' + + 'sequence><' + + '/sequence><' + + 'caseselector/><' + + 'optional>' + + '<' + + 'keyword text="FINALLY"/>'; + + +initialization + fsRegisterLanguage('BasicScript', BASIC_GRAMMAR); + +end. diff --git a/official/4.8.11/FastScript/fs_ibdereg.pas b/official/4.8.11/FastScript/fs_ibdereg.pas new file mode 100644 index 0000000..515b5da --- /dev/null +++ b/official/4.8.11/FastScript/fs_ibdereg.pas @@ -0,0 +1,39 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Registration unit } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ibdereg; + +{$i fs.inc} + +interface + + +procedure Register; + +implementation + +uses + Classes +{$IFNDEF Delphi6} +, DsgnIntf +{$ELSE} +, DesignIntf +{$ENDIF} +, fs_ibdertti; + +{-----------------------------------------------------------------------} + +procedure Register; +begin + RegisterComponents('FastScript', [TfsBDERTTI]); +end; + +end. diff --git a/official/4.8.11/FastScript/fs_ibdertti.pas b/official/4.8.11/FastScript/fs_ibdertti.pas new file mode 100644 index 0000000..f1c0782 --- /dev/null +++ b/official/4.8.11/FastScript/fs_ibdertti.pas @@ -0,0 +1,164 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ BDE classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ibdertti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_idbrtti, + DB, DBTables; + +type + TfsBDERTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnum('TTableType', 'ttDefault, ttParadox, ttDBase, ttFoxPro, ttASCII'); + AddEnum('TParamBindMode', 'pbByName, pbByNumber'); + + AddClass(TSession, 'TComponent'); + AddClass(TDatabase, 'TComponent'); + AddClass(TBDEDataSet, 'TDataSet'); + AddClass(TDBDataSet, 'TBDEDataSet'); + with AddClass(TTable, 'TDBDataSet') do + begin + AddMethod('procedure CreateTable', CallMethod); + AddMethod('procedure DeleteTable', CallMethod); + AddMethod('procedure EmptyTable', CallMethod); + AddMethod('function FindKey(const KeyValues: array): Boolean', CallMethod); + AddMethod('procedure FindNearest(const KeyValues: array)', CallMethod); + AddMethod('procedure RenameTable(const NewTableName: string)', CallMethod); + end; + with AddClass(TQuery, 'TDBDataSet') do + begin + AddMethod('procedure ExecSQL', CallMethod); + AddMethod('function ParamByName(const Value: string): TParam', CallMethod); + AddMethod('procedure Prepare', CallMethod); + AddProperty('ParamCount', 'Word', GetProp, nil); + end; + with AddClass(TStoredProc, 'TDBDataSet') do + begin + AddMethod('procedure ExecProc', CallMethod); + AddMethod('function ParamByName(const Value: string): TParam', CallMethod); + AddMethod('procedure Prepare', CallMethod); + AddProperty('ParamCount', 'Word', GetProp, nil); + end; + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + + function DoFindKey: Boolean; + var + ar: TVarRecArray; + begin + VariantToVarRec(Caller.Params[0], ar); + Result := TTable(Instance).FindKey(ar); + ClearVarRec(ar); + end; + + procedure DoFindNearest; + var + ar: TVarRecArray; + begin + VariantToVarRec(Caller.Params[0], ar); + TTable(Instance).FindNearest(ar); + ClearVarRec(ar); + end; + +begin + Result := 0; + + if ClassType = TTable then + begin + if MethodName = 'CREATETABLE' then + TTable(Instance).CreateTable + else if MethodName = 'DELETETABLE' then + TTable(Instance).DeleteTable + else if MethodName = 'EMPTYTABLE' then + TTable(Instance).EmptyTable + else if MethodName = 'FINDKEY' then + Result := DoFindKey + else if MethodName = 'FINDNEAREST' then + DoFindNearest + else if MethodName = 'RENAMETABLE' then + TTable(Instance).RenameTable(Caller.Params[0]) + end + else if ClassType = TQuery then + begin + if MethodName = 'EXECSQL' then + TQuery(Instance).ExecSQL + else if MethodName = 'PARAMBYNAME' then + Result := Integer(TQuery(Instance).ParamByName(Caller.Params[0])) + else if MethodName = 'PREPARE' then + TQuery(Instance).Prepare + end + else if ClassType = TStoredProc then + begin + if MethodName = 'EXECPROC' then + TStoredProc(Instance).ExecProc + else if MethodName = 'PARAMBYNAME' then + Result := Integer(TStoredProc(Instance).ParamByName(Caller.Params[0])) + else if MethodName = 'PREPARE' then + TStoredProc(Instance).Prepare + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TQuery then + begin + if PropName = 'PARAMCOUNT' then + Result := TQuery(Instance).ParamCount + end + else if ClassType = TStoredProc then + begin + if PropName = 'PARAMCOUNT' then + Result := TStoredProc(Instance).ParamCount + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_ichartrtti.pas b/official/4.8.11/FastScript/fs_ichartrtti.pas new file mode 100644 index 0000000..1765828 --- /dev/null +++ b/official/4.8.11/FastScript/fs_ichartrtti.pas @@ -0,0 +1,172 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Chart } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ichartrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_iformsrtti, Chart, + Series, TeEngine, TeeProcs, TeCanvas; + + +type + TfsChartRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddType('TChartValue', fvtFloat); + AddEnum('TLegendStyle', 'lsAuto, lsSeries, lsValues, lsLastValues'); + AddEnum('TLegendAlignment', 'laLeft, laRight, laTop, laBottom'); + AddEnum('TLegendTextStyle', 'ltsPlain, ltsLeftValue, ltsRightValue, ltsLeftPercent,' + + 'ltsRightPercent, ltsXValue'); + AddEnum('TChartListOrder', 'loNone, loAscending, loDescending'); + AddEnum('TGradientDirection', 'gdTopBottom, gdBottomTop, gdLeftRight, gdRightLeft'); + AddEnum('TSeriesMarksStyle', 'smsValue, smsPercent, smsLabel, smsLabelPercent, ' + + 'smsLabelValue, smsLegend, smsPercentTotal, smsLabelPercentTotal, smsXValue'); + AddEnum('TAxisLabelStyle', 'talAuto, talNone, talValue, talMark, talText'); + AddEnum('THorizAxis', 'aTopAxis, aBottomAxis'); + AddEnum('TVertAxis', 'aLeftAxis, aRightAxis'); + AddEnum('TTeeBackImageMode', 'pbmStretch, pbmTile, pbmCenter'); + AddEnum('TPanningMode', 'pmNone, pmHorizontal, pmVertical, pmBoth'); + AddEnum('TSeriesPointerStyle', 'psRectangle, psCircle, psTriangle, ' + + 'psDownTriangle, psCross, psDiagCross, psStar, psDiamond, psSmallDot'); + AddEnum('TMultiArea', 'maNone, maStacked, maStacked100'); + AddEnum('TMultiBar', 'mbNone, mbSide, mbStacked, mbStacked100'); + AddEnum('TBarStyle', 'bsRectangle, bsPyramid, bsInvPyramid, bsCilinder, ' + + 'bsEllipse, bsArrow, bsRectGradient'); + + AddEnum('TPenEndStyle', 'esRound, esSquare, esFlat'); + AddEnum('TPenMode', 'pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy, ' + + 'pmMergePenNot, pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge, ' + + 'pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor'); + AddEnum('TPenStyle', 'psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame'); + AddClass(TChartValueList, 'TPersistent'); + AddClass(TChartAxisTitle, 'TPersistent'); + AddClass(TChartAxis, 'TPersistent'); + AddClass(TCustomChartLegend, 'TPersistent'); + AddClass(TChartLegend, 'TCustomChartLegend'); + AddClass(TSeriesMarks, 'TPersistent'); + AddClass(TChartGradient, 'TPersistent'); + AddClass(TChartWall, 'TPersistent'); + AddClass(TChartBrush, 'TBrush'); + AddClass(TChartTitle, 'TPersistent'); + AddClass(TView3DOptions, 'TPersistent'); + AddClass(TChartPen, 'TComponent'); + with AddClass(TChartSeries, 'TComponent') do + begin + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Index: Integer)', CallMethod); + AddMethod('function Count: Integer', CallMethod); + AddMethod('procedure Add(const AValue: Double; const ALabel: String; AColor: TColor)', CallMethod); + AddProperty('Active','Boolean', GetProp, SetProp); + end; + AddClass(TSeriesPointer, 'TPersistent'); + AddClass(TCustomSeries, 'TChartSeries'); + AddClass(TLineSeries, 'TCustomSeries'); + AddClass(TPointSeries, 'TCustomSeries'); + AddClass(TAreaSeries, 'TCustomSeries'); + with AddClass(TCustomBarSeries, 'TChartSeries') do + begin + AddProperty('Title','String', GetProp, SetProp); + end; + AddClass(TBarSeries, 'TCustomBarSeries'); + AddClass(THorizBarSeries, 'TCustomBarSeries'); + AddClass(TCircledSeries, 'TChartSeries'); + AddClass(TPieSeries, 'TCircledSeries'); + AddClass(TFastLineSeries, 'TChartSeries'); + AddClass(TCustomChart, 'TWinControl'); + AddClass(TChart, 'TCustomChart'); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TChartSeries then + begin + if MethodName = 'CLEAR' then + TChartSeries(Instance).Clear + else if MethodName = 'ADD' then + TChartSeries(Instance).Add(Caller.Params[0], String(Caller.Params[1]), Caller.Params[2]) + else if MethodName = 'DELETE' then + TChartSeries(Instance).Delete(Caller.Params[0]) + else if MethodName = 'COUNT' then + Result := TChartSeries(Instance).Count + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TChartSeries then + begin + if PropName = 'ACTIVE' then + Result := TChartSeries(Instance).Active + end else + if ClassType = TCustomBarSeries then + begin + if PropName = 'Title' then + Result := TCustomBarSeries(Instance).Title + end; +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + if ClassType = TChartSeries then + begin + if PropName = 'ACTIVE' then + TChartSeries(Instance).Active := Value + end else + if ClassType = TCustomBarSeries then + begin + if PropName = 'Title' then + TCustomBarSeries(Instance).Title := Value + end +end; + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iclassesrtti.pas b/official/4.8.11/FastScript/fs_iclassesrtti.pas new file mode 100644 index 0000000..c8523fe --- /dev/null +++ b/official/4.8.11/FastScript/fs_iclassesrtti.pas @@ -0,0 +1,476 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Classes.pas classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iclassesrtti; + +interface + +{$i fs.inc} + +uses SysUtils, Classes, fs_iinterpreter, fs_xml; + +type + TfsClassesRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddConst('fmCreate', 'Integer', fmCreate); + AddConst('fmOpenRead', 'Integer', fmOpenRead); + AddConst('fmOpenWrite', 'Integer', fmOpenWrite); + AddConst('fmOpenReadWrite', 'Integer', fmOpenReadWrite); + AddConst('fmShareExclusive', 'Integer', fmShareExclusive); + AddConst('fmShareDenyWrite', 'Integer', fmShareDenyWrite); + AddConst('fmShareDenyNone', 'Integer', fmShareDenyNone); + AddConst('soFromBeginning', 'Integer', soFromBeginning); + AddConst('soFromCurrent', 'Integer', soFromCurrent); + AddConst('soFromEnd', 'Integer', soFromEnd); + AddEnum('TDuplicates', 'dupIgnore, dupAccept, dupError'); + AddEnum('TPrinterOrientation', 'poPortrait, poLandscape'); + + with AddClass(TObject, '') do + begin + AddConstructor('constructor Create', CallMethod); + AddMethod('procedure Free', CallMethod); + AddMethod('function ClassName: String', CallMethod); + end; + with AddClass(TPersistent, 'TObject') do + AddMethod('procedure Assign(Source: TPersistent)', CallMethod); + AddClass(TCollectionItem, 'TPersistent'); + with AddClass(TCollection, 'TPersistent') do + begin + AddMethod('procedure Clear', CallMethod); + AddProperty('Count', 'Integer', GetProp, nil); + AddDefaultProperty('Items', 'Integer', 'TCollectionItem', CallMethod, True); + end; + with AddClass(TList, 'TObject') do + begin + AddMethod('function Add(Item: TObject): Integer', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Index: Integer)', CallMethod); + AddMethod('function IndexOf(Item: TObject): Integer', CallMethod); + AddMethod('procedure Insert(Index: Integer; Item: TObject)', CallMethod); + AddMethod('function Remove(Item: TObject): Integer', CallMethod); + AddProperty('Count', 'Integer', GetProp, nil); + AddDefaultProperty('Items', 'Integer', 'TObject', CallMethod); + end; + with AddClass(TStrings, 'TPersistent') do + begin + AddMethod('function Add(const S: string): Integer', CallMethod); + AddMethod('function AddObject(const S: string; AObject: TObject): Integer', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Index: Integer)', CallMethod); + AddMethod('function IndexOf(const S: string): Integer', CallMethod); + AddMethod('function IndexOfName(const Name: string): Integer', CallMethod); + AddMethod('function IndexOfObject(AObject: TObject): Integer', CallMethod); + AddMethod('procedure Insert(Index: Integer; const S: string)', CallMethod); + AddMethod('procedure InsertObject(Index: Integer; const S: string; AObject: TObject)', CallMethod); + AddMethod('procedure LoadFromFile(const FileName: string)', CallMethod); + AddMethod('procedure LoadFromStream(Stream: TStream)', CallMethod); + AddMethod('procedure SaveToFile(const FileName: string)', CallMethod); + AddMethod('procedure Move(CurIndex, NewIndex: Integer)', CallMethod); + AddMethod('procedure SaveToStream(Stream: TStream)', CallMethod); + + AddProperty('CommaText', 'string', GetProp, SetProp); + AddProperty('Count', 'Integer', GetProp, nil); + AddIndexProperty('Names', 'Integer', 'string', CallMethod, True); + AddIndexProperty('Objects', 'Integer', 'TObject', CallMethod); + AddIndexProperty('Values', 'String', 'string', CallMethod); + AddDefaultProperty('Strings', 'Integer', 'string', CallMethod); + AddProperty('Text', 'string', GetProp, SetProp); + end; + with AddClass(TStringList, 'TStrings') do + begin + AddMethod('function Find(s: String; var Index: Integer): Boolean', CallMethod); + AddMethod('procedure Sort', CallMethod); + AddProperty('Duplicates', 'TDuplicates', GetProp, SetProp); + AddProperty('Sorted', 'Boolean', GetProp, SetProp); + end; + with AddClass(TStream, 'TObject') do + begin + AddMethod('function Read(var Buffer: string; Count: Longint): Longint', CallMethod); + AddMethod('function Write(Buffer: string; Count: Longint): Longint', CallMethod); + AddMethod('function Seek(Offset: Longint; Origin: Word): Longint', CallMethod); + AddMethod('function CopyFrom(Source: TStream; Count: Longint): Longint', CallMethod); + AddProperty('Position', 'Longint', GetProp, SetProp); + AddProperty('Size', 'Longint', GetProp, nil); + end; + with AddClass(TFileStream, 'TStream') do + AddConstructor('constructor Create(Filename: String; Mode: Word)', CallMethod); + with AddClass(TMemoryStream, 'TStream') do + begin + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure LoadFromStream(Stream: TStream)', CallMethod); + AddMethod('procedure LoadFromFile(Filename: String)', CallMethod); + AddMethod('procedure SaveToStream(Stream: TStream)', CallMethod); + AddMethod('procedure SaveToFile(Filename: String)', CallMethod); + end; + with AddClass(TComponent, 'TPersistent') do + begin + AddConstructor('constructor Create(AOwner: TComponent)', CallMethod); + AddProperty('Owner', 'TComponent', GetProp, nil); + end; + with AddClass(TfsXMLItem, 'TObject') do + begin + AddConstructor('constructor Create', CallMethod); + AddMethod('procedure AddItem(Item: TfsXMLItem)', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure InsertItem(Index: Integer; Item: TfsXMLItem)', CallMethod); + AddMethod('function Add: TfsXMLItem', CallMethod); + AddMethod('function Find(const Name: String): Integer', CallMethod); + AddMethod('function FindItem(const Name: String): TfsXMLItem', CallMethod); + AddMethod('function Root: TfsXMLItem', CallMethod); + AddProperty('Data', 'Integer', GetProp, SetProp); + AddProperty('Count', 'Integer', GetProp, nil); + AddDefaultProperty('Items', 'Integer', 'TfsXMLItem', CallMethod, True); + AddIndexProperty('Prop', 'String', 'String', CallMethod); + AddProperty('Name', 'String', GetProp, SetProp); + AddProperty('Parent', 'TfsXMLItem', GetProp, nil); + AddProperty('Text', 'String', GetProp, SetProp); + end; + with AddClass(TfsXMLDocument, 'TObject') do + begin + AddConstructor('constructor Create', CallMethod); + AddMethod('procedure SaveToStream(Stream: TStream)', CallMethod); + AddMethod('procedure LoadFromStream(Stream: TStream)', CallMethod); + AddMethod('procedure SaveToFile(const FileName: String)', CallMethod); + AddMethod('procedure LoadFromFile(const FileName: String)', CallMethod); + AddProperty('Root', 'TfsXMLItem', GetProp, nil); + end; + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +var + i: Integer; + s: String; + _TList: TList; + _TStrings: TStrings; + _TStream: TStream; + _TMemoryStream: TMemoryStream; + _TfsXMLItem: TfsXMLItem; + _TfsXMLDocument: TfsXMLDocument; +begin + Result := 0; + + if ClassType = TObject then + begin + if MethodName = 'CREATE' then + Result := Integer(Instance.Create) + else if MethodName = 'FREE' then + Instance.Free + else if MethodName = 'CLASSNAME' then + Result := Instance.ClassName + end + else if ClassType = TPersistent then + begin + if MethodName = 'ASSIGN' then + TPersistent(Instance).Assign(TPersistent(Integer(Caller.Params[0]))); + end + else if ClassType = TCollection then + begin + if MethodName = 'CLEAR' then + TCollection(Instance).Clear + else if MethodName = 'ITEMS.GET' then + Result := Integer(TCollection(Instance).Items[Caller.Params[0]]) + end + else if ClassType = TList then + begin + _TList := TList(Instance); + if MethodName = 'ADD' then + _TList.Add(Pointer(Integer(Caller.Params[0]))) + else if MethodName = 'CLEAR' then + _TList.Clear + else if MethodName = 'DELETE' then + _TList.Delete(Caller.Params[0]) + else if MethodName = 'INDEXOF' then + Result := _TList.IndexOf(Pointer(Integer(Caller.Params[0]))) + else if MethodName = 'INSERT' then + _TList.Insert(Caller.Params[0], Pointer(Integer(Caller.Params[1]))) + else if MethodName = 'REMOVE' then + _TList.Remove(Pointer(Integer(Caller.Params[0]))) + else if MethodName = 'ITEMS.GET' then + Result := Integer(_TList.Items[Caller.Params[0]]) + else if MethodName = 'ITEMS.SET' then + _TList.Items[Caller.Params[0]] := Pointer(Integer(Caller.Params[1])) + end + else if ClassType = TStrings then + begin + _TStrings := TStrings(Instance); + if MethodName = 'ADD' then + Result := _TStrings.Add(Caller.Params[0]) + else if MethodName = 'ADDOBJECT' then + Result := _TStrings.AddObject(Caller.Params[0], TObject(Integer(Caller.Params[1]))) + else if MethodName = 'CLEAR' then + _TStrings.Clear + else if MethodName = 'DELETE' then + _TStrings.Delete(Caller.Params[0]) + else if MethodName = 'INDEXOF' then + Result := _TStrings.IndexOf(Caller.Params[0]) + else if MethodName = 'INDEXOFNAME' then + Result := _TStrings.IndexOfName(Caller.Params[0]) + else if MethodName = 'INDEXOFOBJECT' then + Result := _TStrings.IndexOfObject(TObject(Integer(Caller.Params[0]))) + else if MethodName = 'INSERT' then + _TStrings.Insert(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'INSERTOBJECT' then + _TStrings.InsertObject(Caller.Params[0], Caller.Params[1], TObject(Integer(Caller.Params[2]))) + else if MethodName = 'LOADFROMFILE' then + _TStrings.LoadFromFile(Caller.Params[0]) + else if MethodName = 'LOADFROMSTREAM' then + _TStrings.LoadFromStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'MOVE' then + _TStrings.Move(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'SAVETOFILE' then + _TStrings.SaveToFile(Caller.Params[0]) + else if MethodName = 'SAVETOSTREAM' then + _TStrings.SaveToStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'NAMES.GET' then + Result := _TStrings.Names[Caller.Params[0]] + else if MethodName = 'OBJECTS.GET' then + Result := Integer(_TStrings.Objects[Caller.Params[0]]) + else if MethodName = 'OBJECTS.SET' then + _TStrings.Objects[Caller.Params[0]] := TObject(Integer(Caller.Params[1])) + else if MethodName = 'VALUES.GET' then + Result := _TStrings.Values[Caller.Params[0]] + else if MethodName = 'VALUES.SET' then + _TStrings.Values[Caller.Params[0]] := Caller.Params[1] + else if MethodName = 'STRINGS.GET' then + Result := _TStrings.Strings[Caller.Params[0]] + else if MethodName = 'STRINGS.SET' then + _TStrings.Strings[Caller.Params[0]] := Caller.Params[1] + end + else if ClassType = TStringList then + begin + if MethodName = 'FIND' then + begin + Result := TStringList(Instance).Find(Caller.Params[0], i); + Caller.Params[1] := i; + end + else if MethodName = 'SORT' then + TStringList(Instance).Sort + end + else if ClassType = TStream then + begin + _TStream := TStream(Instance); + if MethodName = 'READ' then + begin + SetLength(s, Integer(Caller.Params[1])); + Result := _TStream.Read(s[1], Caller.Params[1]); + SetLength(s, Integer(Result)); + Caller.Params[0] := s; + end + else if MethodName = 'WRITE' then + begin + s := Caller.Params[0]; + Result := _TStream.Write(s[1], Caller.Params[1]); + end + else if MethodName = 'SEEK' then + Result := _TStream.Seek(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'COPYFROM' then + Result := _TStream.CopyFrom(TStream(Integer(Caller.Params[0])), Caller.Params[1]) + end + else if ClassType = TFileStream then + begin + if MethodName = 'CREATE' then + Result := Integer(TFileStream(Instance).Create(Caller.Params[0], Caller.Params[1])) + end + else if ClassType = TMemoryStream then + begin + _TMemoryStream := TMemoryStream(Instance); + if MethodName = 'CLEAR' then + _TMemoryStream.Clear + else if MethodName = 'LOADFROMSTREAM' then + _TMemoryStream.LoadFromStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'LOADFROMFILE' then + _TMemoryStream.LoadFromFile(Caller.Params[0]) + else if MethodName = 'SAVETOSTREAM' then + _TMemoryStream.SaveToStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'SAVETOFILE' then + _TMemoryStream.SaveToFile(Caller.Params[0]) + end + else if ClassType = TComponent then + begin + if MethodName = 'CREATE' then + Result := Integer(TComponent(Instance).Create(TComponent(Integer(Caller.Params[0])))) + end + else if ClassType = TfsXMLItem then + begin + _TfsXMLItem := TfsXMLItem(Instance); + if MethodName = 'CREATE' then + Result := Integer(_TfsXMLItem.Create) + else if MethodName = 'ADDITEM' then + _TfsXMLItem.AddItem(TfsXMLItem(Integer(Caller.Params[0]))) + else if MethodName = 'CLEAR' then + _TfsXMLItem.Clear + else if MethodName = 'INSERTITEM' then + _TfsXMLItem.InsertItem(Caller.Params[0], TfsXMLItem(Integer(Caller.Params[1]))) + else if MethodName = 'ADD' then + Result := Integer(_TfsXMLItem.Add) + else if MethodName = 'FIND' then + Result := _TfsXMLItem.Find(Caller.Params[0]) + else if MethodName = 'FINDITEM' then + Result := Integer(_TfsXMLItem.FindItem(Caller.Params[0])) + else if MethodName = 'PROP.GET' then + Result := _TfsXMLItem.Prop[Caller.Params[0]] + else if MethodName = 'PROP.SET' then + _TfsXMLItem.Prop[Caller.Params[0]] := Caller.Params[1] + else if MethodName = 'ROOT' then + Result := Integer(_TfsXMLItem.Root) + else if MethodName = 'ROOT' then + Result := Integer(_TfsXMLItem.Root) + else if MethodName = 'ITEMS.GET' then + Result := Integer(_TfsXMLItem[Caller.Params[0]]) + end + else if ClassType = TfsXMLDocument then + begin + _TfsXMLDocument := TfsXMLDocument(Instance); + if MethodName = 'CREATE' then + Result := Integer(_TfsXMLDocument.Create) + else if MethodName = 'SAVETOSTREAM' then + _TfsXMLDocument.SaveToStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'LOADFROMSTREAM' then + _TfsXMLDocument.LoadFromStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'SAVETOFILE' then + _TfsXMLDocument.SaveToFile(Caller.Params[0]) + else if MethodName = 'LOADFROMFILE' then + _TfsXMLDocument.LoadFromFile(Caller.Params[0]) + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TCollection then + begin + if PropName = 'COUNT' then + Result := TCollection(Instance).Count + end + else if ClassType = TList then + begin + if PropName = 'COUNT' then + Result := TList(Instance).Count + end + else if ClassType = TStrings then + begin + if PropName = 'COMMATEXT' then + Result := TStrings(Instance).CommaText + else if PropName = 'COUNT' then + Result := TStrings(Instance).Count + else if PropName = 'TEXT' then + Result := TStrings(Instance).Text + end + else if ClassType = TStringList then + begin + if PropName = 'DUPLICATES' then + Result := TStringList(Instance).Duplicates + else if PropName = 'SORTED' then + Result := TStringList(Instance).Sorted + end + else if ClassType = TStream then + begin + if PropName = 'POSITION' then + Result := TStream(Instance).Position + else if PropName = 'SIZE' then + Result := TStream(Instance).Size + end + else if ClassType = TComponent then + begin + if PropName = 'OWNER' then + Result := Integer(TComponent(Instance).Owner) + end + else if ClassType = TfsXMLItem then + begin + if PropName = 'DATA' then + Result := Integer(TfsXMLItem(Instance).Data) + else if PropName = 'COUNT' then + Result := TfsXMLItem(Instance).Count + else if PropName = 'NAME' then + Result := TfsXMLItem(Instance).Name + else if PropName = 'PARENT' then + Result := Integer(TfsXMLItem(Instance).Parent) + else if PropName = 'TEXT' then + Result := TfsXMLItem(Instance).Text + end + else if ClassType = TfsXMLDocument then + begin + if PropName = 'ROOT' then + Result := Integer(TfsXMLDocument(Instance).Root) + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + if ClassType = TStrings then + begin + if PropName = 'COMMATEXT' then + TStrings(Instance).CommaText := Value + else if PropName = 'TEXT' then + TStrings(Instance).Text := Value + end + else if ClassType = TStringList then + begin + if PropName = 'DUPLICATES' then + TStringList(Instance).Duplicates := Value + else if PropName = 'SORTED' then + TStringList(Instance).Sorted := Value + end + else if ClassType = TStream then + begin + if PropName = 'POSITION' then + TStream(Instance).Position := Value + end + else if ClassType = TfsXMLItem then + begin + if PropName = 'DATA' then + TfsXMLItem(Instance).Data := Pointer(Integer(Value)) + else if PropName = 'NAME' then + TfsXMLItem(Instance).Name := Value + else if PropName = 'TEXT' then + TfsXMLItem(Instance).Text := Value + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iconst.pas b/official/4.8.11/FastScript/fs_iconst.pas new file mode 100644 index 0000000..bbcdd0e --- /dev/null +++ b/official/4.8.11/FastScript/fs_iconst.pas @@ -0,0 +1,59 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Resources } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iconst; + +interface + +{$i fs.inc} + +var + SLangNotFound: String; + SInvalidLanguage: String; + SIdRedeclared: String; + SUnknownType: String; + SIncompatibleTypes: String; + SIdUndeclared: String; + SClassRequired: String; + SIndexRequired: String; + SStringError: String; + SClassError: String; + SArrayRequired: String; + SVarRequired: String; + SNotEnoughParams: String; + STooManyParams: String; + SLeftCantAssigned: String; + SForError: String; + SEventError: String; + + +implementation + +initialization + SLangNotFound := 'Language ''%s'' not found'; + SInvalidLanguage := 'Invalid language definition'; + SIdRedeclared := 'Identifier redeclared: '; + SUnknownType := 'Unknown type: '; + SIncompatibleTypes := 'Incompatible types'; + SIdUndeclared := 'Undeclared identifier: '; + SClassRequired := 'Class type required'; + SIndexRequired := 'Index required'; + SStringError := 'Strings doesn''t have properties or methods'; + SClassError := 'Class %s does not have a default property'; + SArrayRequired := 'Array type required'; + SVarRequired := 'Variable required'; + SNotEnoughParams := 'Not enough actual parameters'; + STooManyParams := 'Too many actual parameters'; + SLeftCantAssigned := 'Left side cannot be assigned to'; + SForError := 'For loop variable must be numeric variable'; + SEventError := 'Event handler must be a procedure'; + +end. diff --git a/official/4.8.11/FastScript/fs_icpp.pas b/official/4.8.11/FastScript/fs_icpp.pas new file mode 100644 index 0000000..c657b4b --- /dev/null +++ b/official/4.8.11/FastScript/fs_icpp.pas @@ -0,0 +1,160 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ C++ grammar } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_icpp; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_itools; + +type + TfsCPP = class(TComponent); + + +implementation + +const + CPP_GRAMMAR = + '' + + '' + + '<' + + 'err20 text="''>'' expected"/>' + + '' + + '' + + '<' + + 'sequence>' + + '<' + + 'sequence>' + + '' + + '' + + '' + + ''; + + +initialization + fsRegisterLanguage('C++Script', CPP_GRAMMAR); + +end. diff --git a/official/4.8.11/FastScript/fs_idbctrlsrtti.pas b/official/4.8.11/FastScript/fs_idbctrlsrtti.pas new file mode 100644 index 0000000..0948213 --- /dev/null +++ b/official/4.8.11/FastScript/fs_idbctrlsrtti.pas @@ -0,0 +1,182 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ DB controls } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_idbctrlsrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_iformsrtti, fs_idbrtti, DB +{$IFDEF CLX} +, QDBCtrls, QDBGrids +{$ELSE} +, DBCtrls, DBGrids +{$ENDIF}; + + +type + TfsDBCtrlsRTTI = class(TComponent); // fake component + + +implementation + +type +{$IFNDEF FPC} + THackDBLookupControl = class(TDBLookupControl); +{$ENDIF} + + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnumSet('TButtonSet', 'nbFirst, nbPrior, nbNext, nbLast,' + + 'nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh'); + AddEnum('TColumnButtonStyle', 'cbsAuto, cbsEllipsis, cbsNone'); + AddEnumSet('TDBGridOptions', 'dgEditing, dgAlwaysShowEditor, dgTitles,' + + 'dgIndicator, dgColumnResize, dgColLines, dgRowLines, dgTabs, dgRowSelect,' + + 'dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit, dgMultiSelect'); + + AddClass(TDBEdit, 'TWinControl'); + AddClass(TDBText, 'TGraphicControl'); + with AddClass(TDBCheckBox, 'TWinControl') do + AddProperty('Checked', 'Boolean', GetProp, nil); + with AddClass(TDBComboBox, 'TCustomComboBox') do + AddProperty('Text', 'String', GetProp, nil); + AddClass(TDBListBox, 'TCustomListBox'); + with AddClass(TDBRadioGroup, 'TWinControl') do + begin + AddProperty('ItemIndex', 'Integer', GetProp, nil); + AddProperty('Value', 'String', GetProp, nil); + end; + AddClass(TDBMemo, 'TWinControl'); + AddClass(TDBImage, 'TCustomControl'); + AddClass(TDBNavigator, 'TWinControl'); +{$IFNDEF FPC} + with AddClass(TDBLookupControl, 'TCustomControl') do + AddProperty('KeyValue', 'Variant', GetProp, SetProp); + with AddClass(TDBLookupListBox, 'TDBLookupControl') do + AddProperty('SelectedItem', 'String', GetProp, nil); + with AddClass(TDBLookupComboBox, 'TDBLookupControl') do + AddProperty('Text', 'String', GetProp, nil); +{$ENDIF} + AddClass(TColumnTitle, 'TPersistent'); + AddClass(TColumn, 'TPersistent'); + with AddClass(TDBGridColumns, 'TCollection') do + begin + AddMethod('function Add: TColumn', CallMethod); + AddMethod('procedure RebuildColumns', CallMethod); + AddMethod('procedure RestoreDefaults', CallMethod); + AddDefaultProperty('Items', 'Integer', 'TColumn', CallMethod, True); + end; + AddClass(TDBGrid, 'TWinControl'); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TDBGridColumns then + begin + if MethodName = 'ADD' then + Result := Integer(TDBGridColumns(Instance).Add) + else if MethodName = 'ITEMS.GET' then + Result := Integer(TDBGridColumns(Instance).Items[Caller.Params[0]]) +{$IFNDEF FPC} + else if MethodName = 'REBUILDCOLUMNS' then + TDBGridColumns(Instance).RebuildColumns + else if MethodName = 'RESTOREDEFAULTS' then + TDBGridColumns(Instance).RestoreDefaults +{$ENDIF} + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TDBCheckBox then + begin + if PropName = 'CHECKED' then + Result := TDBCheckBox(Instance).Checked + end + else if ClassType = TDBComboBox then + begin + if PropName = 'TEXT' then + Result := TDBComboBox(Instance).Text + end + else if ClassType = TDBRadioGroup then + begin + if PropName = 'ITEMINDEX' then + Result := TDBRadioGroup(Instance).ItemIndex + else if PropName = 'VALUE' then + Result := TDBRadioGroup(Instance).Value + end +{$IFNDEF FPC} + else if ClassType = TDBLookupControl then + begin + if PropName = 'KEYVALUE' then + Result := THackDBLookupControl(Instance).KeyValue + end + else if ClassType = TDBLookupListBox then + begin + if PropName = 'SELECTEDITEM' then + Result := TDBLookupListBox(Instance).SelectedItem + end + else if ClassType = TDBLookupComboBox then + begin + if PropName = 'TEXT' then + Result := TDBLookupComboBox(Instance).Text + end +{$ENDIF} +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin +{$IFNDEF FPC} + if ClassType = TDBLookupControl then + begin + if PropName = 'KEYVALUE' then + THackDBLookupControl(Instance).KeyValue := Value + end +{$ENDIF} +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_idbreg.pas b/official/4.8.11/FastScript/fs_idbreg.pas new file mode 100644 index 0000000..54d6231 --- /dev/null +++ b/official/4.8.11/FastScript/fs_idbreg.pas @@ -0,0 +1,39 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Registration unit } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_idbreg; + +{$i fs.inc} + +interface + + +procedure Register; + +implementation + +uses + Classes +{$IFNDEF Delphi6} +, DsgnIntf +{$ELSE} +, DesignIntf +{$ENDIF} +, fs_idbrtti, fs_idbctrlsrtti; + +{-----------------------------------------------------------------------} + +procedure Register; +begin + RegisterComponents('FastScript', [TfsDBRTTI, TfsDBCtrlsRTTI]); +end; + +end. diff --git a/official/4.8.11/FastScript/fs_idbrtti.pas b/official/4.8.11/FastScript/fs_idbrtti.pas new file mode 100644 index 0000000..8f12c97 --- /dev/null +++ b/official/4.8.11/FastScript/fs_idbrtti.pas @@ -0,0 +1,565 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ DB.pas classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_idbrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_iclassesrtti, fs_ievents, + DB; + +type + TfsDBRTTI = class(TComponent); // fake component + + TfsDatasetNotifyEvent = class(TfsCustomEvent) + public + procedure DoEvent(Dataset: TDataset); + function GetMethod: Pointer; override; + end; + + TfsFilterRecordEvent = class(TfsCustomEvent) + public + procedure DoEvent(DataSet: TDataSet; var Accept: Boolean); + function GetMethod: Pointer; override; + end; + + TfsFieldGetTextEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TField; var Text: String; DisplayText: Boolean); + function GetMethod: Pointer; override; + end; + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TfsDatasetNotifyEvent } + +procedure TfsDatasetNotifyEvent.DoEvent(Dataset: TDataset); +begin + CallHandler([Dataset]); +end; + +function TfsDatasetNotifyEvent.GetMethod: Pointer; +begin + Result := @TfsDatasetNotifyEvent.DoEvent; +end; + + +{ TfsFilterRecordEvent } + +procedure TfsFilterRecordEvent.DoEvent(DataSet: TDataSet; var Accept: Boolean); +begin + CallHandler([DataSet, Accept]); + Accept := Handler.Params[1].Value; +end; + +function TfsFilterRecordEvent.GetMethod: Pointer; +begin + Result := @TfsFilterRecordEvent.DoEvent; +end; + + +{ TfsFieldGetTextEvent } + +procedure TfsFieldGetTextEvent.DoEvent(Sender: TField; var Text: String; DisplayText: Boolean); +begin + CallHandler([Sender, Text, DisplayText]); + Text := Handler.Params[1].Value; +end; + +function TfsFieldGetTextEvent.GetMethod: Pointer; +begin + Result := @TfsFieldGetTextEvent.DoEvent; +end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnum('TFieldType', 'ftUnknown, ftString, ftSmallint, ftInteger, ftWord,' + + 'ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,' + + 'ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,' + + 'ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,' + + 'ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,' + + 'ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd'); + AddEnum('TBlobStreamMode', 'bmRead, bmWrite, bmReadWrite'); + AddEnumSet('TLocateOptions', 'loCaseInsensitive, loPartialKey'); + AddEnumSet('TFilterOptions', 'foCaseInsensitive, foNoPartialCompare'); + AddEnum('TParamType', 'ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult'); + + with AddClass(TField, 'TComponent') do + begin + AddProperty('AsBoolean', 'Boolean', GetProp, SetProp); + AddProperty('AsCurrency', 'Currency', GetProp, SetProp); + AddProperty('AsDateTime', 'TDateTime', GetProp, SetProp); + AddProperty('AsFloat', 'Double', GetProp, SetProp); + AddProperty('AsInteger', 'Integer', GetProp, SetProp); + AddProperty('AsString', 'String', GetProp, SetProp); + AddProperty('AsVariant', 'Variant', GetProp, SetProp); + AddProperty('DataType', 'TFieldType', GetProp, nil); + AddProperty('DisplayName', 'String', GetProp, nil); + AddProperty('DisplayText', 'String', GetProp, nil); + AddProperty('IsNull', 'Boolean', GetProp, nil); + AddProperty('Size', 'Integer', GetProp, SetProp); + AddProperty('Value', 'Variant', GetProp, SetProp); + AddProperty('OldValue', 'Variant', GetProp, nil); + AddEvent('OnGetText', TfsFieldGetTextEvent); + end; + with AddClass(TFields, 'TObject') do + AddDefaultProperty('Fields', 'Integer', 'TField', CallMethod, True); + AddClass(TStringField, 'TField'); + AddClass(TNumericField, 'TField'); + AddClass(TIntegerField, 'TNumericField'); + AddClass(TSmallIntField, 'TIntegerField'); + AddClass(TWordField, 'TIntegerField'); + AddClass(TAutoIncField, 'TIntegerField'); + AddClass(TFloatField, 'TNumericField'); + AddClass(TCurrencyField, 'TFloatField'); + AddClass(TBooleanField, 'TField'); + AddClass(TDateTimeField, 'TField'); + AddClass(TDateField, 'TDateTimeField'); + AddClass(TTimeField, 'TDateTimeField'); + AddClass(TBinaryField, 'TField'); + AddClass(TBytesField, 'TBinaryField'); + AddClass(TVarBytesField, 'TBinaryField'); + AddClass(TBCDField, 'TNumericField'); + with AddClass(TBlobField, 'TField') do + begin + AddMethod('procedure LoadFromFile(const FileName: String)', CallMethod); + AddMethod('procedure LoadFromStream(Stream: TStream)', CallMethod); + AddMethod('procedure SaveToFile(const FileName: String)', CallMethod); + AddMethod('procedure SaveToStream(Stream: TStream)', CallMethod); + end; + AddClass(TMemoField, 'TBlobField'); + AddClass(TGraphicField, 'TBlobField'); + AddClass(TFieldDef, 'TPersistent'); + with AddClass(TFieldDefs, 'TObject') do + begin + AddMethod('function AddFieldDef: TFieldDef', CallMethod); + AddMethod('function Find(const Name: string): TFieldDef', CallMethod); + AddMethod('procedure Add(const Name: string; DataType: TFieldType; Size: Word; Required: Boolean)', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Update', CallMethod); + AddDefaultProperty('Items', 'Integer', 'TFieldDef', CallMethod, True); + end; + AddClass(TDataSource, 'TComponent'); + AddType('TBookmark', fvtVariant); + with AddClass(TDataSet, 'TComponent') do + begin + AddMethod('procedure Open', CallMethod); + AddMethod('procedure Close', CallMethod); + AddMethod('procedure First', CallMethod); + AddMethod('procedure Last', CallMethod); + AddMethod('procedure Next', CallMethod); + AddMethod('procedure Prior', CallMethod); + AddMethod('procedure Cancel', CallMethod); + AddMethod('procedure Delete', CallMethod); + AddMethod('procedure Post', CallMethod); + AddMethod('procedure Append', CallMethod); + AddMethod('procedure Insert', CallMethod); + AddMethod('procedure Edit', CallMethod); + + AddMethod('function FieldByName(const FieldName: string): TField', CallMethod); + AddMethod('procedure GetFieldNames(List: TStrings)', CallMethod); + AddMethod('function FindFirst: Boolean', CallMethod); + AddMethod('function FindLast: Boolean', CallMethod); + AddMethod('function FindNext: Boolean', CallMethod); + AddMethod('function FindPrior: Boolean', CallMethod); + AddMethod('procedure FreeBookmark(Bookmark: TBookmark)', CallMethod); + AddMethod('function GetBookmark: TBookmark', CallMethod); + AddMethod('procedure GotoBookmark(Bookmark: TBookmark)', CallMethod); + AddMethod('function Locate(const KeyFields: string; const KeyValues: Variant;' + + 'Options: TLocateOptions): Boolean', CallMethod); + AddMethod('function IsEmpty: Boolean', CallMethod); + AddMethod('procedure EnableControls', CallMethod); + AddMethod('procedure DisableControls', CallMethod); + + AddProperty('Bof', 'Boolean', GetProp, nil); + AddProperty('Eof', 'Boolean', GetProp, nil); + AddProperty('FieldCount', 'Integer', GetProp, nil); + AddProperty('FieldDefs', 'TFieldDefs', GetProp, nil); + AddProperty('Fields', 'TFields', GetProp, nil); + AddProperty('Filter', 'string', GetProp, SetProp); + AddProperty('Filtered', 'Boolean', GetProp, SetProp); + AddProperty('FilterOptions', 'TFilterOptions', GetProp, SetProp); + AddProperty('Active', 'Boolean', GetProp, SetProp); + + AddEvent('BeforeOpen', TfsDatasetNotifyEvent); + AddEvent('AfterOpen', TfsDatasetNotifyEvent); + AddEvent('BeforeClose', TfsDatasetNotifyEvent); + AddEvent('AfterClose', TfsDatasetNotifyEvent); + AddEvent('BeforeInsert', TfsDatasetNotifyEvent); + AddEvent('AfterInsert', TfsDatasetNotifyEvent); + AddEvent('BeforeEdit', TfsDatasetNotifyEvent); + AddEvent('AfterEdit', TfsDatasetNotifyEvent); + AddEvent('BeforePost', TfsDatasetNotifyEvent); + AddEvent('AfterPost', TfsDatasetNotifyEvent); + AddEvent('BeforeCancel', TfsDatasetNotifyEvent); + AddEvent('AfterCancel', TfsDatasetNotifyEvent); + AddEvent('BeforeDelete', TfsDatasetNotifyEvent); + AddEvent('AfterDelete', TfsDatasetNotifyEvent); + AddEvent('BeforeScroll', TfsDatasetNotifyEvent); + AddEvent('AfterScroll', TfsDatasetNotifyEvent); + AddEvent('OnCalcFields', TfsDatasetNotifyEvent); + AddEvent('OnFilterRecord', TfsFilterRecordEvent); + AddEvent('OnNewRecord', TfsDatasetNotifyEvent); + end; + + with AddClass(TParam, 'TPersistent') do + begin + AddMethod('procedure Clear', CallMethod); + AddProperty('AsBoolean', 'Boolean', GetProp, SetProp); + AddProperty('AsCurrency', 'Currency', GetProp, SetProp); + AddProperty('AsDateTime', 'TDateTime', GetProp, SetProp); + AddProperty('AsFloat', 'Double', GetProp, SetProp); + AddProperty('AsInteger', 'Integer', GetProp, SetProp); + AddProperty('AsDate', 'TDate', GetProp, SetProp); + AddProperty('AsTime', 'TTime', GetProp, SetProp); + AddProperty('AsString', 'String', GetProp, SetProp); + AddProperty('Bound', 'Boolean', GetProp, SetProp); + AddProperty('IsNull', 'Boolean', GetProp, nil); + AddProperty('Text', 'String', GetProp, SetProp); + end; + with AddClass(TParams, 'TPersistent') do + begin + AddMethod('function ParamByName(const Value: string): TParam', CallMethod); + AddMethod('function FindParam(const Value: string): TParam', CallMethod); + AddDefaultProperty('Items', 'Integer', 'TParam', CallMethod, True); + end; + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +var + _TDataSet: TDataSet; + + function IntToLocateOptions(i: Integer): TLocateOptions; + begin + Result := []; + if (i and 1) <> 0 then + Result := Result + [loCaseInsensitive]; + if (i and 2) <> 0 then + Result := Result + [loPartialKey]; + end; + +begin + Result := 0; + + if ClassType = TFields then + begin + if MethodName = 'FIELDS.GET' then + Result := Integer(TFields(Instance)[Caller.Params[0]]) + end + else if ClassType = TFieldDefs then + begin + if MethodName = 'ITEMS.GET' then + Result := Integer(TFieldDefs(Instance)[Caller.Params[0]]) + else if MethodName = 'ADD' then + TFieldDefs(Instance).Add(Caller.Params[0], TFieldType(Caller.Params[1]), Caller.Params[2], Caller.Params[3]) + else if MethodName = 'ADDFIELDDEF' then + Result := Integer(TFieldDefs(Instance).AddFieldDef) + else if MethodName = 'CLEAR' then + TFieldDefs(Instance).Clear + else if MethodName = 'FIND' then + Result := Integer(TFieldDefs(Instance).Find(Caller.Params[0])) + else if MethodName = 'UPDATE' then + TFieldDefs(Instance).Update + end + else if ClassType = TBlobField then + begin + if MethodName = 'LOADFROMFILE' then + TBlobField(Instance).LoadFromFile(Caller.Params[0]) + else if MethodName = 'LOADFROMSTREAM' then + TBlobField(Instance).LoadFromStream(TStream(Integer(Caller.Params[0]))) + else if MethodName = 'SAVETOFILE' then + TBlobField(Instance).SaveToFile(Caller.Params[0]) + else if MethodName = 'SAVETOSTREAM' then + TBlobField(Instance).SaveToStream(TStream(Integer(Caller.Params[0]))) + end + else if ClassType = TDataSet then + begin + _TDataSet := TDataSet(Instance); + if MethodName = 'OPEN' then + _TDataSet.Open + else if MethodName = 'CLOSE' then + _TDataSet.Close + else if MethodName = 'FIRST' then + _TDataSet.First + else if MethodName = 'LAST' then + _TDataSet.Last + else if MethodName = 'NEXT' then + _TDataSet.Next + else if MethodName = 'PRIOR' then + _TDataSet.Prior + else if MethodName = 'CANCEL' then + _TDataSet.Cancel + else if MethodName = 'DELETE' then + _TDataSet.Delete + else if MethodName = 'POST' then + _TDataSet.Post + else if MethodName = 'APPEND' then + _TDataSet.Append + else if MethodName = 'INSERT' then + _TDataSet.Insert + else if MethodName = 'EDIT' then + _TDataSet.Edit + else if MethodName = 'FIELDBYNAME' then + Result := Integer(_TDataSet.FieldByName(Caller.Params[0])) + else if MethodName = 'GETFIELDNAMES' then + _TDataSet.GetFieldNames(TStrings(Integer(Caller.Params[0]))) + else if MethodName = 'FINDFIRST' then + Result := _TDataSet.FindFirst + else if MethodName = 'FINDLAST' then + Result := _TDataSet.FindLast + else if MethodName = 'FINDNEXT' then + Result := _TDataSet.FindNext + else if MethodName = 'FINDPRIOR' then + Result := _TDataSet.FindPrior + else if MethodName = 'FREEBOOKMARK' then + _TDataSet.FreeBookmark(TBookMark(Integer(Caller.Params[0]))) + else if MethodName = 'GETBOOKMARK' then + Result := Integer(_TDataSet.GetBookmark) + else if MethodName = 'GOTOBOOKMARK' then + _TDataSet.GotoBookmark(TBookMark(Integer(Caller.Params[0]))) + else if MethodName = 'LOCATE' then + Result := _TDataSet.Locate(Caller.Params[0], Caller.Params[1], IntToLocateOptions(Caller.Params[2])) + else if MethodName = 'ISEMPTY' then + Result := _TDataSet.IsEmpty + else if MethodName = 'ENABLECONTROLS' then + _TDataSet.EnableControls + else if MethodName = 'DISABLECONTROLS' then + _TDataSet.DisableControls + end + else if ClassType = TParam then + begin + if MethodName = 'CLEAR' then + TParam(Instance).Clear + end + else if ClassType = TParams then + begin + if MethodName = 'PARAMBYNAME' then + Result := Integer(TParams(Instance).ParamByName(Caller.Params[0])) + else if MethodName = 'FINDPARAM' then + Result := Integer(TParams(Instance).FindParam(Caller.Params[0])) + else if MethodName = 'ITEMS.GET' then + Result := Integer(TParams(Instance)[Caller.Params[0]]) + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +var + _TField: TField; + _TParam: TParam; + _TDataSet: TDataSet; + + function FilterOptionsToInt(f: TFilterOptions): Integer; + begin + Result := 0; + if foCaseInsensitive in f then + Result := Result or 1; + if foNoPartialCompare in f then + Result := Result or 2; + end; + +begin + Result := 0; + + if ClassType = TField then + begin + _TField := TField(Instance); + if PropName = 'ASBOOLEAN' then + Result := _TField.AsBoolean + else if PropName = 'ASCURRENCY' then + Result := _TField.AsCurrency + else if PropName = 'ASDATETIME' then + Result := _TField.AsDateTime + else if PropName = 'ASFLOAT' then + Result := _TField.AsFloat + else if PropName = 'ASINTEGER' then + Result := _TField.AsInteger + else if PropName = 'ASSTRING' then + Result := _TField.AsString + else if PropName = 'ASVARIANT' then + Result := _TField.AsVariant + else if PropName = 'DATATYPE' then + Result := _TField.DataType + else if PropName = 'DISPLAYNAME' then + Result := _TField.DisplayName + else if PropName = 'DISPLAYTEXT' then + Result := _TField.DisplayText + else if PropName = 'ISNULL' then + Result := _TField.IsNull + else if PropName = 'SIZE' then + Result := _TField.Size + else if PropName = 'VALUE' then + Result := _TField.Value + else if PropName = 'OLDVALUE' then + Result := _TField.OldValue + end + else if ClassType = TDataSet then + begin + _TDataSet := TDataSet(Instance); + if PropName = 'BOF' then + Result := _TDataSet.Bof + else if PropName = 'EOF' then + Result := _TDataSet.Eof + else if PropName = 'FIELDCOUNT' then + Result := _TDataSet.FieldCount + else if PropName = 'FIELDDEFS' then + Result := Integer(_TDataSet.FieldDefs) + else if PropName = 'FIELDS' then + Result := Integer(_TDataSet.Fields) + else if PropName = 'FILTER' then + Result := _TDataSet.Filter + else if PropName = 'FILTERED' then + Result := _TDataSet.Filtered + else if PropName = 'FILTEROPTIONS' then + Result := FilterOptionsToInt(_TDataSet.FilterOptions) + else if PropName = 'ACTIVE' then + Result := _TDataSet.Active + end + else if ClassType = TParam then + begin + _TParam := TParam(Instance); + if PropName = 'BOUND' then + Result := _TParam.Bound + else if PropName = 'ISNULL' then + Result := _TParam.IsNull + else if PropName = 'TEXT' then + Result := _TParam.Text + else if PropName = 'ASBOOLEAN' then + Result := _TParam.AsBoolean + else if PropName = 'ASCURRENCY' then + Result := _TParam.AsCurrency + else if PropName = 'ASDATETIME' then + Result := _TParam.AsDateTime + else if PropName = 'ASFLOAT' then + Result := _TParam.AsFloat + else if PropName = 'ASINTEGER' then + Result := _TParam.AsInteger + else if PropName = 'ASDATE' then + Result := _TParam.AsDate + else if PropName = 'ASTIME' then + Result := _TParam.AsTime + else if PropName = 'ASSTRING' then + Result := _TParam.AsString + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +var + _TField: TField; + _TParam: TParam; + _TDataSet: TDataSet; + + function IntToFilterOptions(i: Integer): TFilterOptions; + begin + Result := []; + if (i and 1) <> 0 then + Result := Result + [foCaseInsensitive]; + if (i and 2) <> 0 then + Result := Result + [foNoPartialCompare]; + end; + +begin + if ClassType = TField then + begin + _TField := TField(Instance); + if PropName = 'ASBOOLEAN' then + _TField.AsBoolean := Value + else if PropName = 'ASCURRENCY' then + _TField.AsCurrency := Value + else if PropName = 'ASDATETIME' then + _TField.AsDateTime := Value + else if PropName = 'ASFLOAT' then + _TField.AsFloat := Value + else if PropName = 'ASINTEGER' then + _TField.AsInteger := Value + else if PropName = 'ASSTRING' then + _TField.AsString := Value + else if PropName = 'ASVARIANT' then + _TField.AsVariant := Value + else if PropName = 'VALUE' then + _TField.Value := Value + else if PropName = 'SIZE' then + _TField.Size := Value + end + else if ClassType = TDataSet then + begin + _TDataSet := TDataSet(Instance); + if PropName = 'FILTER' then + _TDataSet.Filter := Value + else if PropName = 'FILTERED' then + _TDataSet.Filtered := Value + else if PropName = 'FILTEROPTIONS' then + _TDataSet.FilterOptions := IntToFilterOptions(Value) + else if PropName = 'ACTIVE' then + _TDataSet.Active := Value + end + else if ClassType = TParam then + begin + _TParam := TParam(Instance); + if PropName = 'ASBOOLEAN' then + _TParam.AsBoolean := Value + else if PropName = 'ASCURRENCY' then + _TParam.AsCurrency := Value + else if PropName = 'ASDATETIME' then + _TParam.AsDateTime := Value + else if PropName = 'ASFLOAT' then + _TParam.AsFloat := Value + else if PropName = 'ASINTEGER' then + _TParam.AsInteger := Value + else if PropName = 'ASDATE' then + _TParam.AsDate := Value + else if PropName = 'ASTIME' then + _TParam.AsTime := Value + else if PropName = 'ASSTRING' then + _TParam.AsString := Value + else if PropName = 'BOUND' then + _TParam.Bound := Value + else if PropName = 'TEXT' then + _TParam.Text := Value + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_idialogsrtti.pas b/official/4.8.11/FastScript/fs_idialogsrtti.pas new file mode 100644 index 0000000..2018f24 --- /dev/null +++ b/official/4.8.11/FastScript/fs_idialogsrtti.pas @@ -0,0 +1,157 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Dialogs.pas classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_idialogsrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_iclassesrtti +{$IFDEF CLX} +, QDialogs +{$ELSE} +, Dialogs +{$ENDIF}; + +type + TfsDialogsRTTI = class(TComponent); // fake component + + +implementation + +type +{$IFDEF CLX} + THackDialog = class(TDialog); +{$ELSE} + THackDialog = class(TCommonDialog); +{$ENDIF} + + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + +type + TWordSet = set of 0..15; + PWordSet = ^TWordSet; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +var + dlg: String; +begin + inherited Create(AScript); + with AScript do + begin + AddEnumSet('TOpenOptions', 'ofReadOnly, ofOverwritePrompt, ofHideReadOnly,' + + 'ofNoChangeDir, ofShowHelp, ofNoValidate, ofAllowMultiSelect,' + + 'ofExtensionDifferent, ofPathMustExist, ofFileMustExist, ofCreatePrompt,' + + 'ofShareAware, ofNoReadOnlyReturn, ofNoTestFileCreate, ofNoNetworkButton,' + + 'ofNoLongNames, ofOldStyleDialog, ofNoDereferenceLinks, ofEnableIncludeNotify,' + + 'ofEnableSizing'); + AddEnum('TFileEditStyle', 'fsEdit, fsComboBox'); + AddEnumSet('TColorDialogOptions', 'cdFullOpen, cdPreventFullOpen, cdShowHelp,' + + 'cdSolidColor, cdAnyColor'); + AddEnumSet('TFontDialogOptions', 'fdAnsiOnly, fdTrueTypeOnly, fdEffects,' + + 'fdFixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts,' + + 'fdNoSimulations, fdNoSizeSel, fdNoStyleSel, fdNoVectorFonts,' + + 'fdShowHelp, fdWysiwyg, fdLimitSize, fdScalableOnly, fdApplyButton'); + AddEnum('TFontDialogDevice', 'fdScreen, fdPrinter, fdBoth'); + AddEnum('TPrintRange', 'prAllPages, prSelection, prPageNums'); + AddEnumSet('TPrintDialogOptions', 'poPrintToFile, poPageNums, poSelection,' + + 'poWarning, poHelp, poDisablePrintToFile'); +{$IFNDEF CLX} + AddEnum('TMsgDlgType', 'mtWarning, mtError, mtInformation, mtConfirmation, mtCustom'); + AddEnumSet('TMsgDlgButtons', 'mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, ' + + 'mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp'); +{$ELSE} + AddEnum('TMsgDlgType', 'mtCustom, mtInformation, mtWarning, mtError, mtConfirmation'); + AddEnumSet('TMsgDlgButtons', 'mbNone, mbOk, mbCancel, mbYes, mbNo, mbAbort, ' + + 'mbRetry, mbIgnore'); +{$ENDIF} + +{$IFDEF CLX} + dlg := 'TDialog'; + with AddClass(TDialog, 'TComponent') do +{$ELSE} + dlg := 'TCommonDialog'; + with AddClass(TCommonDialog, 'TComponent') do +{$ENDIF} + AddMethod('function Execute: Boolean', CallMethod); + AddClass(TOpenDialog, dlg); + AddClass(TSaveDialog, dlg); + AddClass(TColorDialog, dlg); + AddClass(TFontDialog, dlg); +{$IFNDEF CLX} + {$IFNDEF FPC} + // todo: wait lazarus 1.0 TPrintDialog is targeted in Mantis to 1.0 + AddClass(TPrintDialog, dlg); + AddClass(TPrinterSetupDialog, dlg); + {$ENDIF} +{$ENDIF} + AddMethod('function MessageDlg(Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer', CallMethod, 'ctOther'); + AddMethod('function InputBox(ACaption, APrompt, ADefault: string): string', CallMethod, 'ctOther'); + AddMethod('function InputQuery(ACaption, APrompt: string; var Value: string): Boolean', CallMethod, 'ctOther'); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +var + s: String; + b: TMsgDlgButtons; +begin + Result := 0; + +{$IFDEF CLX} + if ClassType = TDialog then +{$ELSE} + if ClassType = TCommonDialog then +{$ENDIF} + begin + if MethodName = 'EXECUTE' then + Result := THackDialog(Instance).Execute + end + else if MethodName = 'INPUTBOX' then + Result := InputBox(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'INPUTQUERY' then + begin + s := Caller.Params[2]; + Result := InputQuery(Caller.Params[0], Caller.Params[1], s); + Caller.Params[2] := s; + end + else if MethodName = 'MESSAGEDLG' then + begin + {$IFNDEF FPC} + Word(PWordSet(@b)^) := Caller.Params[2]; + {$ELSE} + Integer(PWordSet(@b)^) := Caller.Params[2]; + {$ENDIF} + Result := MessageDlg(Caller.Params[0], Caller.Params[1], b, Caller.Params[3]); + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_idisp.pas b/official/4.8.11/FastScript/fs_idisp.pas new file mode 100644 index 0000000..565e160 --- /dev/null +++ b/official/4.8.11/FastScript/fs_idisp.pas @@ -0,0 +1,131 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ OLE dispatch module } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_idisp; + +interface + +{$I fs.inc} + +uses + Windows, Classes, SysUtils, ActiveX, ComObj, fs_iinterpreter +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfsOLEHelper = class(TfsCustomHelper) + private + function DispatchInvoke(const ParamArray: Variant; ParamCount: Integer; + Flags: Word): Variant; + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + constructor Create(const AName: String); + end; + + +implementation + + +constructor TfsOLEHelper.Create(const AName: String); +begin + inherited Create(AName, fvtVariant, ''); +end; + +function TfsOLEHelper.DispatchInvoke(const ParamArray: Variant; ParamCount: Integer; + Flags: Word): Variant; +const + DispIDArgs: Longint = DISPID_PROPERTYPUT; +var + DispId: TDispId; + Params: TDISPPARAMS; + pName: WideString; + ExcepMess: WideString; + Args: array[0..63] of Variant; + i: Integer; + PResult: PVariant; + Status: Integer; + ExcepInfo: TExcepInfo; +begin + ExcepMess := ''; + pName := WideString(Name); + IDispatch(ParentValue).GetIDsOfNames(GUID_NULL, @pName, 1, GetThreadLocale, @DispId); + + for i := 0 to ParamCount - 1 do + Args[i] := ParamArray[ParamCount - i - 1]; + + Params.rgvarg := @Args; + Params.rgdispidNamedArgs := nil; + Params.cArgs := ParamCount; + Params.cNamedArgs := 0; + if Flags = DISPATCH_PROPERTYPUT then + begin + Params.rgdispidNamedArgs := @DispIDArgs; + Params.cNamedArgs := 1; + end; + + if NeedResult and (Flags <> DISPATCH_PROPERTYPUT) then + PResult := @Result else + PResult := nil; + if PResult <> nil then + VarClear(PResult^); + if (Flags = DISPATCH_METHOD) {and (ParamCount = 0)} and (PResult <> nil) then + Flags := DISPATCH_METHOD or DISPATCH_PROPERTYGET; + + Status := IDispatch(ParentValue).Invoke(DispId, GUID_NULL, 0, + Flags, Params, PResult, @ExcepInfo, nil); + if Status <> 0 then + begin + if ExcepInfo.bstrSource <> '' then + ExcepMess := #13+#10 + 'Source :: '+ ExcepInfo.bstrSource; + if ExcepInfo.bstrDescription <> '' then + ExcepMess := ExcepMess + #13#10 + 'Description :: '+ ExcepInfo.bstrDescription; + if ExcepInfo.bstrHelpFile <> '' then + ExcepMess := ExcepMess + #13#10 + 'Help File :: '+ ExcepInfo.bstrHelpFile; +{$IFDEF Delphi12} + raise Exception.Create('OLE error ' + IntToHex(Status, 8) + ': ' + + String(Name) + ': ' + SysErrorMessage(Status) + ExcepMess); +{$ELSE} + raise Exception.Create('OLE error ' + IntToHex(Status, 8) + ': ' + + Name + ': ' + SysErrorMessage(Status) + ExcepMess); +{$ENDIF} + end; +end; + +procedure TfsOLEHelper.SetValue(const Value: Variant); +var + i: Integer; + v: Variant; +begin + v := VarArrayCreate([0, Count], varVariant); + for i := 0 to Count - 1 do + v[i] := Params[i].Value; + v[Count] := Value; + + DispatchInvoke(v, Count + 1, DISPATCH_PROPERTYPUT); +end; + +function TfsOLEHelper.GetValue: Variant; +var + i: Integer; + v: Variant; +begin + v := VarArrayCreate([0, Count - 1], varVariant); + for i := 0 to Count - 1 do + v[i] := Params[i].Value; + + Result := DispatchInvoke(v, Count, DISPATCH_METHOD); +end; + +end. diff --git a/official/4.8.11/FastScript/fs_ievents.pas b/official/4.8.11/FastScript/fs_ievents.pas new file mode 100644 index 0000000..777b637 --- /dev/null +++ b/official/4.8.11/FastScript/fs_ievents.pas @@ -0,0 +1,228 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Standard events } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ievents; + +interface + +{$i fs.inc} + +uses SysUtils, Classes, fs_iinterpreter +{$IFDEF CLX} +, QControls, QForms +{$ELSE} +, Controls, Forms +{$ENDIF}; + +type + TfsNotifyEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject); + function GetMethod: Pointer; override; + end; + + TfsMouseEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + function GetMethod: Pointer; override; + end; + + TfsMouseMoveEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; Shift: TShiftState; X, Y: Integer); + function GetMethod: Pointer; override; + end; + + TfsKeyEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; var Key: Word; Shift: TShiftState); + function GetMethod: Pointer; override; + end; + + TfsKeyPressEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; var Key: Char); + function GetMethod: Pointer; override; + end; + + TfsCloseEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; var Action: TCloseAction); + function GetMethod: Pointer; override; + end; + + TfsCloseQueryEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; var CanClose: Boolean); + function GetMethod: Pointer; override; + end; + + TfsCanResizeEvent = class(TfsCustomEvent) + public + procedure DoEvent(Sender: TObject; var NewWidth, NewHeight: Integer; + var Resize: Boolean); + function GetMethod: Pointer; override; + end; + + +implementation + + +type + TByteSet = set of 0..7; + PByteSet = ^TByteSet; + + +{ TfsNotifyEvent } + +procedure TfsNotifyEvent.DoEvent(Sender: TObject); +begin + CallHandler([Sender]); +end; + +function TfsNotifyEvent.GetMethod: Pointer; +begin + Result := @TfsNotifyEvent.DoEvent; +end; + +{ TfsMouseEvent } + +procedure TfsMouseEvent.DoEvent(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var +{$IFNDEF FPC} + b: Byte; +{$ELSE} + i: integer; +{$ENDIF} +begin +{$IFNDEF FPC} + b := Byte(PByteSet(@Shift)^); + CallHandler([Sender, Integer(Button), b, X, Y]); +{$ELSE} + i := Integer(PByteSet(@Shift)^); + CallHandler([Sender, Integer(Button), i, X, Y]); +{$ENDIF} +end; + +function TfsMouseEvent.GetMethod: Pointer; +begin + Result := @TfsMouseEvent.DoEvent; +end; + +{ TfsMouseMoveEvent } + +procedure TfsMouseMoveEvent.DoEvent(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +var +{$IFNDEF FPC} + b: Byte; +{$ELSE} + i: integer; +{$ENDIF} +begin +{$IFNDEF FPC} + b := Byte(PByteSet(@Shift)^); + CallHandler([Sender, b, X, Y]); +{$ELSE} + i := Integer(PByteSet(@Shift)^); + CallHandler([Sender, i, X, Y]); +{$ENDIF} +end; + +function TfsMouseMoveEvent.GetMethod: Pointer; +begin + Result := @TfsMouseMoveEvent.DoEvent; +end; + +{ TfsKeyEvent } + +procedure TfsKeyEvent.DoEvent(Sender: TObject; var Key: Word; + Shift: TShiftState); +var +{$IFNDEF FPC} + b: Byte; +{$ELSE} + i: integer; +{$ENDIF} +begin +{$IFNDEF FPC} + b := Byte(PByteSet(@Shift)^); + CallHandler([Sender, Key, b]); +{$ELSE} + i := Integer(PByteSet(@Shift)^); + CallHandler([Sender, Key, i]); +{$ENDIF} + Key := Handler.Params[1].Value; +end; + +function TfsKeyEvent.GetMethod: Pointer; +begin + Result := @TfsKeyEvent.DoEvent; +end; + +{ TfsKeyPressEvent } + +procedure TfsKeyPressEvent.DoEvent(Sender: TObject; var Key: Char); +begin + CallHandler([Sender, Key]); + Key := String(Handler.Params[1].Value)[1]; +end; + +function TfsKeyPressEvent.GetMethod: Pointer; +begin + Result := @TfsKeyPressEvent.DoEvent; +end; + +{ TfsCloseEvent } + +procedure TfsCloseEvent.DoEvent(Sender: TObject; var Action: TCloseAction); +begin + CallHandler([Sender, Integer(Action)]); + Action := Handler.Params[1].Value; +end; + +function TfsCloseEvent.GetMethod: Pointer; +begin + Result := @TfsCloseEvent.DoEvent; +end; + +{ TfsCloseQueryEvent } + +procedure TfsCloseQueryEvent.DoEvent(Sender: TObject; var CanClose: Boolean); +begin + CallHandler([Sender, CanClose]); + CanClose := Handler.Params[1].Value; +end; + +function TfsCloseQueryEvent.GetMethod: Pointer; +begin + Result := @TfsCloseQueryEvent.DoEvent; +end; + +{ TfsCanResizeEvent } + +procedure TfsCanResizeEvent.DoEvent(Sender: TObject; var NewWidth, + NewHeight: Integer; var Resize: Boolean); +begin + CallHandler([Sender, NewWidth, NewHeight, Resize]); + NewWidth := Handler.Params[1].Value; + NewHeight := Handler.Params[2].Value; + Resize := Handler.Params[3].Value; +end; + +function TfsCanResizeEvent.GetMethod: Pointer; +begin + Result := @TfsCanResizeEvent.DoEvent; +end; + +end. diff --git a/official/4.8.11/FastScript/fs_iexpression.pas b/official/4.8.11/FastScript/fs_iexpression.pas new file mode 100644 index 0000000..0d571ee --- /dev/null +++ b/official/4.8.11/FastScript/fs_iexpression.pas @@ -0,0 +1,876 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Expression parser } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iexpression; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + { List of operators } + + TfsOperatorType = (opNone, opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq, + opPlus, opMinus, opOr, opXor, opMul, opDivFloat, opDivInt, opMod, opAnd, + opShl, opShr, opLeftBracket, opRightBracket, opNot, opUnMinus, opIn, opIs); + +{ TfsExpression class holds a list of operands and operators. + List is represented in the tree form. + Call to methods AddXXX puts an expression element to the list. + Call to function Value calculates and returns the expression value } + + TfsExpressionNode = class(TfsCustomVariable) + private + FLeft, FRight, FParent: TfsExpressionNode; + procedure AddNode(Node: TfsExpressionNode); + procedure RemoveNode(Node: TfsExpressionNode); + public + destructor Destroy; override; + function Priority: Integer; virtual; abstract; + end; + + TfsOperandNode = class(TfsExpressionNode) + public + constructor Create(const AValue: Variant); + function Priority: Integer; override; + end; + + TfsOperatorNode = class(TfsExpressionNode) + private + FOp: TfsOperatorType; + FOptimizeInt: Boolean; + FOptimizeBool: Boolean; + public + constructor Create(Op: TfsOperatorType); + function Priority: Integer; override; + end; + + TfsDesignatorNode = class(TfsOperandNode) + private + FDesignator: TfsDesignator; + FVar: TfsCustomVariable; + protected + function GetValue: Variant; override; + public + constructor Create(ADesignator: TfsDesignator); + destructor Destroy; override; + end; + + TfsSetNode = class(TfsOperandNode) + private + FSetExpression: TfsSetExpression; + protected + function GetValue: Variant; override; + public + constructor Create(ASet: TfsSetExpression); + destructor Destroy; override; + end; + + TfsExpression = class(TfsCustomExpression) + private + FCurNode: TfsExpressionNode; + FNode: TfsExpressionNode; + FScript: TfsScript; + FSource: String; + procedure AddOperand(Node: TfsExpressionNode); + protected + function GetValue: Variant; override; + procedure SetValue(const Value: Variant); override; + public + constructor Create(Script: TfsScript); + destructor Destroy; override; + procedure AddConst(const AValue: Variant); + procedure AddDesignator(ADesignator: TfsDesignator); + procedure AddOperator(const Op: String); + procedure AddSet(ASet: TfsSetExpression); + + function Finalize: String; + function Optimize(Designator: TfsDesignator): String; + function SingleItem: TfsCustomVariable; + + property Source: String read FSource write FSource; + end; + + +implementation + +uses fs_itools; + +type + TNoneNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TGreatNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TLessNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TLessEqNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TGreatEqNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TNonEqNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TEqNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TPlusNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TStrCatNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TMinusNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TOrNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TXorNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TMulNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TDivFloatNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TDivIntNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TModNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TAndNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TShlNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TShrNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TLeftBracketNode = class(TfsOperatorNode); + + TRightBracketNode = class(TfsOperatorNode); + + TNotNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TUnMinusNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TInNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + TIsNode = class(TfsOperatorNode) + protected + function GetValue: Variant; override; + end; + + +function TNoneNode.GetValue: Variant; +begin + Result := FLeft.Value; +end; + +function TGreatNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result > FRight.Value; +end; + +function TLessNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result < FRight.Value; +end; + +function TLessEqNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result <= FRight.Value; +end; + +function TGreatEqNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result >= FRight.Value; +end; + +function TNonEqNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result <> FRight.Value; +end; + +function TEqNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result = FRight.Value; +end; + +function TPlusNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result + FRight.Value; +end; + +function TStrCatNode.GetValue: Variant; +begin + Result := FLeft.Value; + if (TVarData(Result).VType = varString){$IFDEF Delphi12} or (TVarData(Result).VType = varUString){$ENDIF} then + Result := VarToStr(Result) + VarToStr(FRight.Value) else + Result := Result + FRight.Value; +end; + +function TMinusNode.GetValue: Variant; +begin + Result := FLeft.Value; + if FOptimizeInt then + Result := Integer(Result) - Integer(FRight.Value) + else + Result := Result - FRight.Value; +end; + +function TOrNode.GetValue: Variant; +begin + Result := FLeft.Value; + + if FOptimizeBool then + begin + if Boolean(Result) = False then + Result := FRight.Value; + end + else + Result := Result or FRight.Value; +end; + +function TXorNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result xor FRight.Value; +end; + +function TMulNode.GetValue: Variant; +begin + Result := FLeft.Value; + if FOptimizeInt then + Result := Integer(Result) * Integer(FRight.Value) + else + Result := Result * FRight.Value; +end; + +function TDivFloatNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result / FRight.Value; +end; + +function TDivIntNode.GetValue: Variant; +begin + Result := FLeft.Value; + if FOptimizeInt then + Result := Integer(Result) div Integer(FRight.Value) + else + Result := Result div FRight.Value; +end; + +function TModNode.GetValue: Variant; +begin + Result := FLeft.Value; + if FOptimizeInt then + Result := Integer(Result) mod Integer(FRight.Value) + else + Result := Result mod FRight.Value; +end; + +function TAndNode.GetValue: Variant; +begin + Result := FLeft.Value; + if FOptimizeBool then + begin + if Boolean(Result) = True then + Result := FRight.Value; + end + else + Result := Result and FRight.Value; +end; + +function TShlNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result shl FRight.Value; +end; + +function TShrNode.GetValue: Variant; +begin + Result := FLeft.Value; + Result := Result shr FRight.Value; +end; + +function TNotNode.GetValue: Variant; +begin + Result := not FLeft.Value; +end; + +function TUnMinusNode.GetValue: Variant; +begin + Result := -FLeft.Value; +end; + +function TInNode.GetValue: Variant; +var + i: Integer; + ar, val, selfVal: Variant; + Count: Integer; +begin + if FRight is TfsSetNode then + Result := TfsSetNode(FRight).FSetExpression.Check(FLeft.Value) + else + begin + Result := False; + ar := FRight.Value; + Count := VarArrayHighBound(ar, 1); + selfVal := FLeft.Value; + + i := 0; + while i <= Count do + begin + val := ar[i]; + Result := selfVal = val; + if (i < Count - 1) and (ar[i + 1] = Null) and not Result then { subrange } + begin + Result := (selfVal >= val) and (selfVal <= ar[i + 2]); + Inc(i, 2); + end; + + if Result then break; + Inc(i); + end; + end; +end; + +function TIsNode.GetValue: Variant; +begin + Result := TObject(Integer(FLeft.Value)) is + TfsClassVariable(TfsDesignatorNode(FRight).FDesignator[0].Ref).ClassRef; +end; + + +{ TfsExpressionNode } + +destructor TfsExpressionNode.Destroy; +begin + FLeft.Free; + FRight.Free; + inherited; +end; + +procedure TfsExpressionNode.AddNode(Node: TfsExpressionNode); +begin + if FLeft = nil then + FLeft := Node + else if FRight = nil then + FRight := Node; + if Node <> nil then + Node.FParent := Self; +end; + +procedure TfsExpressionNode.RemoveNode(Node: TfsExpressionNode); +begin + if FLeft = Node then + FLeft := nil + else if FRight = Node then + FRight := nil; +end; + + +{ TfsOperandNode } + +constructor TfsOperandNode.Create(const AValue: Variant); +var + t: TfsVarType; +begin + inherited Create('', fvtInt, ''); + Value := AValue; + + t := fvtInt; + if TVarData(AValue).VType = varBoolean then + t := fvtBool + else if TVarData(AValue).VType in [varSingle, varDouble, varCurrency] then + t := fvtFloat + else if (TVarData(AValue).VType = varOleStr) or + (TVarData(AValue).VType = varString){$IFDEF Delphi12} or (TVarData(AValue).VType = varUString){$ENDIF} then + t := fvtString; + + Typ := t; +end; + +function TfsOperandNode.Priority: Integer; +begin + Result := 0; +end; + + +{ TfsOperatorNode } + +constructor TfsOperatorNode.Create(Op: TfsOperatorType); +begin + inherited Create('', fvtInt, ''); + FOp := Op; +end; + +function TfsOperatorNode.Priority: Integer; +begin + case FOp of + opNone: + Result := 7; + opLeftBracket: + Result := 6; + opRightBracket: + Result := 5; + opGreat, opLess, opGreatEq, opLessEq, opNonEq, opEq, opIn, opIs: + Result := 4; + opPlus, opMinus, opOr, opXor: + Result := 3; + opMul, opDivFloat, opDivInt, opMod, opAnd, opShr, opShl: + Result := 2; + opNot, opUnMinus: + Result := 1; + else + Result := 0; + end; +end; + + +{ TfsDesignatorNode } + +constructor TfsDesignatorNode.Create(ADesignator: TfsDesignator); +begin + inherited Create(0); + FDesignator := ADesignator; + Typ := ADesignator.Typ; + TypeName := ADesignator.TypeName; + if FDesignator is TfsVariableDesignator then + FVar := FDesignator.RefItem else + FVar := FDesignator; +end; + +destructor TfsDesignatorNode.Destroy; +begin + FDesignator.Free; + inherited; +end; + +function TfsDesignatorNode.GetValue: Variant; +begin + Result := FVar.Value; +end; + + +{ TfsSetNode } + +constructor TfsSetNode.Create(ASet: TfsSetExpression); +begin + inherited Create(0); + FSetExpression := ASet; + Typ := fvtVariant; +end; + +destructor TfsSetNode.Destroy; +begin + FSetExpression.Free; + inherited; +end; + +function TfsSetNode.GetValue: Variant; +begin + Result := FSetExpression.Value; +end; + + +{ TfsExpression } + +constructor TfsExpression.Create(Script: TfsScript); +begin + inherited Create('', fvtInt, ''); + FNode := TNoneNode.Create(opNone); + FCurNode := FNode; + FScript := Script; +end; + +destructor TfsExpression.Destroy; +begin + FNode.Free; + inherited; +end; + +function TfsExpression.GetValue: Variant; +begin + Result := FNode.Value; +end; + +procedure TfsExpression.AddOperand(Node: TfsExpressionNode); +begin + FCurNode.AddNode(Node); + FCurNode := Node; +end; + +procedure TfsExpression.AddOperator(const Op: String); +var + Node: TfsExpressionNode; + n, n1: TfsExpressionNode; + + function CreateOperatorNode(s: String): TfsOperatorNode; + begin + s := AnsiUpperCase(s); + if s = ' ' then + Result := TNoneNode.Create(opNone) + else if s = '>' then + Result := TGreatNode.Create(opGreat) + else if s = '<' then + Result := TLessNode.Create(opLess) + else if s = '<=' then + Result := TLessEqNode.Create(opLessEq) + else if s = '>=' then + Result := TGreatEqNode.Create(opGreatEq) + else if s = '<>' then + Result := TNonEqNode.Create(opNonEq) + else if s = '=' then + Result := TEqNode.Create(opEq) + else if s = '+' then + Result := TPlusNode.Create(opPlus) + else if s = 'STRCAT' then + Result := TStrCatNode.Create(opPlus) + else if s = '-' then + Result := TMinusNode.Create(opMinus) + else if s = 'OR' then + Result := TOrNode.Create(opOr) + else if s = 'XOR' then + Result := TXorNode.Create(opXor) + else if s = '*' then + Result := TMulNode.Create(opMul) + else if s = '/' then + Result := TDivFloatNode.Create(opDivFloat) + else if s = 'DIV' then + Result := TDivIntNode.Create(opDivInt) + else if s = 'MOD' then + Result := TModNode.Create(opMod) + else if s = 'AND' then + Result := TAndNode.Create(opAnd) + else if s = 'SHL' then + Result := TShlNode.Create(opShl) + else if s = 'SHR' then + Result := TShrNode.Create(opShr) + else if s = '(' then + Result := TLeftBracketNode.Create(opLeftBracket) + else if s = ')' then + Result := TRightBracketNode.Create(opRightBracket) + else if s = 'NOT' then + Result := TNotNode.Create(opNot) + else if s = 'UNMINUS' then + Result := TUnMinusNode.Create(opUnMinus) + else if s = 'IN' then + Result := TInNode.Create(opIn) + else if s = 'IS' then + Result := TIsNode.Create(opIs) + else + Result := nil; + end; + +begin + Node := CreateOperatorNode(Op); + Node.SourcePos := SourcePos; + + if (Op = '(') or (Op = 'unminus') or (Op = 'not') then + AddOperand(Node) + else if Op = ')' then + begin + n := FCurNode; + while n.Priority <= Node.Priority do + n := n.FParent; + + n.FParent.RemoveNode(n); + n.FParent.AddNode(n.FLeft); + + Node.Free; + Node := n.FLeft; + n.FLeft := nil; + n.Free; + end + else if FCurNode = FNode then + FNode.AddNode(Node) + else + begin + n := FCurNode; + n1 := nil; + if FCurNode.Priority <> 6 then + begin + n := FCurNode.FParent; + n1 := FCurNode; + end; + + while n.Priority <= Node.Priority do + begin + n1 := n; + n := n.FParent; + end; + + n.RemoveNode(n1); + n.AddNode(Node); + Node.AddNode(n1); + end; + + FCurNode := Node; +end; + +procedure TfsExpression.AddConst(const AValue: Variant); +var + Node: TfsOperandNode; +begin + Node := TfsOperandNode.Create(AValue); + Node.SourcePos := SourcePos; + AddOperand(Node); +end; + +procedure TfsExpression.AddDesignator(ADesignator: TfsDesignator); +var + Node: TfsDesignatorNode; +begin + Node := TfsDesignatorNode.Create(ADesignator); + Node.SourcePos := SourcePos; + AddOperand(Node); +end; + +procedure TfsExpression.AddSet(ASet: TfsSetExpression); +var + Node: TfsSetNode; +begin + Node := TfsSetNode.Create(ASet); + Node.SourcePos := SourcePos; + AddOperand(Node); +end; + +function TfsExpression.Finalize: String; +var + ErrorPos: String; + TypeRec: TfsTypeRec; + + function GetType(Item: TfsExpressionNode): TfsTypeRec; + var + Typ1, Typ2: TfsTypeRec; + op: TfsOperatorType; + Error: Boolean; + begin + if Item = nil then + Result.Typ := fvtVariant + else if Item is TfsOperandNode then + begin + Result.Typ := Item.Typ; + Result.TypeName := Item.TypeName; + end + else + begin + Typ1 := GetType(Item.FLeft); + Typ2 := GetType(Item.FRight); +// if (Typ1.Typ = fvtInt) and (Typ2.Typ = fvtInt) then +// TfsOperatorNode(Item).FOptimizeInt := True; + if (Typ1.Typ = fvtBool) and (Typ2.Typ = fvtBool) then + TfsOperatorNode(Item).FOptimizeBool := True; + + op := TfsOperatorNode(Item).FOp; + + if (op = opIs) and (Typ1.Typ = fvtClass) and (Typ2.Typ = fvtClass) then + Error := False + else + begin + { check types compatibility } + Error := not TypesCompatible(Typ1, Typ2, FScript); + { check operators applicability } + if not Error then + case Typ1.Typ of + fvtBool: + Error := not (op in [opNonEq, opEq, opOr, opXor, opAnd, opNot]); + fvtChar, fvtString: + Error := not (op in [opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq, opPlus, opIn]); + fvtClass, fvtArray: + Error := not (op in [opNonEq, opEq]); + end; + end; + + if not Error then + begin + Result := Typ1; + { if one type is Float, resulting type is float too } + if [Typ1.Typ] + [Typ2.Typ] = [fvtInt, fvtFloat] then + Result.Typ := fvtFloat; + { case int / int = float } + if (Typ1.Typ = fvtInt) and (Typ2.Typ = fvtInt) and (op = opDivFloat) then + Result.Typ := fvtFloat; + { result of comparing two types is always boolean } + if op in [opGreat, opLess, opLessEq, opGreatEq, opNonEq, opEq, opIn, opIs] then + Result.Typ := fvtBool; + end + else if ErrorPos = '' then + ErrorPos := Item.SourcePos; + + Item.Typ := Result.Typ; + end; + end; + +begin + { remove the empty root node } + FCurNode := FNode.FLeft; + FNode.RemoveNode(FCurNode); + FNode.Free; + FNode := FCurNode; + + { check and get the expression type } + ErrorPos := ''; + TypeRec := GetType(FNode); + Typ := TypeRec.Typ; + TypeName := TypeRec.TypeName; + Result := ErrorPos; + + { expression is assignable if it has only one node of type "Variable" } + if not ((FNode is TfsDesignatorNode) and not + (TfsDesignatorNode(FNode).FDesignator.IsReadOnly)) then + IsReadOnly := True; +end; + +procedure TfsExpression.SetValue(const Value: Variant); +begin + if not IsReadOnly then + TfsDesignatorNode(FNode).FDesignator.Value := Value; +end; + +function TfsExpression.Optimize(Designator: TfsDesignator): String; +var + Op: TfsOperatorType; +begin + Result := ' '; + + if not (Designator is TfsVariableDesignator) or + not (FNode is TfsOperatorNode) then Exit; + + Op := TfsOperatorNode(FNode).FOp; + if not (Op in [opPlus, opMinus, opDivFloat, opMul]) then Exit; + + { optimize a := a op b statement } + if (FNode.FLeft is TfsDesignatorNode) and + (TfsDesignatorNode(FNode.FLeft).FDesignator is TfsVariableDesignator) and + (TfsDesignatorNode(FNode.FLeft).FDesignator.RefItem = Designator.RefItem) then + begin + FCurNode := FNode.FRight; + FNode.RemoveNode(FCurNode); + FNode.Free; + FNode := FCurNode; + + if Op = opPlus then + Result := '+' + else if Op = opMinus then + Result := '-' + else if Op = opDivFloat then + Result := '/' + else if Op = opMul then + Result := '*'; + end + { optimize a := b op a statement } + else if (FNode.FRight is TfsDesignatorNode) and + (TfsDesignatorNode(FNode.FRight).FDesignator is TfsVariableDesignator) and + (TfsDesignatorNode(FNode.FRight).FDesignator.RefItem = Designator.RefItem) and + (Op in [opPlus, opMul]) and + not (Designator.RefItem.Typ in [fvtString, fvtVariant]) then + begin + FCurNode := FNode.FLeft; + FNode.RemoveNode(FCurNode); + FNode.Free; + FNode := FCurNode; + + if Op = opPlus then + Result := '+' + else if Op = opMul then + Result := '*'; + end; +end; + +function TfsExpression.SingleItem: TfsCustomVariable; +begin + { if expression contains only one item, returns reference to it } + Result := nil; + + if FNode is TfsDesignatorNode then + begin + if TfsDesignatorNode(FNode).FDesignator is TfsVariableDesignator then + Result := TfsDesignatorNode(FNode).FDesignator.RefItem else + Result := TfsDesignatorNode(FNode).FDesignator; + end + else if FNode is TfsOperandNode then + Result := FNode; +end; + +end. diff --git a/official/4.8.11/FastScript/fs_iextctrlsrtti.pas b/official/4.8.11/FastScript/fs_iextctrlsrtti.pas new file mode 100644 index 0000000..a256d01 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iextctrlsrtti.pas @@ -0,0 +1,425 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ ExtCtrls } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iextctrlsrtti; + +interface + +{$i fs.inc} + +uses SysUtils, Classes, fs_iinterpreter, fs_ievents, fs_iformsrtti +{$IFDEF CLX} +, QExtCtrls, QButtons, QCheckLst, QComCtrls +{$ELSE} +, ExtCtrls, Buttons, CheckLst, ComCtrls +{$ENDIF}; + +type + TfsExtCtrlsRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnum('TShapeType', 'stRectangle, stSquare, stRoundRect, stRoundSquare,' + + 'stEllipse, stCircle'); + AddEnum('TBevelStyle', 'bsLowered, bsRaised'); + AddEnum('TBevelShape', 'bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine,' + + 'bsRightLine, bsSpacer'); + AddEnum('TResizeStyle', 'rsNone, rsLine, rsUpdate, rsPattern'); + AddEnum('TButtonLayout', 'blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom'); + AddEnum('TButtonState', 'bsUp, bsDisabled, bsDown, bsExclusive'); + AddEnum('TButtonStyle', 'bsAutoDetect, bsWin31, bsNew'); + AddEnum('TBitBtnKind', 'bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo,' + + 'bkClose, bkAbort, bkRetry, bkIgnore, bkAll'); + AddType('TNumGlyphs', fvtInt); + AddEnum('TTabPosition', 'tpTop, tpBottom, tpLeft, tpRight'); + AddEnum('TTabStyle', 'tsTabs, tsButtons, tsFlatButtons'); + AddEnum('TStatusPanelStyle', 'psText, psOwnerDraw'); + AddEnum('TStatusPanelBevel', 'pbNone, pbLowered, pbRaised'); + AddEnum('TSortType', 'stNone, stData, stText, stBoth'); + AddEnum('TTrackBarOrientation', 'trHorizontal, trVertical'); + AddEnum('TTickMark', 'tmBottomRight, tmTopLeft, tmBoth'); + AddEnum('TTickStyle', 'tsNone, tsAuto, tsManual'); + AddEnum('TProgressBarOrientation', 'pbHorizontal, pbVertical'); + AddEnum('TIconArrangement', 'iaTop, iaLeft'); + AddEnum('TListArrangement', 'arAlignBottom, arAlignLeft, arAlignRight,' + + 'arAlignTop, arDefault, arSnapToGrid'); + AddEnum('TViewStyle', 'vsIcon, vsSmallIcon, vsList, vsReport'); + AddEnum('TToolButtonStyle', 'tbsButton, tbsCheck, tbsDropDown, tbsSeparator, tbsDivider'); + AddEnum('TDateTimeKind', 'dtkDate, dtkTime'); + AddEnum('TDTDateMode', 'dmComboBox, dmUpDown'); + AddEnum('TDTDateFormat', 'dfShort, dfLong'); + AddEnum('TDTCalAlignment', 'dtaLeft, dtaRight'); + AddEnum('TCalDayOfWeek', 'dowMonday, dowTuesday, dowWednesday, dowThursday,' + + 'dowFriday, dowSaturday, dowSunday, dowLocaleDefault'); + + AddClass(TShape, 'TGraphicControl'); + with AddClass(TPaintBox, 'TGraphicControl') do + AddEvent('OnPaint', TfsNotifyEvent); + AddClass(TImage, 'TGraphicControl'); + AddClass(TBevel, 'TGraphicControl'); + with AddClass(TTimer, 'TComponent') do + AddEvent('OnTimer', TfsNotifyEvent); + AddClass(TPanel, 'TCustomControl'); + AddClass(TSplitter, 'TGraphicControl'); + AddClass(TBitBtn, 'TButton'); + AddClass(TSpeedButton, 'TGraphicControl'); + with AddClass(TCheckListBox, 'TCustomListBox') do + AddIndexProperty('Checked', 'Integer', 'Boolean', CallMethod); + AddClass(TTabControl, 'TWinControl'); + with AddClass(TTabSheet, 'TWinControl') do + AddProperty('PageControl', 'TPageControl', GetProp, SetProp); + with AddClass(TPageControl, 'TWinControl') do + begin + AddMethod('procedure SelectNextPage(GoForward: Boolean)', CallMethod); + AddProperty('PageCount', 'Integer', GetProp, nil); + AddIndexProperty('Pages', 'Integer', 'TTabSheet', CallMethod, True); + end; + AddClass(TStatusPanel, 'TPersistent'); + with AddClass(TStatusPanels, 'TPersistent') do + begin + AddMethod('function Add: TStatusPanel', CallMethod); + AddIndexProperty('Items', 'Integer', 'TStatusPanel', CallMethod, True); + end; + AddClass(TStatusBar, 'TWinControl'); + with AddClass(TTreeNode, 'TPersistent') do + begin + AddMethod('procedure Delete', CallMethod); + AddMethod('function EditText: Boolean', CallMethod); + AddProperty('Count', 'Integer', GetProp, nil); + AddProperty('Data', 'Pointer', GetProp, SetProp); + AddProperty('ImageIndex', 'Integer', GetProp, SetProp); + AddProperty('SelectedIndex', 'Integer', GetProp, SetProp); + AddProperty('StateIndex', 'Integer', GetProp, SetProp); + AddProperty('Text', 'String', GetProp, SetProp); + end; + with AddClass(TTreeNodes, 'TPersistent') do + begin + AddMethod('function Add(Node: TTreeNode; const S: string): TTreeNode', CallMethod); + AddMethod('function AddChild(Node: TTreeNode; const S: string): TTreeNode', CallMethod); + AddMethod('procedure BeginUpdate', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Node: TTreeNode)', CallMethod); + AddMethod('procedure EndUpdate', CallMethod); + AddProperty('Count', 'Integer', GetProp, nil); + AddDefaultProperty('Item', 'Integer', 'TTreeNode', CallMethod, True); + end; + with AddClass(TTreeView, 'TWinControl') do + begin + AddMethod('procedure FullCollapse', CallMethod); + AddMethod('procedure FullExpand', CallMethod); + AddProperty('Items', 'TTreeNodes', GetProp, nil); + AddProperty('Selected', 'TTreeNode', GetProp, SetProp); + AddProperty('TopItem', 'TTreeNode', GetProp, SetProp); + end; + AddClass(TTrackBar, 'TWinControl'); + AddClass(TProgressBar, 'TWinControl'); + AddClass(TListColumn, 'TPersistent'); + with AddClass(TListColumns, 'TPersistent') do + begin + AddMethod('function Add: TListColumn', CallMethod); + AddDefaultProperty('Items', 'Integer', 'TListColumn', CallMethod, True); + end; + with AddClass(TListItem, 'TPersistent') do + begin + AddMethod('procedure Delete', CallMethod); + AddMethod('function EditCaption: Boolean', CallMethod); + AddProperty('Caption', 'String', GetProp, SetProp); + AddProperty('Checked', 'Boolean', GetProp, SetProp); + AddProperty('Data', 'Pointer', GetProp, SetProp); + AddProperty('ImageIndex', 'Integer', GetProp, SetProp); + AddProperty('Selected', 'Boolean', GetProp, SetProp); + AddProperty('StateIndex', 'Integer', GetProp, SetProp); + AddProperty('SubItems', 'TStrings', GetProp, SetProp); + end; + with AddClass(TListItems, 'TPersistent') do + begin + AddMethod('function Add: TListItem', CallMethod); + AddMethod('procedure BeginUpdate', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Index: Integer)', CallMethod); + AddMethod('procedure EndUpdate', CallMethod); + AddProperty('Count', 'Integer', GetProp, nil); + AddDefaultProperty('Item', 'Integer', 'TListItem', CallMethod, True); + end; +{$IFNDEF FPC} + AddClass(TIconOptions, 'TPersistent'); +{$ENDIF} + AddClass(TListView, 'TWinControl'); + AddClass(TToolButton, 'TGraphicControl'); + AddClass(TToolBar, 'TWinControl'); +{$IFNDEF CLX} + {$IFNDEF FPC} + AddClass(TMonthCalColors, 'TPersistent'); + AddClass(TDateTimePicker, 'TWinControl'); + AddClass(TMonthCalendar, 'TWinControl'); + AddClass(TCustomRichEdit, 'TWinControl'); + AddClass(TRichEdit, 'TCustomRichEdit'); + {$ENDIF} +{$ENDIF} + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TCheckListBox then + begin + if MethodName = 'CHECKED.GET' then + Result := TCheckListBox(Instance).Checked[Caller.Params[0]] + else if MethodName = 'CHECKED.SET' then + TCheckListBox(Instance).Checked[Caller.Params[0]] := Caller.Params[1] + end + else if ClassType = TPageControl then + begin + if MethodName = 'SELECTNEXTPAGE' then + TPageControl(Instance).SelectNextPage(Caller.Params[0]) + else if MethodName = 'PAGES.GET' then + Result := Integer(TPageControl(Instance).Pages[Caller.Params[0]]) + end + else if ClassType = TStatusPanels then + begin + if MethodName = 'ADD' then + Result := Integer(TStatusPanels(Instance).Add) + else if MethodName = 'ITEMS.GET' then + Result := Integer(TStatusPanels(Instance).Items[Caller.Params[0]]) + end + else if ClassType = TTreeNode then + begin + if MethodName = 'DELETE' then + TTreeNode(Instance).Delete + else if MethodName = 'EDITTEXT' then + Result := TTreeNode(Instance).EditText + end + else if ClassType = TTreeNodes then + begin + if MethodName = 'ADD' then + Result := Integer(TTreeNodes(Instance).Add(TTreeNode(Integer(Caller.Params[0])), + Caller.Params[1])) + else if MethodName = 'ADDCHILD' then + Result := Integer(TTreeNodes(Instance).AddChild(TTreeNode(Integer(Caller.Params[0])), + Caller.Params[1])) + else if MethodName = 'BEGINUPDATE' then + TTreeNodes(Instance).BeginUpdate + else if MethodName = 'CLEAR' then + TTreeNodes(Instance).Clear + else if MethodName = 'DELETE' then + TTreeNodes(Instance).Delete(TTreeNode(Integer(Caller.Params[0]))) + else if MethodName = 'ENDUPDATE' then + TTreeNodes(Instance).EndUpdate + else if MethodName = 'ITEM.GET' then + Result := Integer(TTreeNodes(Instance).Item[Caller.Params[0]]) + end + else if ClassType = TTreeView then + begin + if MethodName = 'FULLCOLLAPSE' then + TTreeView(Instance).FullCollapse + else if MethodName = 'FULLEXPAND' then + TTreeView(Instance).FullExpand + end + else if ClassType = TListColumns then + begin + if MethodName = 'ADD' then + Result := Integer(TListColumns(Instance).Add) + else if MethodName = 'ITEMS.GET' then + Result := Integer(TListColumns(Instance).Items[Caller.Params[0]]) + end + else if ClassType = TListItem then + begin + if MethodName = 'DELETE' then + TListItem(Instance).Delete +{$IFNDEF CLX} + {$IFNDEF FPC} + else if MethodName = 'EDITCAPTION' then + Result := TListItem(Instance).EditCaption + {$ENDIF} +{$ENDIF} + end + else if ClassType = TListItems then + begin + if MethodName = 'ADD' then + Result := Integer(TListItems(Instance).Add) +{$IFNDEF FPC} + else if MethodName = 'BEGINUPDATE' then + TListItems(Instance).BeginUpdate +{$ENDIF} + else if MethodName = 'CLEAR' then + TListItems(Instance).Clear + else if MethodName = 'DELETE' then + TListItems(Instance).Delete(Caller.Params[0]) +{$IFNDEF FPC} + else if MethodName = 'ENDUPDATE' then + TListItems(Instance).EndUpdate +{$ENDIF} + else if MethodName = 'ITEM.GET' then + Result := Integer(TListItems(Instance).Item[Caller.Params[0]]) + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TPageControl then + begin + if PropName = 'PAGECOUNT' then + Result := TPageControl(Instance).PageCount + end + else if ClassType = TTabSheet then + begin + if PropName = 'PAGECONTROL' then + Result := Integer(TTabSheet(Instance).PageControl) + end + else if ClassType = TTreeNode then + begin + if PropName = 'COUNT' then + Result := TTreeNode(Instance).Count + else if PropName = 'DATA' then + Result := Integer(TTreeNode(Instance).Data) + else if PropName = 'IMAGEINDEX' then + Result := TTreeNode(Instance).ImageIndex + else if PropName = 'SELECTEDINDEX' then + Result := TTreeNode(Instance).SelectedIndex +{$IFNDEF CLX} + else if PropName = 'STATEINDEX' then + Result := TTreeNode(Instance).StateIndex +{$ENDIF} + else if PropName = 'TEXT' then + Result := TTreeNode(Instance).Text + end + else if ClassType = TTreeNodes then + begin + if PropName = 'COUNT' then + Result := TTreeNodes(Instance).Count + end + else if ClassType = TTreeView then + begin + if PropName = 'ITEMS' then + Result := Integer(TTreeView(Instance).Items) + else if PropName = 'SELECTED' then + Result := Integer(TTreeView(Instance).Selected) + else if PropName = 'TOPITEM' then + Result := Integer(TTreeView(Instance).TopItem) + end + else if ClassType = TListItem then + begin + if PropName = 'CAPTION' then + Result := TListItem(Instance).Caption + else if PropName = 'CHECKED' then + Result := TListItem(Instance).Checked + else if PropName = 'DATA' then + Result := Integer(TListItem(Instance).Data) + else if PropName = 'IMAGEINDEX' then + Result := TListItem(Instance).ImageIndex + else if PropName = 'SELECTED' then + Result := TListItem(Instance).Selected +{$IFNDEF CLX} + {$IFNDEF FPC} + else if PropName = 'STATEINDEX' then + Result := TListItem(Instance).StateIndex + {$ENDIF} +{$ENDIF} + else if PropName = 'SUBITEMS' then + Result := Integer(TListItem(Instance).SubItems) + end + else if ClassType = TListItems then + begin + if PropName = 'COUNT' then + Result := TListItems(Instance).Count + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + if ClassType = TTabSheet then + begin + if PropName = 'PAGECONTROL' then + TTabSheet(Instance).PageControl := TPageControl(Integer(Value)) + end + else if ClassType = TTreeNode then + begin + if PropName = 'DATA' then + TTreeNode(Instance).Data := Pointer(Integer(Value)) + else if PropName = 'IMAGEINDEX' then + TTreeNode(Instance).ImageIndex := Value + else if PropName = 'SELECTEDINDEX' then + TTreeNode(Instance).SelectedIndex := Value +{$IFNDEF CLX} + else if PropName = 'STATEINDEX' then + TTreeNode(Instance).StateIndex := Value +{$ENDIF} + else if PropName = 'TEXT' then + TTreeNode(Instance).Text := Value + end + else if ClassType = TTreeView then + begin + if PropName = 'SELECTED' then + TTreeView(Instance).Selected := TTreeNode(Integer(Value)) + else if PropName = 'TOPITEM' then + TTreeView(Instance).TopItem := TTreeNode(Integer(Value)) + end + else if ClassType = TListItem then + begin + if PropName = 'CAPTION' then + TListItem(Instance).Caption := Value + else if PropName = 'CHECKED' then + TListItem(Instance).Checked := Value + else if PropName = 'DATA' then + TListItem(Instance).Data := Pointer(Integer(Value)) + else if PropName = 'IMAGEINDEX' then + TListItem(Instance).ImageIndex := Value + else if PropName = 'SELECTED' then + TListItem(Instance).Selected := Value +{$IFNDEF CLX} + {$IFNDEF FPC} + else if PropName = 'STATEINDEX' then + TListItem(Instance).StateIndex := Value + {$ENDIF} +{$ENDIF} + else if PropName = 'SUBITEMS' then + TListItem(Instance).SubItems := TStrings(Integer(Value)) + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iformsrtti.pas b/official/4.8.11/FastScript/fs_iformsrtti.pas new file mode 100644 index 0000000..5058a94 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iformsrtti.pas @@ -0,0 +1,428 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Forms and StdCtrls } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iformsrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_ievents, fs_iclassesrtti, + fs_igraphicsrtti +{$IFDEF CLX} + , QControls, QForms, QStdCtrls +{$ELSE} + {$IFNDEF FPC} + , Windows + {$ELSE} + , LCLType, Buttons + {$ENDIF} + , Controls, Forms, StdCtrls +{$ENDIF}; + +type + TfsFormsRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddConst('mrNone', 'Integer', mrNone); + AddConst('mrOk', 'Integer', mrOk); + AddConst('mrCancel', 'Integer', mrCancel); + AddConst('mrAbort', 'Integer', mrAbort); + AddConst('mrRetry', 'Integer', mrRetry); + AddConst('mrIgnore', 'Integer', mrIgnore); + AddConst('mrYes', 'Integer', mrYes); + AddConst('mrNo', 'Integer', mrNo); + AddConst('mrAll', 'Integer', mrAll); + AddConst('mrNoToAll', 'Integer', mrNoToAll); + AddConst('mrYesToAll', 'Integer', mrYesToAll); + + AddConst('crDefault', 'Integer', crDefault); + AddConst('crNone', 'Integer', crNone); + AddConst('crArrow', 'Integer', crArrow); + AddConst('crCross', 'Integer', crCross); + AddConst('crIBeam', 'Integer', crIBeam); + AddConst('crSize', 'Integer', crSize); + AddConst('crSizeNESW', 'Integer', crSizeNESW); + AddConst('crSizeNS', 'Integer', crSizeNS); + AddConst('crSizeNWSE', 'Integer', crSizeNWSE); + AddConst('crSizeWE', 'Integer', crSizeWE); + AddConst('crUpArrow', 'Integer', crUpArrow); + AddConst('crHourGlass', 'Integer', crHourGlass); + AddConst('crDrag', 'Integer', crDrag); + AddConst('crNoDrop', 'Integer', crNoDrop); + AddConst('crHSplit', 'Integer', crHSplit); + AddConst('crVSplit', 'Integer', crVSplit); + AddConst('crMultiDrag', 'Integer', crMultiDrag); + AddConst('crSQLWait', 'Integer', crSQLWait); + AddConst('crNo', 'Integer', crNo); + AddConst('crAppStart', 'Integer', crAppStart); + AddConst('crHelp', 'Integer', crHelp); + AddConst('crHandPoint', 'Integer', crHandPoint); + AddConst('crSizeAll', 'Integer', crSizeAll); + +{$IFDEF CLX} + AddConst('bsNone', 'Integer', fbsNone); + AddConst('bsSingle', 'Integer', fbsSingle); + AddConst('bsSizeable', 'Integer', fbsSizeable); + AddConst('bsDialog', 'Integer', fbsDialog); + AddConst('bsToolWindow', 'Integer', fbsToolWindow); + AddConst('bsSizeToolWin', 'Integer', fbsSizeToolWin); +{$ELSE} + AddConst('bsNone', 'Integer', bsNone); + AddConst('bsSingle', 'Integer', bsSingle); + AddConst('bsSizeable', 'Integer', bsSizeable); + AddConst('bsDialog', 'Integer', bsDialog); + AddConst('bsToolWindow', 'Integer', bsToolWindow); + AddConst('bsSizeToolWin', 'Integer', bsSizeToolWin); +{$ENDIF} + +{$IFNDEF CLX} + AddConst('VK_RBUTTON', 'Integer', VK_RBUTTON); + AddConst('VK_CANCEL', 'Integer', VK_CANCEL); + AddConst('VK_MBUTTON', 'Integer', VK_MBUTTON); + AddConst('VK_BACK', 'Integer', VK_BACK);//Backspace key + AddConst('VK_TAB', 'Integer', VK_TAB);//Tab key + AddConst('VK_RETURN', 'Integer', VK_RETURN);//Enter key + AddConst('VK_SHIFT', 'Integer', VK_SHIFT);//Shift key + AddConst('VK_CONTROL', 'Integer', VK_CONTROL);//Ctrl key + AddConst('VK_MENU', 'Integer', VK_MENU);//Alt key + AddConst('VK_PAUSE', 'Integer', VK_PAUSE);//Pause key + AddConst('VK_CAPITAL', 'Integer', VK_CAPITAL);//Caps Lock key + AddConst('VK_ESCAPE', 'Integer', VK_ESCAPE);//Esc key + AddConst('VK_SPACE', 'Integer', VK_SPACE);//Space bar + AddConst('VK_PRIOR', 'Integer', VK_PRIOR);//Page Up key + AddConst('VK_NEXT', 'Integer', VK_NEXT);// Page Down key + AddConst('VK_END', 'Integer', VK_END);// End key + AddConst('VK_HOME', 'Integer', VK_HOME);// Home key + AddConst('VK_LEFT', 'Integer', VK_LEFT);// Left Arrow key + AddConst('VK_UP', 'Integer', VK_UP);// Up Arrow key + AddConst('VK_RIGHT', 'Integer', VK_RIGHT);// Right Arrow key + AddConst('VK_DOWN', 'Integer', VK_DOWN);// Down Arrow key + AddConst('VK_INSERT', 'Integer', VK_INSERT);// Insert key + AddConst('VK_DELETE', 'Integer', VK_DELETE);// Delete key + AddConst('VK_HELP', 'Integer', VK_HELP);// Help key + AddConst('VK_LWIN', 'Integer', VK_LWIN);// Left Windows key (Microsoft keyboard) + AddConst('VK_RWIN', 'Integer', VK_RWIN);// Right Windows key (Microsoft keyboard) + AddConst('VK_APPS', 'Integer', VK_APPS);// Applications key (Microsoft keyboard) + AddConst('VK_NUMPAD0', 'Integer', VK_NUMPAD0);// 0 key (numeric keypad) + AddConst('VK_NUMPAD1', 'Integer', VK_NUMPAD1);// 1 key (numeric keypad) + AddConst('VK_NUMPAD2', 'Integer', VK_NUMPAD2);// 2 key (numeric keypad) + AddConst('VK_NUMPAD3', 'Integer', VK_NUMPAD3);// 3 key (numeric keypad) + AddConst('VK_NUMPAD4', 'Integer', VK_NUMPAD4);// 4 key (numeric keypad) + AddConst('VK_NUMPAD5', 'Integer', VK_NUMPAD5);// 5 key (numeric keypad) + AddConst('VK_NUMPAD6', 'Integer', VK_NUMPAD6);// 6 key (numeric keypad) + AddConst('VK_NUMPAD7', 'Integer', VK_NUMPAD7);// 7 key (numeric keypad) + AddConst('VK_NUMPAD8', 'Integer', VK_NUMPAD8);// 8 key (numeric keypad) + AddConst('VK_NUMPAD9', 'Integer', VK_NUMPAD9);// 9 key (numeric keypad) + AddConst('VK_MULTIPLY', 'Integer', VK_MULTIPLY);// Multiply key (numeric keypad) + AddConst('VK_ADD', 'Integer', VK_ADD);// Add key (numeric keypad) + AddConst('VK_SEPARATOR', 'Integer', VK_SEPARATOR);// Separator key (numeric keypad) + AddConst('VK_SUBTRACT', 'Integer', VK_SUBTRACT);// Subtract key (numeric keypad) + AddConst('VK_DECIMAL', 'Integer', VK_DECIMAL);// Decimal key (numeric keypad) + AddConst('VK_DIVIDE', 'Integer', VK_DIVIDE);// Divide key (numeric keypad) + AddConst('VK_F1', 'Integer', VK_F1);// F1 key + AddConst('VK_F1', 'Integer', VK_F2);// F2 key + AddConst('VK_F3', 'Integer', VK_F3);// F3 key + AddConst('VK_F4', 'Integer', VK_F4);// F4 key + AddConst('VK_F5', 'Integer', VK_F5);// F5 key + AddConst('VK_F6', 'Integer', VK_F6);// F6 key + AddConst('VK_F7', 'Integer', VK_F7);// F7 key + AddConst('VK_F8', 'Integer', VK_F8);// F8 key + AddConst('VK_F9', 'Integer', VK_F9);// F9 key + AddConst('VK_F10', 'Integer', VK_F10);// F10 key + AddConst('VK_F11', 'Integer', VK_F11);// F11 key + AddConst('VK_F12', 'Integer', VK_F12);// F12 key + AddConst('VK_NUMLOCK', 'Integer', VK_NUMLOCK);// Num Lock key + AddConst('VK_SCROLL', 'Integer', VK_SCROLL);// Scroll Lock key +{$ENDIF} + + AddConst('crDefault', 'Integer', crDefault); + AddConst('crNone', 'Integer', crNone); + AddConst('crArrow', 'Integer', crArrow); + AddConst('crCross', 'Integer', crCross); + AddConst('crIBeam', 'Integer', crIBeam); + AddConst('crSize', 'Integer', crSize); + AddConst('crSizeNESW', 'Integer', crSizeNESW); + AddConst('crSizeNS', 'Integer', crSizeNS); + AddConst('crSizeNWSE', 'Integer', crSizeNWSE); + AddConst('crSizeWE', 'Integer', crSizeWE); + AddConst('crUpArrow', 'Integer', crUpArrow); + AddConst('crHourGlass', 'Integer', crHourGlass); + AddConst('crDrag', 'Integer', crDrag); + AddConst('crNoDrop', 'Integer', crNoDrop); + AddConst('crHSplit', 'Integer', crHSplit); + AddConst('crVSplit', 'Integer', crVSplit); + AddConst('crMultiDrag', 'Integer', crMultiDrag); + AddConst('crSQLWait', 'Integer', crSQLWait); + AddConst('crNo', 'Integer', crNo); + AddConst('crAppStart', 'Integer', crAppStart); + AddConst('crHelp', 'Integer', crHelp); + AddConst('crHandPoint', 'Integer', crHandPoint); + AddConst('crSizeAll', 'Integer', crSizeAll); + + AddType('TFormBorderStyle', fvtInt); + AddType('TBorderStyle', fvtInt); + AddType('TAlignment', fvtInt); + AddType('TLeftRight', fvtInt); + AddConst('taLeftJustify', 'Integer', taLeftJustify); + AddConst('taRightJustify', 'Integer', taRightJustify); + AddConst('taCenter', 'Integer', taCenter); + + AddEnumSet('TShiftState', 'ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble'); +// AddEnum('TAlignment', 'taLeftJustify, taRightJustify, taCenter'); + AddEnum('TAlign', 'alNone, alTop, alBottom, alLeft, alRight, alClient'); + AddEnum('TMouseButton', 'mbLeft, mbRight, mbMiddle'); + AddEnumSet('TAnchors', 'akLeft, akTop, akRight, akBottom'); + AddEnum('TBevelCut', 'bvNone, bvLowered, bvRaised, bvSpace'); + AddEnum('TTextLayout', 'tlTop, tlCenter, tlBottom'); + AddEnum('TEditCharCase', 'ecNormal, ecUpperCase, ecLowerCase'); + AddEnum('TScrollStyle', 'ssNone, ssHorizontal, ssVertical, ssBoth'); + AddEnum('TComboBoxStyle', 'csDropDown, csSimple, csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable'); + AddEnum('TCheckBoxState', 'cbUnchecked, cbChecked, cbGrayed'); + AddEnum('TListBoxStyle', 'lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable'); + AddEnum('TWindowState', 'wsNormal, wsMinimized, wsMaximized'); + AddEnum('TFormStyle', 'fsNormal, fsMDIChild, fsMDIForm, fsStayOnTop'); + AddEnumSet('TBorderIcons', 'biSystemMenu, biMinimize, biMaximize, biHelp'); + AddEnum('TPosition', 'poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly, poScreenCenter, poDesktopCenter'); + AddEnum('TCloseAction', 'caNone, caHide, caFree, caMinimize'); + + with AddClass(TControl, 'TComponent') do + begin + AddProperty('Parent', 'TWinControl', GetProp, SetProp); + AddMethod('procedure Hide', CallMethod); + AddMethod('procedure Show', CallMethod); + AddMethod('procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer)', CallMethod); + AddEvent('OnCanResize', TfsCanResizeEvent); + AddEvent('OnClick', TfsNotifyEvent); + AddEvent('OnDblClick', TfsNotifyEvent); + AddEvent('OnMouseDown', TfsMouseEvent); + AddEvent('OnMouseMove', TfsMouseMoveEvent); + AddEvent('OnMouseUp', TfsMouseEvent); + AddEvent('OnResize', TfsNotifyEvent); + end; + with AddClass(TWinControl, 'TControl') do + begin + AddMethod('procedure SetFocus', CallMethod); + AddEvent('OnEnter', TfsNotifyEvent); + AddEvent('OnExit', TfsNotifyEvent); + AddEvent('OnKeyDown', TfsKeyEvent); + AddEvent('OnKeyPress', TfsKeyPressEvent); + AddEvent('OnKeyUp', TfsKeyEvent); + end; + AddClass(TCustomControl, 'TWinControl'); + AddClass(TGraphicControl, 'TControl'); + AddClass(TGroupBox, 'TWinControl'); + AddClass(TLabel, 'TControl'); + AddClass(TEdit, 'TWinControl'); + AddClass(TMemo, 'TWinControl'); + with AddClass(TCustomComboBox, 'TWinControl') do + begin + AddProperty('DroppedDown', 'Boolean', GetProp, SetProp); + AddProperty('ItemIndex', 'Integer', GetProp, SetProp); + AddEvent('OnChange', TfsNotifyEvent); + AddEvent('OnDropDown', TfsNotifyEvent); + AddEvent('OnCloseUp', TfsNotifyEvent); + end; + AddClass(TComboBox, 'TCustomComboBox'); + AddClass(TButton, 'TWinControl'); + AddClass(TCheckBox, 'TWinControl'); + AddClass(TRadioButton, 'TWinControl'); + with AddClass(TCustomListBox, 'TWinControl') do + begin + AddProperty('ItemIndex', 'Integer', GetProp, SetProp); + AddProperty('SelCount', 'Integer', GetProp, nil); + AddIndexProperty('Selected', 'Integer', 'Boolean', CallMethod); + end; + AddClass(TListBox, 'TCustomListBox'); + AddClass(TControlScrollBar, 'TPersistent'); + AddClass(TScrollingWinControl, 'TWinControl'); + AddClass(TScrollBox, 'TScrollingWinControl'); + with AddClass(TCustomForm, 'TScrollingWinControl') do + begin + AddMethod('procedure Close', CallMethod); + AddMethod('procedure Hide', CallMethod); + AddMethod('procedure Show', CallMethod); + AddMethod('function ShowModal: Integer', CallMethod); + AddEvent('OnActivate', TfsNotifyEvent); + AddEvent('OnClose', TfsCloseEvent); + AddEvent('OnCloseQuery', TfsCloseQueryEvent); + AddEvent('OnCreate', TfsNotifyEvent); + AddEvent('OnDestroy', TfsNotifyEvent); + AddEvent('OnDeactivate', TfsNotifyEvent); + AddEvent('OnHide', TfsNotifyEvent); + AddEvent('OnPaint', TfsNotifyEvent); + AddEvent('OnShow', TfsNotifyEvent); + AddProperty('Canvas', 'TCanvas', GetProp, nil); + AddProperty('ModalResult', 'Integer', GetProp, SetProp); + end; + AddClass(TForm, 'TCustomForm'); + AddClass(TDataModule, 'TComponent'); + with AddClass(TApplication, 'TComponent') do + begin + AddMethod('procedure Minimize', CallMethod); + AddMethod('procedure ProcessMessages', CallMethod); + AddMethod('procedure Restore', CallMethod); + AddProperty('ExeName', 'String', GetProp, nil); + end; + AddObject('Application', Application); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +var + Form: TCustomForm; +begin + Result := 0; + + if ClassType = TControl then + begin + if MethodName = 'HIDE' then + TControl(Instance).Hide + else if MethodName = 'SHOW' then + TControl(Instance).Show + else if MethodName = 'SETBOUNDS' then + TControl(Instance).SetBounds(Caller.Params[0], Caller.Params[1], Caller.Params[2], Caller.Params[3]) + end + else if ClassType = TWinControl then + begin + if MethodName = 'SETFOCUS' then + TWinControl(Instance).SetFocus + end + else if ClassType = TCustomListBox then + begin + if MethodName = 'SELECTED.GET' then + Result := TCustomListBox(Instance).Selected[Caller.Params[0]] + else if MethodName = 'SELECTED.SET' then + TCustomListBox(Instance).Selected[Caller.Params[0]] := Caller.Params[1] + end + else if ClassType = TCustomForm then + begin + Form := TCustomForm(Instance); + if MethodName = 'CLOSE' then + Form.Close + else if MethodName = 'HIDE' then + Form.Hide + else if MethodName = 'SHOW' then + Form.Show + else if MethodName = 'SHOWMODAL' then + Result := Form.ShowModal; + end + else if ClassType = TApplication then + begin + if MethodName = 'MINIMIZE' then + TApplication(Instance).Minimize + else if MethodName = 'PROCESSMESSAGES' then + TApplication(Instance).ProcessMessages + else if MethodName = 'RESTORE' then + TApplication(Instance).Restore + end +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TControl then + begin + if PropName = 'PARENT' then + Result := Integer(TControl(Instance).Parent) + end + else if ClassType = TCustomComboBox then + begin + if PropName = 'DROPPEDDOWN' then + Result := TCustomComboBox(Instance).DroppedDown + else if PropName = 'ITEMINDEX' then + Result := TCustomComboBox(Instance).ItemIndex + end + else if ClassType = TCustomListBox then + begin + if PropName = 'SELCOUNT' then + Result := TCustomListBox(Instance).SelCount + else if PropName = 'ITEMINDEX' then + Result := TCustomListBox(Instance).ItemIndex + end + else if ClassType = TCustomForm then + begin + if PropName = 'MODALRESULT' then + Result := TCustomForm(Instance).ModalResult + else if PropName = 'CANVAS' then + Result := Integer(TCustomForm(Instance).Canvas) + end + else if ClassType = TApplication then + begin + if PropName = 'EXENAME' then + Result := TApplication(Instance).ExeName + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + if ClassType = TControl then + begin + if PropName = 'PARENT' then + TControl(Instance).Parent := TWinControl(Integer(Value)) + end + else if ClassType = TCustomComboBox then + begin + if PropName = 'DROPPEDDOWN' then + TCustomComboBox(Instance).DroppedDown := Value + else if PropName = 'ITEMINDEX' then + TCustomComboBox(Instance).ItemIndex := Value + end + else if ClassType = TCustomListBox then + begin + if PropName = 'ITEMINDEX' then + TCustomListBox(Instance).ItemIndex := Value + end + else if ClassType = TCustomForm then + begin + if PropName = 'MODALRESULT' then + TCustomForm(Instance).ModalResult := Value + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_igraphicsrtti.pas b/official/4.8.11/FastScript/fs_igraphicsrtti.pas new file mode 100644 index 0000000..8a98f1c --- /dev/null +++ b/official/4.8.11/FastScript/fs_igraphicsrtti.pas @@ -0,0 +1,249 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Graphics.pas classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_igraphicsrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_iclassesrtti +{$IFDEF CLX} +, QGraphics +{$ELSE} +, Graphics +{$ENDIF}; + +type + TfsGraphicsRTTI = class(TComponent); // fake component + + +implementation + +type + THackGraphic = class(TGraphic) + end; + + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); + procedure GetColorProc(const Name: String); + public + constructor Create(AScript: TfsScript); override; + end; + + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + GetColorValues(GetColorProc); + AddEnumSet('TFontStyles', 'fsBold, fsItalic, fsUnderline, fsStrikeout'); + AddEnum('TFontPitch', 'fpDefault, fpVariable, fpFixed'); + AddEnum('TPenStyle', 'psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame'); + AddEnum('TPenMode', 'pmBlack, pmWhite, pmNop, pmNot, pmCopy, pmNotCopy, pmMergePenNot, ' + + 'pmMaskPenNot, pmMergeNotPen, pmMaskNotPen, pmMerge, pmNotMerge, pmMask, pmNotMask, pmXor, pmNotXor'); + AddEnum('TBrushStyle', 'bsSolid, bsClear, bsHorizontal, bsVertical, ' + + 'bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross'); + + with AddClass(TFont, 'TPersistent') do + AddConstructor('constructor Create', CallMethod); + with AddClass(TPen, 'TPersistent') do + AddConstructor('constructor Create', CallMethod); + with AddClass(TBrush, 'TPersistent') do + AddConstructor('constructor Create', CallMethod); + with AddClass(TCanvas, 'TPersistent') do + begin + AddConstructor('constructor Create', CallMethod); + AddMethod('procedure Draw(X, Y: Integer; Graphic: TGraphic)', CallMethod); + AddMethod('procedure Ellipse(X1, Y1, X2, Y2: Integer)', CallMethod); + AddMethod('procedure LineTo(X, Y: Integer)', CallMethod); + AddMethod('procedure MoveTo(X, Y: Integer)', CallMethod); + AddMethod('procedure Rectangle(X1, Y1, X2, Y2: Integer)', CallMethod); + AddMethod('procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer)', CallMethod); + AddMethod('procedure StretchDraw(X1, Y1, X2, Y2: Integer; Graphic: TGraphic)', CallMethod); + AddMethod('function TextHeight(const Text: string): Integer', CallMethod); + AddMethod('procedure TextOut(X, Y: Integer; const Text: string)', CallMethod); + AddMethod('function TextWidth(const Text: string): Integer', CallMethod); +{$IFNDEF CLX} + AddIndexProperty('Pixels', 'Integer, Integer', 'TColor', CallMethod); +{$ENDIF} + end; + with AddClass(TGraphic, 'TPersistent') do + begin + AddConstructor('constructor Create', CallMethod); + AddMethod('procedure LoadFromFile(const Filename: string)', CallMethod); + AddMethod('procedure SaveToFile(const Filename: string)', CallMethod); + AddProperty('Height', 'Integer', GetProp, SetProp); + AddProperty('Width', 'Integer', GetProp, SetProp); + end; + with AddClass(TPicture, 'TPersistent') do + begin + AddMethod('procedure LoadFromFile(const Filename: string)', CallMethod); + AddMethod('procedure SaveToFile(const Filename: string)', CallMethod); + AddProperty('Height', 'Integer', GetProp, nil); + AddProperty('Width', 'Integer', GetProp, nil); + end; +{$IFNDEF CROSS_COMPILE} + AddClass(TMetafile, 'TGraphic'); + with AddClass(TMetafileCanvas, 'TCanvas') do + AddConstructor('constructor Create(AMetafile: TMetafile; ReferenceDevice: Integer)', CallMethod); +{$ENDIF} + with AddClass(TBitmap, 'TGraphic') do + AddProperty('Canvas', 'TCanvas', GetProp); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant; +var + _Canvas: TCanvas; +begin + Result := 0; + + if ClassType = TFont then + begin + if MethodName = 'CREATE' then + Result := Integer(TFont(Instance).Create) + end + else if ClassType = TPen then + begin + if MethodName = 'CREATE' then + Result := Integer(TPen(Instance).Create) + end + else if ClassType = TBrush then + begin + if MethodName = 'CREATE' then + Result := Integer(TBrush(Instance).Create) + end + else if ClassType = TCanvas then + begin + _Canvas := TCanvas(Instance); + + if MethodName = 'CREATE' then + Result := Integer(TCanvas(Instance).Create) + else if MethodName = 'DRAW' then + _Canvas.Draw(Caller.Params[0], Caller.Params[1], TGraphic(Integer(Caller.Params[2]))) + else if MethodName = 'ELLIPSE' then + _Canvas.Ellipse(Caller.Params[0], Caller.Params[1], Caller.Params[2], Caller.Params[3]) + else if MethodName = 'LINETO' then + _Canvas.LineTo(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'MOVETO' then + _Canvas.MoveTo(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'RECTANGLE' then + _Canvas.Rectangle(Caller.Params[0], Caller.Params[1], Caller.Params[2], Caller.Params[3]) + else if MethodName = 'ROUNDRECT' then + _Canvas.RoundRect(Caller.Params[0], Caller.Params[1], Caller.Params[2], Caller.Params[3], Caller.Params[4], Caller.Params[5]) + else if MethodName = 'STRETCHDRAW' then + _Canvas.StretchDraw(Rect(Caller.Params[0], Caller.Params[1], Caller.Params[2], Caller.Params[3]), TGraphic(Integer(Caller.Params[4]))) + else if MethodName = 'TEXTHEIGHT' then + Result := _Canvas.TextHeight(Caller.Params[0]) + else if MethodName = 'TEXTOUT' then + _Canvas.TextOut(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'TEXTWIDTH' then + Result := _Canvas.TextWidth(Caller.Params[0]) +{$IFNDEF CLX} + else if MethodName = 'PIXELS.GET' then + Result := _Canvas.Pixels[Caller.Params[0], Caller.Params[1]] + else if MethodName = 'PIXELS.SET' then + _Canvas.Pixels[Caller.Params[0], Caller.Params[1]] := Caller.Params[2] +{$ENDIF} + end + else if ClassType = TGraphic then + begin + if MethodName = 'CREATE' then + Result := Integer(THackGraphic(Instance).Create) + else if MethodName = 'LOADFROMFILE' then + TGraphic(Instance).LoadFromFile(Caller.Params[0]) + else if MethodName = 'SAVETOFILE' then + TGraphic(Instance).SaveToFile(Caller.Params[0]) + end + else if ClassType = TPicture then + begin + if MethodName = 'LOADFROMFILE' then + TPicture(Instance).LoadFromFile(Caller.Params[0]) + else if MethodName = 'SAVETOFILE' then + TPicture(Instance).SaveToFile(Caller.Params[0]) + end +{$IFNDEF CROSS_COMPILE} + else if ClassType = TMetafileCanvas then + begin + if MethodName = 'CREATE' then + Result := Integer(TMetafileCanvas(Instance).Create(TMetafile(Integer(Caller.Params[0])), Caller.Params[1])) + end +{$ENDIF} +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TGraphic then + begin + if PropName = 'HEIGHT' then + Result := TGraphic(Instance).Height + else if PropName = 'WIDTH' then + Result := TGraphic(Instance).Width + end + else if ClassType = TPicture then + begin + if PropName = 'HEIGHT' then + Result := TPicture(Instance).Height + else if PropName = 'WIDTH' then + Result := TPicture(Instance).Width + end + else if ClassType = TBitmap then + begin + if PropName = 'CANVAS' then + Result := Integer(TBitmap(Instance).Canvas) + end +end; + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant); +begin + if ClassType = TGraphic then + begin + if PropName = 'HEIGHT' then + TGraphic(Instance).Height := Value + else if PropName = 'WIDTH' then + TGraphic(Instance).Width := Value + end +end; + +procedure TFunctions.GetColorProc(const Name: String); +var + c: Integer; +begin + IdentToColor(Name, c); + Script.AddConst(Name, 'Integer', c); +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iibxreg.pas b/official/4.8.11/FastScript/fs_iibxreg.pas new file mode 100644 index 0000000..1ceab8b --- /dev/null +++ b/official/4.8.11/FastScript/fs_iibxreg.pas @@ -0,0 +1,39 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Registration unit } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iibxreg; + +{$i fs.inc} + +interface + + +procedure Register; + +implementation + +uses + Classes +{$IFNDEF Delphi6} +, DsgnIntf +{$ELSE} +, DesignIntf +{$ENDIF} +, fs_iibxrtti; + +{-----------------------------------------------------------------------} + +procedure Register; +begin + RegisterComponents('FastScript', [TfsIBXRTTI]); +end; + +end. diff --git a/official/4.8.11/FastScript/fs_iibxrtti.pas b/official/4.8.11/FastScript/fs_iibxrtti.pas new file mode 100644 index 0000000..6f858ea --- /dev/null +++ b/official/4.8.11/FastScript/fs_iibxrtti.pas @@ -0,0 +1,117 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ IBX classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iibxrtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_itools, fs_idbrtti, db, ibdatabase, + IBCustomDataSet, IBQuery, IBTable, IBStoredProc; + +type + TfsIBXRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class (TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; const MethodName: + String; Caller: TfsMethodHelper): Variant; + function RecordCount(Instance: TObject; ClassType: TClass; const PropName: + String): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddClass(TIBDataBase, 'TComponent'); + + with AddClass(TIBTransaction, 'TComponent') do + begin + AddMethod('procedure Commit', CallMethod); + AddMethod('procedure RollBack', CallMethod); + AddMethod('procedure StartTransaction', CallMethod); + end; + + AddClass(TIBCustomDataSet, 'TDataSet'); + AddClass(TIBTable, 'TIBCustomDataSet'); + with AddClass(TIBQuery, 'TIBCustomDataSet') do + begin + AddMethod('procedure ExecSQL', CallMethod); + AddMethod('procedure FetchAll', CallMethod); + AddProperty('RecordCount', 'Integer',RecordCount, nil); + end; + with AddClass(TIBStoredProc, 'TIBCustomDataSet') do + AddMethod('procedure ExecProc', CallMethod); + end; +end; + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; const + MethodName: String; Caller: TfsMethodHelper): Variant; +begin + Result := 0; + + if ClassType = TIBQuery then + begin + if MethodName = 'EXECSQL' then + TIBQuery(Instance).ExecSQL + else + if MethodName = 'FETCHALL' then + TIBQuery(Instance).FETCHALL; + end + else + if ClassType = TIBStoredProc then + begin + if MethodName = 'EXECPROC' then + TIBStoredProc(Instance).ExecProc + end + else + if(ClassType = TIBTransaction) AND (MethodName = 'COMMIT') then + TIBTransaction(Instance).Commit + else + if (ClassType = TIBTransaction) AND (MethodName = 'ROLLBACK') then + TIBTransaction(Instance).RollBack + else + if(ClassType = TIBTransaction) AND (MethodName = 'STARTTRANSACTION') then + TIBTransaction(Instance).StartTransaction; + +end; + +function TFunctions.RecordCount(Instance: TObject; ClassType: TClass; const + PropName: String): Variant; +begin + Result:=0; + if (ClassType = TIBQuery) AND (PropName = 'RECORDCOUNT') then + Result:=TIBQuery(Instance).RecordCount; + +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iilparser.pas b/official/4.8.11/FastScript/fs_iilparser.pas new file mode 100644 index 0000000..f6cdd68 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iilparser.pas @@ -0,0 +1,2032 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Intermediate Language parser } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iilparser; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, fs_iparser, fs_iexpression, fs_xml +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfsEmitOp = (emNone, emCreate, emFree); + +{ TfsILParser performs the syntax analyze of source code. Source code + can be on ANY language. Grammars are stored in the XML file and + can be easily changed to support any structured language. Currently + supported languages are Pascal, C++, Basic and Java subsets. + + The result of the analyze (function MakeScript) is the output XML script + (called Intermediate Language). This output processed by the ParseILScript + method. This method creates the program structure (defined in the + fs_Interpreter unit) and fills it by the data } + + TfsILParser = class(TObject) + private + FErrorPos: String; + FGrammar: TfsXMLDocument; + FILScript: TfsXMLDocument; + FLangName: String; + FNeedDeclareVars: Boolean; + FParser: TfsParser; + FProgram: TfsScript; + FProgRoot: TfsXMLItem; + FRoot: TfsXMLItem; + FUnitName: String; + FUsesList: TStrings; + FWithList: TStringList; + function PropPos(xi: TfsXMLItem): String; + procedure ErrorPos(xi: TfsXMLItem); + procedure CheckIdent(Prog: TfsScript; const Name: String); + function FindClass(const TypeName: String): TfsClassVariable; + procedure CheckTypeCompatibility(Var1, Var2: TfsCustomVariable); + function FindVar(Prog: TfsScript; const Name: String): TfsCustomVariable; + function FindType(s: String): TfsVarType; + function CreateVar(xi: TfsXMLItem; Prog: TfsScript; const Name: String; + Statement: TfsStatement = nil; CreateParam: Boolean = False; + IsVarParam: Boolean = False): TfsCustomVariable; + function DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression; + function DoExpression(xi: TfsXMLItem; Prog: TfsScript): TfsExpression; + procedure DoUses(xi: TfsXMLItem; Prog: TfsScript); + procedure DoVar(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoConst(xi: TfsXMLItem; Prog: TfsScript); + procedure DoParameters(xi: TfsXMLItem; v: TfsProcVariable); + procedure DoProc1(xi: TfsXMLItem; Prog: TfsScript); + procedure DoProc2(xi: TfsXMLItem; Prog: TfsScript); + procedure DoFunc1(xi: TfsXMLItem; Prog: TfsScript); + procedure DoFunc2(xi: TfsXMLItem; Prog: TfsScript); + procedure DoAssign(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoCall(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoIf(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoVbFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoCppFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoWhile(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoRepeat(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoCase(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoTry(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoBreak(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoContinue(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoExit(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoReturn(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoWith(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoDelete(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoCompoundStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); + procedure DoProgram(xi: TfsXMLItem; Prog: TfsScript); + public + constructor Create(AProgram: TfsScript); + destructor Destroy; override; + + procedure SelectLanguage(const LangName: String); + { convert the input script to the Intermediate Language } + function MakeILScript(const Text: String): Boolean; + { parse IL } + procedure ParseILScript; + { this method is needed here to implement late-binding } + function DoDesignator(xi: TfsXMLItem; Prog: TfsScript; + EmitOp: TfsEmitOp = emNone): TfsDesignator; + property ILScript: TfsXMLDocument read FILScript; + end; + + +implementation + +uses fs_itools, fs_iconst +{$IFDEF CROSS_COMPILE} +, Types +{$ELSE} +, Windows +{$ENDIF} +{$IFDEF OLE} +, fs_idisp +{$ENDIF}; + + +{ TfsILParser } + +constructor TfsILParser.Create(AProgram: TfsScript); +begin + FNeedDeclareVars := True; + FProgram := AProgram; + FGrammar := TfsXMLDocument.Create; + FILScript := TfsXMLDocument.Create; + FParser := TfsParser.Create; + FUsesList := TStringList.Create; + FWithList := TStringList.Create; +end; + +destructor TfsILParser.Destroy; +begin + FGrammar.Free; + FILScript.Free; + FParser.Free; + FUsesList.Free; + FWithList.Free; + inherited; +end; + +procedure TfsILParser.SelectLanguage(const LangName: String); +var + i: Integer; + Name, PropText: String; + xi: TfsXMLItem; + ParserRoot: TfsXMLItem; + ss: TStringStream; +begin + FParser.Clear; + FLangName := LangName; + ss := TStringStream.Create(fsGetLanguage(LangName)); + try + FGrammar.LoadFromStream(ss); + finally + ss.Free; + end; + + FRoot := FGrammar.Root; + ParserRoot := FRoot.FindItem('parser'); + + xi := ParserRoot.FindItem('keywords'); + for i := 0 to xi.Count - 1 do + FParser.Keywords.Add(xi[i].Name); + for i := 0 to ParserRoot.Count - 1 do + begin + Name := LowerCase(ParserRoot[i].Name); + PropText := ParserRoot[i].Prop['text']; + if Name = 'identchars' then + FParser.ConstructCharset(PropText) + else if Name = 'commentline1' then + FParser.CommentLine1 := PropText + else if Name = 'commentline2' then + FParser.CommentLine2 := PropText + else if Name = 'commentblock1' then + FParser.CommentBlock1 := PropText + else if Name = 'commentblock2' then + FParser.CommentBlock2 := PropText + else if Name = 'stringquotes' then + FParser.StringQuotes := PropText + else if Name = 'hexsequence' then + FParser.HexSequence := PropText + else if Name = 'specstrchar' then + begin + if PropText = '1' then + FParser.SpecStrChar := true; + end + else if Name = 'declarevars' then + begin + if PropText = '0' then + FNeedDeclareVars := False; + end + else if Name = 'skipeol' then + begin + if PropText = '0' then + FParser.SkipEOL := False; + end + else if Name = 'skipchar' then + FParser.SkipChar := PropText + else if Name = 'casesensitive' then + begin + if PropText = '1' then + FParser.CaseSensitive := True; + end + end; + + if FProgram.ExtendedCharset then + for i := 128 to 255 do + FParser.IdentifierCharset := FParser.IdentifierCharset + [Chr(i)]; +end; + +function TfsILParser.MakeILScript(const Text: String): Boolean; +var + FList: TStrings; + FStream: TStream; + FErrorMsg: String; + FErrorPos: String; + FTermError: Boolean; + i: Integer; + + function Run(xi: TfsXMLItem): Boolean; + var + i, j, ParsPos, ParsPos1, LoopPos, ListPos: Integer; + s, NodeName, Token, PropText, PropAdd, PropAddText, PropNode: String; + Completed, TopLevelNode, Flag: Boolean; + const + PathD = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF} + procedure DoInclude(const Name: String); + var + sl: TStringList; + p: TfsILParser; + ss: TStringStream; + s, UnitPath: String; + idx: Integer; + begin + if FUsesList.IndexOf(Name) <> -1 then + Exit; + FUsesList.Add(Name); + sl := TStringList.Create; + try + if Assigned(FProgram.OnGetUnit) then + begin + s := ''; + FProgram.OnGetUnit(FProgram, Name, s); + sl.Text := s; + end + else + begin + UnitPath := ''; + for idx := 0 to FProgram.IncludePath.Count - 1 do + begin + UnitPath := FProgram.IncludePath[idx]; + if (UnitPath <> '') and (PathD <> UnitPath[Length(UnitPath)]) then + UnitPath := UnitPath + PathD; + if FileExists(UnitPath + Name) then + break; + end; + sl.LoadFromFile(UnitPath + Name); + end; + + p := TfsILParser.Create(FProgram); + p.FUnitName := Name; + ss := TStringStream.Create(''); + try + s := ''; + if sl.Count > 0 then + begin + p.SelectLanguage(FLangName); + p.FUsesList.Assign(FUsesList); + if p.MakeILScript(sl.Text) then + begin + FUsesList.Assign(p.FUsesList); + p.ILScript.SaveToStream(ss); + s := ss.DataString; + Delete(s, 1, Pos('?>', s) + 1); + end + else + begin + FErrorMsg := FProgram.ErrorMsg; + FErrorPos := FProgram.ErrorPos; + if FProgram.ErrorUnit = '' then + FProgram.ErrorUnit := Name; + end; + end; + + FList.Insert(ListPos, ''); + FList.Insert(ListPos, s); + FList.Insert(ListPos, ''); + Inc(ListPos, 3); + finally + p.Free; + ss.Free; + end; + finally + sl.Free; + end; + end; + + procedure CheckPropNode(Flag: Boolean); + var + i, ParsPos1: Integer; + s: String; + begin + if CompareText(PropNode, 'uses') = 0 then + begin + while FList.Count > ListPos do + begin + s := FList[FList.Count - 1]; + i := Pos('text="', s); + Delete(s, 1, i + 5); + i := Pos('" ', s); + Delete(s, i, 255); + DoInclude(Copy(s, 2, Length(s) - 2)); + FList.Delete(FList.Count - 1); + end; + end + else if PropNode <> '' then + if Flag then + begin + ParsPos1 := FParser.Position; + FParser.Position := ParsPos; + FParser.SkipSpaces; + + s := '<' + PropNode + ' pos="' + FParser.GetXYPosition + '"'; + FParser.Position := ParsPos1; + + if PropNode = 'expr' then + s := s + ' pos1="' + FParser.GetXYPosition + '"'; + s := s + '>'; + + FList.Insert(ListPos, s); + FList.Add(''); + end + else + begin + while FList.Count > ListPos do + FList.Delete(FList.Count - 1); + end; + end; + + procedure AddError(xi: TfsXMLItem); + var + PropErr: String; + xi1: TfsXMLItem; + begin + PropErr := xi.Prop['err']; + if (PropErr <> '') and (FErrorMsg = '') then + begin + xi1 := FRoot.FindItem('parser'); + xi1 := xi1.FindItem('errors'); + FErrorMsg := xi1.FindItem(PropErr).Prop['text']; + FParser.Position := ParsPos; + FParser.SkipSpaces; + FErrorPos := FParser.GetXYPosition; + FTermError := xi.Prop['term'] = '1'; + end; + end; + + begin + Result := True; + ParsPos := FParser.Position; + ListPos := FList.Count; + NodeName := AnsiLowerCase(xi.Name); + PropText := AnsiLowerCase(xi.Prop['text']); + PropNode := LowerCase(xi.Prop['node']); + TopLevelNode := xi.Parent = FRoot; + + Completed := False; + Flag := False; + Token := ''; + + if TopLevelNode then + Completed := True + else if NodeName = 'char' then + begin + if xi.Prop['skip'] <> '0' then + FParser.SkipSpaces; + Token := FParser.GetChar; + Flag := True; + end + else if NodeName = 'keyword' then + begin + Token := FParser.GetWord; + Flag := True; + end + else if NodeName = 'ident' then + begin + Token := FParser.GetIdent; + Flag := True; + end + else if NodeName = 'number' then + begin + Token := FParser.GetNumber; + Flag := True; + end + else if NodeName = 'string' then + begin + Token := FParser.GetString; + Flag := True; + end + else if NodeName = 'frstring' then + begin + Token := FParser.GetFRString; + s := FParser.GetXYPosition; + FList.Add(''); + FList.Add(''); + FList.Add(''); + FList.Add(''); + FList.Add(''); + FList.Add(''); + Flag := True; + end + else if NodeName = 'eol' then + Completed := FParser.GetEOL + else if NodeName = 'sequence' then + Completed := True + else if (NodeName = 'switch') or (NodeName = 'optionalswitch') then + begin + Completed := True; + + for i := 0 to xi.Count - 1 do + begin + Completed := Run(xi[i]); + if Completed then + break; + end; + + if not Completed then + if NodeName <> 'optionalswitch' then + begin + Result := False; + AddError(xi); + end; + Exit; + end + else if (NodeName = 'loop') or (NodeName = 'optionalloop') then + begin + j := 0; + repeat + Inc(j); + Flag := False; + LoopPos := FParser.Position; + + for i := 0 to xi.Count - 1 do + begin + Result := Run(xi[i]); + if not Result then + begin + Flag := True; + break; + end; + end; + + { try loop delimiter } + ParsPos1 := FParser.Position; + if Result and (PropText <> '') then + begin + FParser.SkipSpaces; + if FParser.GetChar <> PropText then + begin + FParser.Position := ParsPos1; + Flag := True; + end; + end; + + { avoid infinity loop } + if FParser.Position = LoopPos then + Flag := True; + until Flag; + + { at least one loop was succesful } + if j > 1 then + begin + { special case - now implemented only in "case" statement } + if (xi.Prop['skip'] = '1') or FTermError then + FErrorMsg := ''; + FParser.Position := ParsPos1; + Result := True; + end; + + if NodeName = 'optionalloop' then + begin + if not Result then + FParser.Position := ParsPos; + Result := True; + end; + Exit; + end + else if NodeName = 'optional' then + begin + for i := 0 to xi.Count - 1 do + if not Run(xi[i]) then + begin + FParser.Position := ParsPos; + break; + end; + Exit; + end + else + begin + j := FRoot.Find(NodeName); + if j = -1 then + raise Exception.Create(SInvalidLanguage); + + Completed := Run(FRoot[j]); + end; + + if Flag then + begin + if FParser.CaseSensitive then + Completed := (Token <> '') and + ((PropText = '') or (Token = PropText)) + else + Completed := (Token <> '') and + ((PropText = '') or (AnsiCompareText(Token, PropText) = 0)); + end; + + if not Completed then + begin + Result := False; + AddError(xi); + end + else + begin + if not TopLevelNode then + CheckPropNode(True); + + PropAdd := xi.Prop['add']; + PropAddText := xi.Prop['addtext']; + if PropAdd <> '' then + begin + if PropAddText = '' then + s := Token else + s := PropAddText; + FList.Add('<' + PropAdd + ' text="' + StrToXML(s) + '" pos="' + + FParser.GetXYPosition + '"/>'); + end; + + for i := 0 to xi.Count - 1 do + begin + Result := Run(xi[i]); + if not Result then + break; + end; + end; + + if not Result then + FParser.Position := ParsPos; + if TopLevelNode then + CheckPropNode(Result); + end; + +begin + FList := TStringList.Create; + FErrorMsg := ''; + FErrorPos := ''; + Result := False; + + try + FParser.Text := Text; + + i := 1; + if FParser.GetChar = '#' then + begin + if CompareText(FParser.GetIdent, 'language') = 0 then + begin + i := FParser.Position; +{$IFDEF LINUX} + while (i <= Length(Text)) and (Text[i] <> #10) do +{$ELSE} + while (i <= Length(Text)) and (Text[i] <> #13) do +{$ENDIF} + Inc(i); + SelectLanguage(Trim(Copy(Text, FParser.Position, i - FParser.Position))); + Inc(i, 2); + end; + end; + FParser.Position := i; + + if Run(FRoot.FindItem('program')) and (FErrorMsg = '') then + begin + FErrorMsg := ''; + FErrorPos := ''; + FStream := TMemoryStream.Create; + try + FList.Insert(0, ''); + FList.Insert(1, ''); + FList.Add(''); + FList.SaveToStream(FStream{$IFDEF Delphi12}, TEncoding.UTF8{$ENDIF}); +{$IFDEF Delphi12} + FStream.Position := 3; +{$ELSE} + FStream.Position := 0; +{$ENDIF} + FILScript.LoadFromStream(FStream); + FILScript.Root.Add.Assign(FRoot.FindItem('types')); +// uncomment the following lines to see what is IL script +// FILScript.AutoIndent := True; +// FILScript.SaveToFile(ExtractFilePath(ParamStr(0)) + 'out.xml'); + Result := True; + finally + FStream.Free; + end; + end; + + FProgram.ErrorPos := FErrorPos; + FProgram.ErrorMsg := FErrorMsg; + finally + FList.Free; + end; +end; + +procedure TfsILParser.ParseILScript; +begin + FWithList.Clear; + FProgram.ErrorUnit := ''; + FUnitName := ''; + + try + DoProgram(FILScript.Root, FProgram); + FProgram.ErrorPos := ''; + except + on e: Exception do + begin + FProgram.ErrorMsg := e.Message; + FProgram.ErrorPos := FErrorPos; + FProgram.ErrorUnit := FUnitName; + end; + end; +end; + +function TfsILParser.PropPos(xi: TfsXMLItem): String; +begin + Result := xi.Prop['pos']; +end; + +procedure TfsILParser.ErrorPos(xi: TfsXMLItem); +begin + FErrorPos := PropPos(xi); +end; + +procedure TfsILParser.CheckIdent(Prog: TfsScript; const Name: String); +begin + if Prog.FindLocal(Name) <> nil then + raise Exception.Create(SIdRedeclared + '''' + Name + ''''); +end; + +function TfsILParser.FindClass(const TypeName: String): TfsClassVariable; +begin + Result := FProgram.FindClass(TypeName); + if Result = nil then + raise Exception.Create(SUnknownType + '''' + TypeName + ''''); +end; + +procedure TfsILParser.CheckTypeCompatibility(Var1, Var2: TfsCustomVariable); +begin + if not AssignCompatible(Var1, Var2, FProgram) then + raise Exception.Create(SIncompatibleTypes + ': ''' + Var1.GetFullTypeName + + ''', ''' + Var2.GetFullTypeName + ''''); +end; + +function TfsILParser.FindVar(Prog: TfsScript; const Name: String): TfsCustomVariable; +begin + Result := Prog.Find(Name); + if Result = nil then + if not FNeedDeclareVars then + begin + Result := TfsVariable.Create(Name, fvtVariant, ''); + FProgram.Add(Name, Result); + end + else + raise Exception.Create(SIdUndeclared + '''' + Name + ''''); +end; + +function TfsILParser.FindType(s: String): TfsVarType; +var + xi: TfsXMLItem; +begin + xi := FProgRoot.FindItem('types'); + if xi.Find(s) <> -1 then + s := xi[xi.Find(s)].Prop['type'] + else + begin + xi := FGrammar.Root.FindItem('types'); + if xi.Find(s) <> -1 then + s := xi[xi.Find(s)].Prop['type'] + end; + Result := StrToVarType(s, FProgram); + if Result = fvtClass then + FindClass(s); +end; + +function TfsILParser.CreateVar(xi: TfsXMLItem; Prog: TfsScript; const Name: String; + Statement: TfsStatement = nil; CreateParam: Boolean = False; + IsVarParam: Boolean = False): TfsCustomVariable; +var + i, j: Integer; + Typ: TfsVarType; + TypeName: String; + RefItem: TfsCustomVariable; + InitValue: Variant; + InitItem: TfsXMLItem; + AssignStmt: TfsAssignmentStmt; + IsPascal: Boolean; + SourcePos: String; + + procedure DoArray(xi: TfsXMLItem); + var + i, n: Integer; + v: array of Integer; + Expr: TfsExpression; + begin + n := xi.Count; + SetLength(v, n * 2); + + for i := 0 to n - 1 do + begin + Expr := DoExpression(xi[i][0], Prog); + v[i * 2] := Expr.Value; + Expr.Free; + + if xi[i].Count = 2 then + begin + Expr := DoExpression(xi[i][1], Prog); + v[i * 2 + 1] := Expr.Value; + Expr.Free; + end + else + begin + v[i * 2 + 1] := v[i * 2] - 1; + v[i * 2] := 0; + end; + end; + + if n = 0 then + begin + SetLength(v, 2); + v[0] := 0; + v[1] := 0; + n := 1; + end; + + InitValue := VarArrayCreate(v, varVariant); + RefItem := TfsArrayHelper.Create('', n, Typ, TypeName); + Prog.Add('', RefItem); + v := nil; + Typ := fvtArray; + end; + + procedure DoInit(xi: TfsXMLItem); + var + Expr: TfsExpression; + Temp: TfsVariable; + begin + Temp := TfsVariable.Create('', Typ, TypeName); + try + Expr := DoExpression(xi[0], Prog); + InitValue := Expr.Value; + try + CheckTypeCompatibility(Temp, Expr); + finally + Expr.Free; + end; + finally + Temp.Free; + end; + end; + +begin + RefItem := nil; + InitItem := nil; + TypeName := 'Variant'; + IsPascal := False; + SourcePos := FErrorPos; + +(* + + + + + + + + ... + + + + + + + + - type may be first (in C-like languages) or last (in Pascal-like ones) + - type may be skipped (treated as variant) + - array and init may be either skipped, or after each + - array and init may be after each + - do not handle tags - they are handled in calling part +*) + + + { find the type } + for i := 0 to xi.Count - 1 do + if CompareText(xi[i].name, 'type') = 0 then + begin + IsPascal := i <> 0; + TypeName := xi[i].Prop['text']; + ErrorPos(xi[i]); + break; + end; + + Typ := FindType(TypeName); + case Typ of + fvtInt, fvtFloat, fvtClass: + InitValue := 0; + fvtBool: + InitValue := False; + fvtChar, fvtString: + InitValue := ''; + else + InitValue := Null; + end; + + { fing the tag corresponding to our variable } + for i := 0 to xi.Count - 1 do + if CompareText(xi[i].Prop['text'], Name) = 0 then + begin + { process and tags if any } + j := i + 1; + while (j < xi.Count) and (IsPascal or (CompareText(xi[j].Name, 'ident') <> 0)) do + begin + if CompareText(xi[j].Name, 'array') = 0 then + DoArray(xi[j]) + else if CompareText(xi[j].Name, 'init') = 0 then + begin + if Statement = nil then + DoInit(xi[j]); + InitItem := xi[j]; + end; + Inc(j); + end; + break; + end; + + if CreateParam then + Result := TfsParamItem.Create(Name, Typ, TypeName, InitItem <> nil, IsVarParam) + else if Typ in [fvtChar, fvtString] then + Result := TfsStringVariable.Create(Name, Typ, TypeName) else + Result := TfsVariable.Create(Name, Typ, TypeName); + + try + Result.Value := InitValue; + Result.RefItem := RefItem; + Result.SourcePos := SourcePos; + Result.SourceUnit := FUnitName; + Result.OnGetVarValue := FProgram.OnGetVarValue; + + { create init statement } + if (InitItem <> nil) and (Statement <> nil) then + begin + AssignStmt := TfsAssignmentStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(AssignStmt); + AssignStmt.Designator := TfsVariableDesignator.Create(Prog); + AssignStmt.Designator.RefItem := Result; + AssignStmt.Expression := DoExpression(InitItem[0], Prog); + CheckTypeCompatibility(Result, AssignStmt.Expression); + AssignStmt.Optimize; + end; + + except + on e: Exception do + begin + Result.Free; + raise; + end; + end; +end; + +function TfsILParser.DoDesignator(xi: TfsXMLItem; Prog: TfsScript; + EmitOp: TfsEmitOp = emNone): TfsDesignator; +var + i, j: Integer; + NodeName, NodeText, TypeName: String; + Expr: TfsExpression; + Item, PriorItem: TfsDesignatorItem; + ClassVar: TfsClassVariable; + StringVar: TfsStringVariable; + Typ: TfsVarType; + LateBinding, PriorIsIndex: Boolean; + NewDesignator: TfsDesignator; + PriorValue: Variant; + Component: TComponent; + + function FindInWithList(const Name: String; ResultDS: TfsDesignator; + Item: TfsDesignatorItem): Boolean; + var + i: Integer; + WithStmt: TfsWithStmt; + WithItem: TfsDesignatorItem; + ClassVar: TfsClassVariable; + xi1: TfsXMLItem; + begin + Result := False; + LateBinding := False; + for i := FWithList.Count - 1 downto 0 do + begin + { prevent checking non-local 'with' } + if Prog.FindLocal(FWithList[i]) = nil then + continue; + WithStmt := TfsWithStmt(FWithList.Objects[i]); + + if WithStmt.Variable.Typ = fvtVariant then + begin + { first check all known variables } + if Prog.Find(Name) <> nil then + Exit; + { if nothing found, create late binding information } + Item.Ref := WithStmt.Variable; + ResultDS.Finalize; + ResultDS.LateBindingXMLSource := TfsXMLItem.Create; + ResultDS.LateBindingXMLSource.Assign(xi); + xi1 := TfsXMLItem.Create; + xi1.Name := 'node'; + xi1.Text := 'text="' + FWithList[i] + '"'; + ResultDS.LateBindingXMLSource.InsertItem(0, xi1); + LateBinding := True; + Result := True; + break; + end + else + begin + ClassVar := FindClass(WithStmt.Variable.TypeName); + Item.Ref := ClassVar.Find(NodeText); + end; + + if Item.Ref <> nil then + begin + WithItem := TfsDesignatorItem.Create; + WithItem.Ref := WithStmt.Variable; + WithItem.SourcePos := Item.SourcePos; + + ResultDS.Remove(Item); + ResultDS.Add(WithItem); + ResultDS.Add(Item); + Result := True; + break; + end; + end; + end; + +{$IFDEF OLE} + procedure CreateOLEHelpers(Index: Integer); + var + i: Integer; + OLEHelper: TfsOLEHelper; + begin + for i := Index to xi.Count - 1 do + begin + ErrorPos(xi[i]); + NodeName := LowerCase(xi[i].Name); + NodeText := xi[i].Prop['text']; + + if (NodeName = 'node') and (NodeText <> '[') then + begin + Item := TfsDesignatorItem.Create; + Result.Add(Item); + Item.SourcePos := FErrorPos; + OLEHelper := TfsOLEHelper.Create(NodeText); + Prog.Add('', OLEHelper); + Item.Ref := OLEHelper; + end + else if NodeName = 'expr' then + begin + Expr := DoExpression(xi[i], Prog); + PriorItem := Result.Items[Result.Count - 1]; + PriorItem.Add(Expr); + PriorItem.Ref.Add(TfsParamItem.Create('', fvtVariant, '', False, False)); + end + end; + end; +{$ENDIF} + +begin + Result := TfsDesignator.Create(Prog); + try + + for i := 0 to xi.Count - 1 do + begin + ErrorPos(xi[i]); + NodeName := LowerCase(xi[i].Name); + NodeText := xi[i].Prop['text']; + + if NodeName = 'node' then + begin + Item := TfsDesignatorItem.Create; + Result.Add(Item); + Item.SourcePos := FErrorPos; + + if Result.Count = 1 then + begin + if not FindInWithList(NodeText, Result, Item) then + Item.Ref := FindVar(Prog, NodeText); + + { LateBinding flag turned on in the FindInWithList } + if LateBinding then + Exit; + { add .Create for cpp NEW statement, i.e convert o = new TObject + to o = TObject.Create } + if EmitOp = emCreate then + begin + if not (Item.Ref is TfsClassVariable) then + raise Exception.Create(SClassRequired); + ClassVar := TfsClassVariable(Item.Ref); + Item := TfsDesignatorItem.Create; + Result.Add(Item); + Item.Ref := ClassVar.Find('Create'); + end; + end + else + begin + PriorItem := Result.Items[Result.Count - 2]; + PriorIsIndex := (PriorItem.Ref is TfsMethodHelper) and + TfsMethodHelper(PriorItem.Ref).IndexMethod and not PriorItem.Flag; + Typ := PriorItem.Ref.Typ; + { late binding } + if (Typ = fvtVariant) and not PriorIsIndex then + begin + PriorValue := PriorItem.Ref.Value; + if VarIsNull(PriorValue) then + begin + Result.Remove(Item); + Item.Free; + Result.Finalize; + Result.LateBindingXMLSource := TfsXMLItem.Create; + Result.LateBindingXMLSource.Assign(xi); + Exit; + end + else + begin + if (TVarData(PriorValue).VType = varString) {$IFDEF Delphi12}or (TVarData(PriorValue).VType = varUString){$ENDIF} then + { accessing string elements } + Typ := fvtString + {$IFDEF OLE} + else if TVarData(PriorValue).VType = varDispatch then + begin + { calling ole } + Result.Remove(Item); + Item.Free; + CreateOLEHelpers(i); + Result.Finalize; + Exit; + end + {$ENDIF} + else if (TVarData(PriorValue).VType and varArray) = varArray then + begin + { accessing array elements } + if NodeText = '[' then { set ref to arrayhelper } + Item.Ref := FindVar(Prog, '__ArrayHelper') + else + raise Exception.Create(SIndexRequired); + continue; + end + else + begin + { accessing class items } + Typ := fvtClass; + PriorItem.Ref.TypeName := TObject(Integer(PriorItem.Ref.Value)).ClassName; + end; + end; + end; + + if PriorIsIndex then + begin + PriorItem.Flag := True; + Result.Remove(Item); { previous item is set up already } + Item.Free; + FErrorPos := PriorItem.SourcePos; + if NodeText <> '[' then + raise Exception.Create(SIndexRequired); + end + else if Typ = fvtString then + begin + if NodeText = '[' then { set ref to stringhelper } + Item.Ref := FindVar(Prog, '__StringHelper') + else + raise Exception.Create(SStringError); + end + else if Typ = fvtClass then + begin + TypeName := PriorItem.Ref.TypeName; + ClassVar := FindClass(TypeName); + + if NodeText = '[' then { default property } + begin + Item.Flag := True; + Item.Ref := ClassVar.DefProperty; + if Item.Ref = nil then + raise Exception.CreateFmt(SClassError, [TypeName]); + end + else { property or method } + begin + Item.Ref := ClassVar.Find(NodeText); + { property not found. Probably it's a form element such as button? } + if Item.Ref = nil then + begin + PriorValue := PriorItem.Ref.Value; + if ((VarIsNull(PriorValue) or (PriorValue = 0)) and not Prog.IsRunning) and Prog.UseClassLateBinding then + begin + { at compile time, we don't know anything about form elements. + So clear the designator items and use the late binding. } + Result.Remove(Item); + Item.Free; + while Result.Count > 1 do + begin + Item := Result.Items[Result.Count - 1]; + Result.Remove(Item); + Item.Free; + end; + Item := Result.Items[0]; + Result.Finalize; + Result.Typ := fvtVariant; + Result.LateBindingXMLSource := TfsXMLItem.Create; + Result.LateBindingXMLSource.Assign(xi); + Exit; + end + else + begin + { we at run time now. Try to search in the form's elements. } + if TObject(Integer(PriorValue)) is TComponent then + begin + Component := TComponent(Integer(PriorValue)).FindComponent(NodeText); + if Component <> nil then + begin + Item.Ref := TfsCustomVariable.Create('', fvtClass, Component.ClassName); + Item.Ref.Value := Integer(Component); + end; + end; + if Item.Ref = nil then + raise Exception.Create(SIdUndeclared + '''' + NodeText + ''''); + end + end; + end; + end + else if Typ = fvtArray then { set ref to array helper } + Item.Ref := PriorItem.Ref.RefItem + else + raise Exception.Create(SArrayRequired); + end; + end + else if NodeName = 'expr' then + begin + Expr := DoExpression(xi[i], Prog); + Result.Items[Result.Count - 1].Add(Expr); + end + else if NodeName = 'addr' then { @ operator } + begin + if xi.Count <> 2 then + raise Exception.Create(SVarRequired); + + Item := TfsDesignatorItem.Create; + Result.Add(Item); + ErrorPos(xi[1]); + Item.SourcePos := FErrorPos; + + { we just return the string containing a referenced item name. For + example, var s: String; procedure B1; begin end; s := @B1 + will assign 'B1' to the s } + StringVar := TfsStringVariable.Create('', fvtString, ''); + StringVar.Value := xi[1].Prop['text']; + Prog.Add('', StringVar); + Item.Ref := StringVar; + + break; + end; + end; + + if EmitOp = emFree then + begin + PriorItem := Result.Items[Result.Count - 1]; + if (PriorItem.Ref.Typ <> fvtClass) and (PriorItem.Ref.Typ <> fvtVariant) then + raise Exception.Create(SClassRequired); + Item := TfsDesignatorItem.Create; + Result.Add(Item); + ClassVar := FindClass('TObject'); + Item.Ref := ClassVar.Find('Free'); + end; + + Result.Finalize; + if Result.Kind <> dkOther then + begin + NewDesignator := nil; + if Result.Kind = dkVariable then + NewDesignator := TfsVariableDesignator.Create(Prog) + else if Result.Kind = dkStringArray then + NewDesignator := TfsStringDesignator.Create(Prog) + else if Result.Kind = dkArray then + NewDesignator := TfsArrayDesignator.Create(Prog); + + NewDesignator.Borrow(Result); + Result.Free; + Result := NewDesignator; + end; + + for i := 0 to Result.Count - 1 do + begin + Item := Result[i]; + FErrorPos := Item.SourcePos; + if Item.Ref is TfsDesignator then continue; + + if Item.Count < Item.Ref.GetNumberOfRequiredParams then + raise Exception.Create(SNotEnoughParams) + else if Item.Count > Item.Ref.Count then + raise Exception.Create(STooManyParams) + else if Item.Count <> Item.Ref.Count then { construct the default params } + for j := Item.Count to Item.Ref.Count - 1 do + begin + Expr := TfsExpression.Create(FProgram); + Item.Add(Expr); + Expr.AddConst(Item.Ref[j].DefValue); + Expr.Finalize; + end; + + for j := 0 to Item.Count - 1 do + begin + FErrorPos := Item[j].SourcePos; + CheckTypeCompatibility(Item.Ref[j], Item[j]); + end; + end; + + except + on e: Exception do + begin + Result.Free; + raise; + end; + end; +end; + +function TfsILParser.DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression; +var + i: Integer; + Name: String; +begin + Result := TfsSetExpression.Create('', fvtVariant, ''); + try + for i := 0 to xi.Count - 1 do + begin + Name := LowerCase(xi[i].Name); + if Name = 'expr' then + Result.Add(DoExpression(xi[i], Prog)) + else if Name = 'range' then + Result.Add(nil); + end; + + except + on e: Exception do + begin + Result.Free; + raise; + end; + end; +end; + +function TfsILParser.DoExpression(xi: TfsXMLItem; Prog: TfsScript): TfsExpression; +var + ErPos: String; + SourcePos1, SourcePos2: TPoint; + + procedure DoExpressionItems(xi: TfsXMLItem; Expression: TfsExpression); + var + i: Integer; + NodeName: String; + OpName: String; + begin + i := 0; + while i < xi.Count do + begin + ErrorPos(xi[i]); + Expression.SourcePos := FErrorPos; + NodeName := Lowercase(xi[i].Name); + OpName := xi[i].Prop['text']; + + if (NodeName = 'op') then + begin + OpName := LowerCase(OpName); + if (OpName = ')') or (i < xi.Count - 1) then + Expression.AddOperator(OpName); + end + else if (NodeName = 'number') or (NodeName = 'string') then + Expression.AddConst(ParserStringToVariant(OpName)) + else if NodeName = 'dsgn' then + Expression.AddDesignator(DoDesignator(xi[i], Prog)) + else if NodeName = 'set' then + Expression.AddSet(DoSet(xi[i], Prog)) + else if NodeName = 'new' then + Expression.AddDesignator(DoDesignator(xi[i][0], Prog, emCreate)) + else if NodeName = 'expr' then + DoExpressionItems(xi[i], Expression); + + Inc(i); + end; + end; + + function GetSource(pt1, pt2: TPoint): String; + var + i1, i2: Integer; + begin + i1 := FParser.GetPlainPosition(pt1); + i2 := FParser.GetPlainPosition(pt2); + if (i1 = -1) or (i2 = -1) then + Result := '' + else + Result := Copy(FParser.Text, i1, i2 - i1); + end; + +begin + Result := TfsExpression.Create(FProgram); + try + DoExpressionItems(xi, Result); + SourcePos1 := fsPosToPoint(PropPos(xi)); + SourcePos2 := fsPosToPoint(xi.Prop['pos1']); + Result.Source := GetSource(SourcePos1, SourcePos2); + + ErPos := Result.Finalize; + if ErPos <> '' then + begin + FErrorPos := ErPos; + raise Exception.Create(SIncompatibleTypes); + end; + + except + on e: Exception do + begin + Result.Free; + raise; + end; + end; +end; + +procedure TfsILParser.DoUses(xi: TfsXMLItem; Prog: TfsScript); +var + i: Integer; + SaveUnitName: String; + s: String; + sl: TStringList; + ms: TMemoryStream; + xd: TfsXMLDocument; +begin + SaveUnitName := FUnitName; + FUnitName := xi.Prop['unit']; + xd := nil; + + if Assigned(FProgram.OnGetILUnit) then + begin + s := ''; + FProgram.OnGetILUnit(FProgram, FUnitName, s); + if s <> '' then + begin + sl := TStringList.Create; + sl.Text := s; + + ms := TMemoryStream.Create; + sl.SaveToStream(ms); + sl.Free; + ms.Position := 0; + + xd := TfsXMLDocument.Create; + xd.LoadFromStream(ms); + ms.Free; + end; + end; + + if xd <> nil then + begin + try + DoProgram(xd.Root, Prog); + finally + xd.Free; + end; + end + else + begin + for i := 0 to xi.Count - 1 do + DoProgram(xi[i], Prog); + end; + + FUnitName := SaveUnitName; +end; + +procedure TfsILParser.DoVar(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Name: String; +begin + for i := 0 to xi.Count - 1 do + begin + ErrorPos(xi[i]); + if CompareText(xi[i].Name, 'ident') = 0 then + begin + Name := xi[i].Prop['text']; + CheckIdent(Prog, Name); + Prog.Add(Name, CreateVar(xi, Prog, Name, Statement)); + end; + end; +end; + +procedure TfsILParser.DoConst(xi: TfsXMLItem; Prog: TfsScript); +var + Name: String; + Expr: TfsExpression; + v: TfsVariable; +begin + Name := xi[0].Prop['text']; + ErrorPos(xi[0]); + CheckIdent(Prog, Name); + + Expr := DoExpression(xi[1], Prog); + v := TfsVariable.Create(Name, Expr.Typ, Expr.TypeName); + v.Value := Expr.Value; + v.IsReadOnly := True; + Expr.Free; + + Prog.Add(Name, v); +end; + +procedure TfsILParser.DoParameters(xi: TfsXMLItem; v: TfsProcVariable); +var + i: Integer; + s: String; + varParams: Boolean; + + procedure DoParam(xi: TfsXMLItem); + var + i: Integer; + Name: String; + Param: TfsParamItem; + varParam: Boolean; + begin + varParam := False; + + for i := 0 to xi.Count - 1 do + begin + ErrorPos(xi[i]); + if CompareText(xi[i].Name, 'varparam') = 0 then + varParam := True + else if CompareText(xi[i].Name, 'ident') = 0 then + begin + Name := xi[i].Prop['text']; + CheckIdent(v.Prog, Name); + Param := TfsParamItem(CreateVar(xi, v.Prog, Name, nil, True, + varParams or VarParam)); + Param.DefValue := Param.Value; + v.Add(Param); + v.Prog.Add(Name, Param); + varParam := False; + end; + end; + end; + +begin + if CompareText(xi.Name, 'parameters') <> 0 then Exit; + varParams := False; + for i := 0 to xi.Count - 1 do + begin + s := LowerCase(xi[i].Name); + if s = 'varparams' then + varParams := True + else if s = 'var' then + begin + DoParam(xi[i]); + varParams := False; + end; + end; +end; + +procedure TfsILParser.DoProc1(xi: TfsXMLItem; Prog: TfsScript); +var + i: Integer; + s, Name: String; + Proc: TfsProcVariable; +begin + ErrorPos(xi[0]); + Name := xi[0].Prop['text']; + CheckIdent(Prog, Name); + + Proc := TfsProcVariable.Create(Name, fvtInt, '', Prog, False); + Proc.SourcePos := PropPos(xi); + Proc.SourceUnit := FUnitName; + Prog.Add(Name, Proc); + + for i := 0 to xi.Count - 1 do + begin + s := LowerCase(xi[i].Name); + if s = 'parameters' then + DoParameters(xi[i], Proc); + end; +end; + +procedure TfsILParser.DoProc2(xi: TfsXMLItem; Prog: TfsScript); +var + Name: String; + Proc: TfsProcVariable; +begin + Name := xi[0].Prop['text']; + Proc := TfsProcVariable(FindVar(Prog, Name)); + DoProgram(xi, Proc.Prog); +end; + +procedure TfsILParser.DoFunc1(xi: TfsXMLItem; Prog: TfsScript); +var + i: Integer; + s, Name, TypeName: String; + Typ: TfsVarType; + Func: TfsProcVariable; +begin + Name := ''; + TypeName := ''; + Typ := fvtVariant; + + for i := 0 to xi.Count - 1 do + begin + ErrorPos(xi[i]); + s := LowerCase(xi[i].Name); + if s = 'type' then + begin + TypeName := xi[i].Prop['text']; + Typ := FindType(TypeName); + end + else if s = 'name' then + begin + Name := xi[i].Prop['text']; + CheckIdent(Prog, Name); + end + end; + + + Func := TfsProcVariable.Create(Name, Typ, TypeName, Prog, + CompareText(TypeName, 'void') <> 0); + Func.SourcePos := PropPos(xi); + Func.SourceUnit := FUnitName; + Prog.Add(Name, Func); + + for i := 0 to xi.Count - 1 do + begin + s := LowerCase(xi[i].Name); + if s = 'parameters' then + DoParameters(xi[i], Func); + end; +end; + +procedure TfsILParser.DoFunc2(xi: TfsXMLItem; Prog: TfsScript); +var + i: Integer; + s, Name: String; + Func: TfsProcVariable; +begin + Name := ''; + + for i := 0 to xi.Count - 1 do + begin + s := LowerCase(xi[i].Name); + if s = 'name' then + Name := xi[i].Prop['text']; + end; + + Func := TfsProcVariable(FindVar(Prog, Name)); + DoProgram(xi, Func.Prog); +end; + +procedure TfsILParser.DoAssign(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Stmt: TfsAssignmentStmt; + Designator: TfsDesignator; + Expression: TfsExpression; + Modificator: String; +begin + Designator := nil; + Expression := nil; + + try + Modificator := ' '; + Designator := DoDesignator(xi[0], Prog); + + i := 1; + if CompareText(xi[1].Name, 'modificator') = 0 then + begin + Modificator := xi[1].Prop['text']; + Inc(i); + end; + Expression := DoExpression(xi[i], Prog); + + if Designator.IsReadOnly then + raise Exception.Create(SLeftCantAssigned); + + CheckTypeCompatibility(Designator, Expression); + if Modificator = ' ' then + Modificator := Expression.Optimize(Designator); + except + on e: Exception do + begin + if Designator <> nil then + Designator.Free; + if Expression <> nil then + Expression.Free; + raise; + end; + end; + + case Modificator[1] of + '+': + Stmt := TfsAssignPlusStmt.Create(Prog, FUnitName, PropPos(xi)); + '-': + Stmt := TfsAssignMinusStmt.Create(Prog, FUnitName, PropPos(xi)); + '*': + Stmt := TfsAssignMulStmt.Create(Prog, FUnitName, PropPos(xi)); + '/': + Stmt := TfsAssignDivStmt.Create(Prog, FUnitName, PropPos(xi)); + else + Stmt := TfsAssignmentStmt.Create(Prog, FUnitName, PropPos(xi)); + end; + + Statement.Add(Stmt); + Stmt.Designator := Designator; + Stmt.Expression := Expression; + Stmt.Optimize; + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoCall(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsCallStmt; +begin + Stmt := TfsCallStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + Stmt.Designator := DoDesignator(xi[0], Prog); + if xi.Count > 1 then + begin + Stmt.Modificator := xi[1].Prop['text']; + if Stmt.Designator.IsReadOnly then + raise Exception.Create(SLeftCantAssigned); + end; + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoIf(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + s: String; + Stmt: TfsIfStmt; +begin + Stmt := TfsIfStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + Stmt.Condition := DoExpression(xi[0], Prog); + + for i := 1 to xi.Count - 1 do + begin + s := Lowercase(xi[i].Name); + if s = 'thenstmt' then + DoCompoundStmt(xi[1], Prog, Stmt) + else if s = 'elsestmt' then + DoCompoundStmt(xi[2], Prog, Stmt.ElseStmt); + end; + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Stmt: TfsForStmt; +begin + Stmt := TfsForStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + ErrorPos(xi[0]); + Stmt.Variable := FindVar(Prog, xi[0].Prop['text']); + if not ((Stmt.Variable is TfsVariable) and + (Stmt.Variable.Typ in [fvtInt, fvtVariant, fvtFloat])) then + raise Exception.Create(SForError); + + Stmt.BeginValue := DoExpression(xi[1], Prog); + CheckTypeCompatibility(Stmt.Variable, Stmt.BeginValue); + + i := 2; + if CompareText(xi[2].Name, 'downto') = 0 then + begin + Stmt.Down := True; + Inc(i); + end; + + Stmt.EndValue := DoExpression(xi[i], Prog); + CheckTypeCompatibility(Stmt.Variable, Stmt.EndValue); + if i + 1 < xi.Count then + DoStmt(xi[i + 1], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoVbFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Stmt: TfsVbForStmt; +begin + Stmt := TfsVbForStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + ErrorPos(xi[0]); + Stmt.Variable := FindVar(Prog, xi[0].Prop['text']); + if not ((Stmt.Variable is TfsVariable) and + (Stmt.Variable.Typ in [fvtInt, fvtVariant, fvtFloat])) then + raise Exception.Create(SForError); + + Stmt.BeginValue := DoExpression(xi[1], Prog); + CheckTypeCompatibility(Stmt.Variable, Stmt.BeginValue); + + Stmt.EndValue := DoExpression(xi[2], Prog); + CheckTypeCompatibility(Stmt.Variable, Stmt.EndValue); + + i := 3; + if i < xi.Count then + if CompareText(xi[i].Name, 'expr') = 0 then + begin + Stmt.Step := DoExpression(xi[i], Prog); + CheckTypeCompatibility(Stmt.Variable, Stmt.Step); + Inc(i); + end; + + if i < xi.Count then + DoStmt(xi[i], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoCppFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsCppForStmt; +begin + Stmt := TfsCppForStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + DoStmt(xi[0], Prog, Stmt.FirstStmt); + Stmt.Expression := DoExpression(xi[1], Prog); + DoStmt(xi[2], Prog, Stmt.SecondStmt); + DoStmt(xi[3], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoWhile(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsWhileStmt; +begin + Stmt := TfsWhileStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + Stmt.Condition := DoExpression(xi[0], Prog); + if xi.Count > 1 then + DoStmt(xi[1], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoRepeat(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i, j: Integer; + Stmt: TfsRepeatStmt; +begin + Stmt := TfsRepeatStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + + j := xi.Count - 1; + if CompareText(xi[j].Name, 'inverse') = 0 then + begin + Stmt.InverseCondition := True; + Dec(j); + end; + Stmt.Condition := DoExpression(xi[j], Prog); + Dec(j); + + for i := 0 to j do + DoStmt(xi[i], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoCase(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Stmt: TfsCaseStmt; + + procedure DoCaseSelector(xi: TfsXMLItem); + var + Selector: TfsCaseSelector; + begin + if (CompareText(xi.Name, 'caseselector') <> 0) or (xi.Count <> 2) then Exit; + Selector := TfsCaseSelector.Create(Prog, FUnitName, PropPos(xi)); + Stmt.Add(Selector); + + Selector.SetExpression := DoSet(xi[0], Prog); + DoStmt(xi[1], Prog, Selector); + end; + +begin + Stmt := TfsCaseStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + Stmt.Condition := DoExpression(xi[0], Prog); + + for i := 1 to xi.Count - 1 do + DoCaseSelector(xi[i]); + if CompareText(xi[xi.Count - 1].Name, 'caseselector') <> 0 then + DoStmt(xi[xi.Count - 1], Prog, Stmt.ElseStmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoTry(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; + Stmt: TfsTryStmt; +begin + Stmt := TfsTryStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + + for i := 0 to xi.Count - 1 do + if CompareText(xi[i].Name, 'exceptstmt') = 0 then + begin + Stmt.IsExcept := True; + DoCompoundStmt(xi[i], Prog, Stmt.ExceptStmt); + end + else if CompareText(xi[i].Name, 'finallystmt') = 0 then + DoCompoundStmt(xi[i], Prog, Stmt.ExceptStmt) + else + DoStmt(xi[i], Prog, Stmt); + + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoBreak(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsBreakStmt; +begin + Stmt := TfsBreakStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoContinue(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsContinueStmt; +begin + Stmt := TfsContinueStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoExit(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsExitStmt; +begin + Stmt := TfsExitStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoReturn(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + xi1: TfsXMLItem; +begin + if xi.Count = 1 then { "return expr" } + begin + xi1 := TfsXMLItem.Create; + xi1.Name := 'dsgn'; + xi.InsertItem(0, xi1); + with xi1.Add do + begin + Name := 'node'; + Text := 'text="Result" pos="' + xi[1].Prop['pos'] + '"'; + end; + + DoAssign(xi, Prog, Statement); + end; + + DoExit(xi, Prog, Statement); +end; + +procedure TfsILParser.DoWith(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + d: TfsDesignator; + i, n: Integer; + s: String; + v: TfsVariable; + Stmt: TfsWithStmt; + + function CreateUniqueVariable: String; + var + i: Integer; + begin + i := 0; + while (Prog.FindLocal(IntToStr(i)) <> nil) or + (FWithList.IndexOf(IntToStr(i)) <> -1) do + Inc(i); + Result := '_WithList_' + IntToStr(i); + end; + +begin + n := xi.Count - 1; + + for i := 0 to n - 1 do + begin + d := DoDesignator(xi[i], Prog); + if not ((d.Typ = fvtClass) or (d.Typ = fvtVariant)) then + begin + d.Free; + raise Exception.Create(SClassRequired); + end; + + { create local variable with unique name } + s := CreateUniqueVariable; + v := TfsVariable.Create(s, d.Typ, d.TypeName); + Prog.Add(s, v); + + Stmt := TfsWithStmt.Create(Prog, FUnitName, PropPos(xi)); + Stmt.Variable := v; + Stmt.Designator := d; + Statement.Add(Stmt); + FWithList.AddObject(s, Stmt); + end; + + DoStmt(xi[xi.Count - 1], Prog, Statement); + + for i := 0 to n - 1 do + FWithList.Delete(FWithList.Count - 1); + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoDelete(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + Stmt: TfsCallStmt; +begin + Stmt := TfsCallStmt.Create(Prog, FUnitName, PropPos(xi)); + Statement.Add(Stmt); + Stmt.Designator := DoDesignator(xi[0], Prog, emFree); + FProgram.AddCodeLine(FUnitName, PropPos(xi)); +end; + +procedure TfsILParser.DoCompoundStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + i: Integer; +begin + for i := 0 to xi.Count - 1 do + DoStmt(xi[i], Prog, Statement); +end; + +procedure TfsILParser.DoStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement); +var + s: String; +begin + s := LowerCase(xi.Name); + if s = 'assignstmt' then + DoAssign(xi, Prog, Statement) + else if s = 'callstmt' then + DoCall(xi, Prog, Statement) + else if s = 'ifstmt' then + DoIf(xi, Prog, Statement) + else if s = 'casestmt' then + DoCase(xi, Prog, Statement) + else if s = 'forstmt' then + DoFor(xi, Prog, Statement) + else if s = 'vbforstmt' then + DoVbFor(xi, Prog, Statement) + else if s = 'cppforstmt' then + DoCppFor(xi, Prog, Statement) + else if s = 'whilestmt' then + DoWhile(xi, Prog, Statement) + else if s = 'repeatstmt' then + DoRepeat(xi, Prog, Statement) + else if s = 'trystmt' then + DoTry(xi, Prog, Statement) + else if s = 'break' then + DoBreak(xi, Prog, Statement) + else if s = 'continue' then + DoContinue(xi, Prog, Statement) + else if s = 'exit' then + DoExit(xi, Prog, Statement) + else if s = 'return' then + DoReturn(xi, Prog, Statement) + else if s = 'with' then + DoWith(xi, Prog, Statement) + else if s = 'delete' then + DoDelete(xi, Prog, Statement) + else if s = 'compoundstmt' then + DoCompoundStmt(xi, Prog, Statement) + else if s = 'uses' then + DoUses(xi, Prog) + else if s = 'var' then + DoVar(xi, Prog, Statement) + else if s = 'const' then + DoConst(xi, Prog) + else if s = 'procedure' then + DoProc2(xi, Prog) + else if s = 'function' then + DoFunc2(xi, Prog) +end; + +procedure TfsILParser.DoProgram(xi: TfsXMLItem; Prog: TfsScript); +var + TempRoot: TfsXMLItem; + + procedure DoFirstPass(xi: TfsXMLItem); + var + i: Integer; + s: String; + begin + for i := 0 to xi.Count - 1 do + begin + s := LowerCase(xi[i].Name); + if s = 'compoundstmt' then + DoFirstPass(xi[i]) + else if s = 'procedure' then + DoProc1(xi[i], Prog) + else if s = 'function' then + DoFunc1(xi[i], Prog) + end; + end; + +begin + TempRoot := FProgRoot; + FProgRoot := xi; + DoFirstPass(xi); + DoCompoundStmt(xi, Prog, Prog.Statement); + FProgRoot := TempRoot; +end; + + +end. diff --git a/official/4.8.11/FastScript/fs_iinirtti.pas b/official/4.8.11/FastScript/fs_iinirtti.pas new file mode 100644 index 0000000..dd6ef6a --- /dev/null +++ b/official/4.8.11/FastScript/fs_iinirtti.pas @@ -0,0 +1,367 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ IniFiles.pas classes and functions } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{ Copyright (c) 2004-2007 } +{ by Stalker SoftWare } +{ } +{******************************************} + +unit fs_iinirtti; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_iinterpreter, IniFiles; + +type + TfsIniRTTI = class(TComponent); // fake component + + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; const PropName: String): Variant; + procedure SaveIniFileToStream(oIniFile: TCustomIniFile; oStream: TStream); + procedure LoadIniFileFromStream(oIniFile :TCustomIniFile; oStream :TStream); + procedure WriteTStrings(oIniFile: TCustomIniFile; const Section: String; Values: TStrings; IsClear :Boolean = True); + procedure ReadTStrings(oIniFile: TCustomIniFile; const Section: String; Values: TStrings; IsClear :Boolean = True); + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + + with AScript do + begin + with AddClass(TCustomIniFile, 'TObject') do + begin + AddConstructor('constructor Create(const FileName: String)', CallMethod); + AddMethod('function ReadInteger(const Section, Ident: String; Default: LongInt): LongInt', CallMethod); + AddMethod('procedure WriteInteger(const Section, Ident: String; Value: LongInt)', CallMethod); + AddMethod('function ReadBool(const Section, Ident: String; Default: Boolean): Boolean', CallMethod); + AddMethod('procedure WriteBool(const Section, Ident: String; Value: Boolean)', CallMethod); + AddMethod('function ReadDate(const Section, Name: String; Default: TDateTime): TDateTime', CallMethod); + AddMethod('procedure WriteDate(const Section, Name: String; Value: TDateTime)', CallMethod); + AddMethod('function ReadDateTime(const Section, Name: String; Default: TDateTime): TDateTime', CallMethod); + AddMethod('procedure WriteDateTime(const Section, Name: String; Value: TDateTime)', CallMethod); + AddMethod('function ReadFloat(const Section, Name: String; Default: Double): Double', CallMethod); + AddMethod('procedure WriteFloat(const Section, Name: String; Value: Double)', CallMethod); + AddMethod('function ReadTime(const Section, Name: String; Default: TDateTime): TDateTime', CallMethod); + AddMethod('procedure WriteTime(const Section, Name: String; Value: TDateTime);', CallMethod); +{$IFDEF DELPHI6} + AddMethod('function ReadBinaryStream(const Section, Name: String; Value: TStream): Integer', CallMethod); + AddMethod('procedure WriteBinaryStream(const Section, Name: String; Value: TStream)', CallMethod); +{$ENDIF} + AddMethod('function SectionExists(const Section: String): Boolean', CallMethod); + AddMethod('function ValueExists(const Section, Ident: String): Boolean', CallMethod); + + AddMethod('procedure WriteTStrings(const Section :String; Value :TStrings; IsClear :Boolean = True)', CallMethod); + AddMethod('function ReadTStrings(const Section :String; Value :TStrings; IsClear :Boolean = True): String;', CallMethod); + + AddProperty('FileName', 'String', GetProp); + end; + + with AddClass(TMemIniFile, 'TCustomIniFile') do + begin + AddConstructor('constructor Create(const FileName: String)', CallMethod); + AddMethod('procedure WriteString(const Section, Ident, Value: String)', CallMethod); + AddMethod('function ReadString(const Section, Ident, Default: String): String;', CallMethod); +{$IFDEF DELPHI6} + AddMethod('procedure ReadSectionValuesEx(const Section: String; Strings: TStrings)', CallMethod); +{$ENDIF} + AddMethod('procedure DeleteKey(const Section, Ident: String)', CallMethod); + AddMethod('procedure ReadSection(const Section: String; Strings: TStrings)', CallMethod); + AddMethod('procedure ReadSections(Strings: TStrings)', CallMethod); + AddMethod('procedure ReadSectionValues(const Section: String; Strings: TStrings)', CallMethod); + AddMethod('procedure EraseSection(const Section: String)', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure GetStrings(List: TStrings)', CallMethod); + AddMethod('procedure SetStrings(List: TStrings)', CallMethod); + AddMethod('procedure SaveIniFileToStream(oStream: TStream)', CallMethod); + AddMethod('procedure LoadIniFileFromStream(oStream: TStream)', CallMethod); + end; + + with AddClass(TIniFile, 'TCustomIniFile') do + begin + AddMethod('procedure WriteString(const Section, Ident, Value: String)', CallMethod); + AddMethod('function ReadString(const Section, Ident, Default: String): String;', CallMethod); +{$IFDEF DELPHI6} + AddMethod('procedure ReadSectionValuesEx(const Section: String; Strings: TStrings)', CallMethod); +{$ENDIF} + AddMethod('procedure DeleteKey(const Section, Ident: String)', CallMethod); + AddMethod('procedure ReadSection(const Section: String; Strings: TStrings)', CallMethod); + AddMethod('procedure ReadSections(Strings: TStrings)', CallMethod); + AddMethod('procedure ReadSectionValues(const Section: String; Strings: TStrings)', CallMethod); + AddMethod('procedure EraseSection(const Section: String)', CallMethod); + AddMethod('procedure SaveIniFileToStream(oStream: TStream)', CallMethod); + AddMethod('procedure LoadIniFileFromStream(oStream: TStream)', CallMethod); + end; + + end; + +end; + +{$HINTS OFF} +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; Caller: TfsMethodHelper): Variant; +var + oCustomIniFile: TCustomIniFile; + oMemIniFile: TMemIniFile; + oIniFile: TIniFile; + oList: TStrings; + nCou: Integer; + +begin + + Result := 0; + + if ClassType = TCustomIniFile then + begin + oCustomIniFile := TCustomIniFile(Instance); + if MethodName = 'CREATE' then + Result := Integer(oCustomIniFile.Create(Caller.Params[0])) + else if MethodName = 'WRITEINTEGER' then + oCustomIniFile.WriteInteger(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READINTEGER' then + Result := oCustomIniFile.ReadInteger(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'WRITEBOOL' then + oCustomIniFile.WriteBool(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READBOOL' then + Result := oCustomIniFile.ReadBool(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'WRITEDATE' then + oCustomIniFile.WriteDate(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READDATE' then + Result := oCustomIniFile.ReadDate(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'WRITEDATETIME' then + oCustomIniFile.WriteDateTime(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READDATETIME' then + Result := oCustomIniFile.ReadDateTime(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'WRITEFLOAT' then + oCustomIniFile.WriteFloat(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READFLOAT' then + Result := oCustomIniFile.ReadFloat(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'WRITETIME' then + oCustomIniFile.WriteTime(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READTIME' then + Result := oCustomIniFile.ReadTime(Caller.Params[0], Caller.Params[1], Caller.Params[2]) +{$IFDEF DELPHI6} + else if MethodName = 'WRITEBINARYSTREAM' then + oCustomIniFile.WriteBinaryStream(Caller.Params[0], Caller.Params[1], TStream(Integer(Caller.Params[2]))) + else if MethodName = 'READBINARYSTREAM' then + Result := oCustomIniFile.ReadBinaryStream(Caller.Params[0], Caller.Params[1], TStream(Integer(Caller.Params[2]))) +{$ENDIF} + else if MethodName = 'SECTIONEXISTS' then + Result := oCustomIniFile.SectionExists(Caller.Params[0]) + else if MethodName = 'VALUEEXISTS' then + Result := oCustomIniFile.ValueExists(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'WRITETSTRINGS' then + WriteTStrings(oCustomIniFile, Caller.Params[0], TStrings(Integer(Caller.Params[1])), Caller.Params[2]) + else if MethodName = 'READTSTRINGS' then + ReadTStrings(oCustomIniFile, Caller.Params[0], TStrings(Integer(Caller.Params[1])), Caller.Params[2]) + + end; + + if ClassType = TMemIniFile then + begin + oMemIniFile := TMemIniFile(Instance); + if MethodName = 'CREATE' then + Result := Integer(oMemIniFile.Create(Caller.Params[0])) + else if MethodName = 'WRITESTRING' then + oMemIniFile.WriteString(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READSTRING' then + Result := oMemIniFile.ReadString(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'DELETEKEY' then + oMemIniFile.DeleteKey(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'READSECTION' then + oMemIniFile.ReadSection(Caller.Params[0], TStrings(Integer(Caller.Params[1]))) + else if MethodName = 'READSECTIONS' then + oMemIniFile.ReadSections(TStrings(Integer(Caller.Params[0]))) + else if MethodName = 'READSECTIONVALUES' then + oMemIniFile.ReadSectionValues(Caller.Params[0], TStrings(Integer(Caller.Params[1]))) + else if MethodName = 'ERASESECTION' then + oMemIniFile.EraseSection(Caller.Params[0]) +{$IFDEF DELPHI6} + else if MethodName = 'READSECTIONVALUESEX' then + begin + oList := TStringList.Create; + try + oMemIniFile.ReadSectionValues(Caller.Params[0], oList); + TStrings(Integer(Caller.Params[1])).Clear; + for nCou := 0 to oList.Count-1 do +// TStrings(Integer(Caller.Params[1])).Add(oList.ValueFromIndex[nCou]); + TStrings(Integer(Caller.Params[1])).Add(oList.Values[oList.Names[nCou]]); + finally + oList.Free; + end; + end +{$ENDIF} + else if MethodName = 'CLEAR' then + oMemIniFile.Clear + else if MethodName = 'GETSTRINGS' then + oMemIniFile.GetStrings(TStrings(Integer(Caller.Params[0]))) + else if MethodName = 'SETSTRINGS' then + oMemIniFile.SetStrings(TStrings(Integer(Caller.Params[0]))) + else if MethodName = 'SAVEINIFILETOSTREAM' then + SaveIniFileToStream(oMemIniFile, TStream(Integer(Caller.Params[0]))) + else if MethodName = 'LOADINIFILEFROMSTREAM' then + LoadIniFileFromStream(oMemIniFile, TStream(Integer(Caller.Params[0]))) + end; + + if ClassType = TIniFile then + begin + oIniFile := TIniFile(Instance); + if MethodName = 'WRITESTRING' then + oIniFile.WriteString(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'READSTRING' then + Result := oIniFile.ReadString(Caller.Params[0], Caller.Params[1], Caller.Params[2]) + else if MethodName = 'DELETEKEY' then + oIniFile.DeleteKey(Caller.Params[0], Caller.Params[1]) + else if MethodName = 'READSECTION' then + oIniFile.ReadSection(Caller.Params[0], TStrings(Integer(Caller.Params[1]))) + else if MethodName = 'READSECTIONS' then + oIniFile.ReadSections(TStrings(Integer(Caller.Params[0]))) + else if MethodName = 'READSECTIONVALUES' then + oIniFile.ReadSectionValues(Caller.Params[0], TStrings(Integer(Caller.Params[1]))) + else if MethodName = 'ERASESECTION' then + oIniFile.EraseSection(Caller.Params[0]) +{$IFDEF DELPHI6} + else if MethodName = 'READSECTIONVALUESEX' then + begin + oList := TStringList.Create; + try + oIniFile.ReadSectionValues(Caller.Params[0], oList); + TStrings(Integer(Caller.Params[1])).Clear; + for nCou := 0 to oList.Count-1 do +// TStrings(Integer(Caller.Params[1])).Add(oList.ValueFromIndex[nCou]); + TStrings(Integer(Caller.Params[1])).Add(oList.Values[oList.Names[nCou]]); + finally + oList.Free; + end; + end +{$ENDIF} + else if MethodName = 'SAVEINIFILETOSTREAM' then + SaveIniFileToStream(oIniFile, TStream(Integer(Caller.Params[0]))) + else if MethodName = 'LOADINIFILEFROMSTREAM' then + LoadIniFileFromStream(oIniFile, TStream(Integer(Caller.Params[0]))) + end; + +end; +{$HINTS ON} + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TCustomIniFile then + begin + if PropName = 'FILENAME' then + Result := TIniFile(Instance).FileName + end; +end; + +procedure TFunctions.SaveIniFileToStream(oIniFile :TCustomIniFile; oStream :TStream); +var + oStrings :TStrings; + +begin + + if (not Assigned(oIniFile)) or (not Assigned(oStream)) then Exit; + + if not ((oIniFile is TIniFile) or (oIniFile is TMemIniFile)) then Exit; + + oStrings:= TStringList.Create; + try + + if oIniFile is TIniFile then + oStrings.LoadFromFile(oIniFile.FileName) + else + if oIniFile is TMemIniFile then + TMemIniFile(oIniFile).GetStrings(oStrings); + + oStrings.SaveToStream(oStream); + + finally + oStrings.Free; + end; + +end; + +procedure TFunctions.LoadIniFileFromStream(oIniFile :TCustomIniFile; oStream :TStream); +var + oStrings :TStrings; + +begin + + if (not Assigned(oIniFile)) or (not Assigned(oStream)) then Exit; + + if not ((oIniFile is TIniFile) or (oIniFile is TMemIniFile)) then Exit; + + oStrings:= TStringList.Create; + try + + oStrings.LoadFromStream(oStream); + + if oIniFile is TIniFile then + oStrings.SaveToFile(oIniFile.FileName) + else + if oIniFile is TMemIniFile then + TMemIniFile(oIniFile).SetStrings(oStrings); + + finally + oStrings.Free; + end; + +end; + +procedure TFunctions.WriteTStrings(oIniFile :TCustomIniFile; const Section :String; Values :TStrings; IsClear :Boolean = True); +var + nCou :Integer; + +begin + + if IsClear then oIniFile.EraseSection(Section); + + for nCou := 0 to Values.Count-1 do + oIniFile.WriteString(Section, 'Items'+IntToStr(nCou), Values[nCou]); + + oIniFile.WriteInteger(Section, 'Count', Values.Count); + +end; + +procedure TFunctions.ReadTStrings(oIniFile :TCustomIniFile; const Section :String; Values :TStrings; IsClear :Boolean = True); +var + nCou, nCount :Integer; + +begin + + nCount := oIniFile.ReadInteger(Section, 'Count', 0); + + if IsClear then Values.Clear; + + for nCou := 0 to nCount-1 do + Values.Add(oIniFile.ReadString(Section, 'Items'+IntToStr(nCou), '')); + +end; + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + fsRTTIModules.Remove(TFunctions); + +end. diff --git a/official/4.8.11/FastScript/fs_iinterpreter.pas b/official/4.8.11/FastScript/fs_iinterpreter.pas new file mode 100644 index 0000000..b92f372 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iinterpreter.pas @@ -0,0 +1,3272 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Main module } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iinterpreter; + +interface + +{$I fs.inc} + +uses + SysUtils, Classes, fs_xml +{$IFDEF Delphi6} +, Variants +{$ENDIF} + +, SyncObjs; + + +type + TfsStatement = class; + TfsDesignator = class; + TfsCustomVariable = class; + TfsClassVariable = class; + TfsProcVariable = class; + TfsMethodHelper = class; + TfsPropertyHelper = class; + TfsScript = class; + +{ List of supported types. Actually all values are variants; types needed + only to know what kind of operations can be implemented to the variable } + + TfsVarType = (fvtInt, fvtBool, fvtFloat, fvtChar, fvtString, fvtClass, + fvtArray, fvtVariant, fvtEnum, fvtConstructor); + + TfsTypeRec = {$IFDEF Delphi12}{$ELSE}packed{$ENDIF} record + Typ: TfsVarType; +{$IFDEF Delphi12} + TypeName: String; +{$ELSE} + TypeName: String[32]; +{$ENDIF} + end; + +{ Events for get/set non-published property values and call methods } + + TfsGetValueEvent = function(Instance: TObject; ClassType: TClass; + const PropName: String): Variant of object; + TfsSetValueEvent = procedure(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant) of object; + + TfsGetValueNewEvent = function(Instance: TObject; ClassType: TClass; + const PropName: String; Caler: TfsPropertyHelper): Variant of object; + TfsSetValueNewEvent = procedure(Instance: TObject; ClassType: TClass; + const PropName: String; Value: Variant; Caller: TfsPropertyHelper) of object; + + TfsCallMethodNewEvent = function(Instance: TObject; ClassType: TClass; + const MethodName: String; Caller: TfsMethodHelper): Variant of object; + TfsCallMethodEvent = function(Instance: TObject; ClassType: TClass; + const MethodName: String; var Params: Variant): Variant of object; + TfsRunLineEvent = procedure(Sender: TfsScript; + const UnitName, SourcePos: String) of object; + TfsGetUnitEvent = procedure(Sender: TfsScript; + const UnitName: String; var UnitText: String) of object; + TfsGetVariableValueEvent = function(VarName: String; + VarTyp: TfsVarType; OldValue: Variant): Variant of object; + +{ List of objects. Unlike TList, Destructor frees all objects in the list } + + TfsItemList = class(TObject) + protected + FItems: TList; + protected + procedure Clear; virtual; + public + constructor Create; + destructor Destroy; override; + procedure Add(Item: TObject); + function Count: Integer; + procedure Remove(Item: TObject); + end; + + +{ TfsScript represents the main script. It holds the list of local variables, + constants, procedures in the Items. Entry point is the Statement. + + There is one global object fsGlobalUnit: TfsScript that holds all information + about external classes, global variables, methods and constants. To use + such globals, pass fsGlobalUnit to the TfsScript.Create. + If you want, you can add classes/variables/methods to the TfsScript - they + will be local for it and not visible in other programs. + + To execute a program, compile it first by calling Compile method. If error + occurs, the ErrorMsg will contain the error message and ErrorPos will point + to an error position in the source text. For example: + + if not Prg.Compile then + begin + ErrorLabel.Caption := Prg.ErrorMsg; + Memo1.SetFocus; + Memo1.Perform(EM_SETSEL, Prg.ErrorPos - 1, Prg.ErrorPos - 1); + Memo1.Perform(EM_SCROLLCARET, 0, 0); + end; + + If no errors occured, call Execute method to execute the program } + + + TfsScript = class(TComponent) + + private + FAddedBy: TObject; + FBreakCalled: Boolean; + FContinueCalled: Boolean; + FExitCalled: Boolean; + FErrorMsg: String; + FErrorPos: String; + FErrorUnit: String; + FExtendedCharset: Boolean; + FItems: TStringList; + FIsRunning: Boolean; + FLines: TStrings; + FMacros: TStrings; + FMainProg: Boolean; + FOnGetILUnit: TfsGetUnitEvent; + FOnGetUnit: TfsGetUnitEvent; + FOnRunLine: TfsRunLineEvent; + FOnGetVarValue: TfsGetVariableValueEvent; + FParent: TfsScript; + FProgRunning: TfsScript; + FRTTIAdded: Boolean; + FStatement: TfsStatement; + FSyntaxType: String; + FTerminated: Boolean; + FUnitLines: TStringList; + FIncludePath: TStrings; + FUseClassLateBinding: Boolean; + FEvaluteRiseError: Boolean; + function GetItem(Index: Integer): TfsCustomVariable; + procedure RunLine(const UnitName, Index: String); + function GetVariables(Index: String): Variant; + procedure SetVariables(Index: String; const Value: Variant); + procedure SetLines(const Value: TStrings); + + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Add(const Name: String; Item: TObject); + procedure AddCodeLine(const UnitName, APos: String); + procedure AddRTTI; + procedure Remove(Item: TObject); + procedure RemoveItems(Owner: TObject); + procedure Clear; + procedure ClearItems(Owner: TObject); + procedure ClearRTTI; + function Count: Integer; + + { Adds a class. Example: + with AddClass(TComponent, 'TPersistent') do + begin + ... add properties and methods ... + end } + function AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable; dynamic; + { Adds a constant. Example: + AddConst('pi', 'Double', 3.14159) } + procedure AddConst(const Name, Typ: String; const Value: Variant); dynamic; + { Adds an enumeration constant. Example: + AddEnum('TFontPitch', 'fpDefault, fpFixed, fpVariable') + all constants gets type fvtEnum and values 0,1,2,3.. } + procedure AddEnum(const Typ, Names: String); dynamic; + { Adds an set constant. Example: + AddEnumSet('TFontStyles', 'fsBold, fsItalic, fsUnderline') + all constants gets type fvtEnum and values 1,2,4,8,.. } + procedure AddEnumSet(const Typ, Names: String); dynamic; + { Adds a form or datamodule with all its child components } + procedure AddComponent(Form: TComponent); dynamic; + procedure AddForm(Form: TComponent); dynamic; + { Adds a method. Syntax is the same as for TfsClassVariable.AddMethod } + procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent; + const Category: String = ''; const Description: String = ''); overload; dynamic; + procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent; + const Category: String = ''; const Description: String = ''); overload; dynamic; + { Adds an external object. Example: + AddObject('Memo1', Memo1) } + procedure AddObject(const Name: String; Obj: TObject); dynamic; + { Adds a variable. Example: + AddVariable('n', 'Variant', 0) } + procedure AddVariable(const Name, Typ: String; const Value: Variant); dynamic; + { Adds a type. Example: + AddType('TDateTime', fvtFloat) } + procedure AddType(const TypeName: String; ParentType: TfsVarType); dynamic; + { Calls internal procedure or function. Example: + val := CallFunction('ScriptFunc1', VarArrayOf([2003, 3])) } + function CallFunction(const Name: String; const Params: Variant): Variant; + function CallFunction1(const Name: String; var Params: Variant): Variant; + function CallFunction2(const Func: TfsProcVariable; const Params: Variant): Variant; + + { Compiles the source code. Example: + Lines.Text := 'begin i := 0 end.'; + SyntaxType := 'PascalScript'; + if Compile then ... } + function Compile: Boolean; + { Executes compiled code } + procedure Execute; + { Same as if Compile then Execute. Returns False if compile failed } + function Run: Boolean; + { terminates the script } + procedure Terminate; + { Evaluates an expression (useful for debugging purposes). Example: + val := Evaluate('i+1'); } + function Evaluate(const Expression: String): Variant; + { checks whether is the line is executable } + function IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean; + + { Generates intermediate language. You can save it and compile later + by SetILCode method } + function GetILCode(Stream: TStream): Boolean; + { Compiles intermediate language } + function SetILCode(Stream: TStream): Boolean; + + function Find(const Name: String): TfsCustomVariable; + function FindClass(const Name: String): TfsClassVariable; + function FindLocal(const Name: String): TfsCustomVariable; + + property AddedBy: TObject read FAddedBy write FAddedBy; + property ErrorMsg: String read FErrorMsg write FErrorMsg; + property ErrorPos: String read FErrorPos write FErrorPos; + property ErrorUnit: String read FErrorUnit write FErrorUnit; + property ExtendedCharset: Boolean read FExtendedCharset write FExtendedCharset; + property Items[Index: Integer]: TfsCustomVariable read GetItem; + property IsRunning: Boolean read FIsRunning; + property Macros: TStrings read FMacros; + property MainProg: Boolean read FMainProg write FMainProg; + property Parent: TfsScript read FParent write FParent; + property ProgRunning: TfsScript read FProgRunning; + property Statement: TfsStatement read FStatement; + property Variables[Index: String]: Variant read GetVariables write SetVariables; + property IncludePath: TStrings read FIncludePath; + property UseClassLateBinding: Boolean read FUseClassLateBinding write FUseClassLateBinding; + property EvaluteRiseError: Boolean read FEvaluteRiseError; + published + { the source code } + property Lines: TStrings read FLines write SetLines; + { the language name } + property SyntaxType: String read FSyntaxType write FSyntaxType; + property OnGetILUnit: TfsGetUnitEvent read FOnGetILUnit write FOnGetILUnit; + property OnGetUnit: TfsGetUnitEvent read FOnGetUnit write FOnGetUnit; + property OnRunLine: TfsRunLineEvent read FOnRunLine write FOnRunLine; + property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue; + end; + + + TfsCustomExpression = class; + TfsSetExpression = class; + +{ Statements } + + TfsStatement = class(TfsItemList) + private + FProgram: TfsScript; + FSourcePos: String; + FUnitName: String; + function GetItem(Index: Integer): TfsStatement; + procedure RunLine; + public + constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); virtual; + procedure Execute; virtual; + property Items[Index: Integer]: TfsStatement read GetItem; + end; + + TfsAssignmentStmt = class(TfsStatement) + private + FDesignator: TfsDesignator; + FExpression: TfsCustomExpression; + FVar: TfsCustomVariable; + FExpr: TfsCustomVariable; + public + destructor Destroy; override; + procedure Execute; override; + procedure Optimize; + property Designator: TfsDesignator read FDesignator write FDesignator; + property Expression: TfsCustomExpression read FExpression write FExpression; + end; + + TfsAssignPlusStmt = class(TfsAssignmentStmt) + public + procedure Execute; override; + end; + + TfsAssignMinusStmt = class(TfsAssignmentStmt) + public + procedure Execute; override; + end; + + TfsAssignMulStmt = class(TfsAssignmentStmt) + public + procedure Execute; override; + end; + + TfsAssignDivStmt = class(TfsAssignmentStmt) + public + procedure Execute; override; + end; + + TfsCallStmt = class(TfsStatement) + private + FDesignator: TfsDesignator; + FModificator: String; + public + destructor Destroy; override; + procedure Execute; override; + property Designator: TfsDesignator read FDesignator write FDesignator; + property Modificator: String read FModificator write FModificator; + end; + + TfsIfStmt = class(TfsStatement) + private + FCondition: TfsCustomExpression; + FElseStmt: TfsStatement; + public + constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override; + destructor Destroy; override; + procedure Execute; override; + property Condition: TfsCustomExpression read FCondition write FCondition; + property ElseStmt: TfsStatement read FElseStmt write FElseStmt; + end; + + TfsCaseSelector = class(TfsStatement) + private + FSetExpression: TfsSetExpression; + public + destructor Destroy; override; + function Check(const Value: Variant): Boolean; + property SetExpression: TfsSetExpression read FSetExpression write FSetExpression; + end; + + TfsCaseStmt = class(TfsStatement) + private + FCondition: TfsCustomExpression; + FElseStmt: TfsStatement; + public + constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override; + destructor Destroy; override; + procedure Execute; override; + property Condition: TfsCustomExpression read FCondition write FCondition; + property ElseStmt: TfsStatement read FElseStmt write FElseStmt; + end; + + TfsRepeatStmt = class(TfsStatement) + private + FCondition: TfsCustomExpression; + FInverseCondition: Boolean; + public + destructor Destroy; override; + procedure Execute; override; + property Condition: TfsCustomExpression read FCondition write FCondition; + property InverseCondition: Boolean read FInverseCondition write FInverseCondition; + end; + + TfsWhileStmt = class(TfsStatement) + private + FCondition: TfsCustomExpression; + public + destructor Destroy; override; + procedure Execute; override; + property Condition: TfsCustomExpression read FCondition write FCondition; + end; + + TfsForStmt = class(TfsStatement) + private + FBeginValue: TfsCustomExpression; + FDown: Boolean; + FEndValue: TfsCustomExpression; + FVariable: TfsCustomVariable; + public + destructor Destroy; override; + procedure Execute; override; + property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue; + property Down: Boolean read FDown write FDown; + property EndValue: TfsCustomExpression read FEndValue write FEndValue; + property Variable: TfsCustomVariable read FVariable write FVariable; + end; + + TfsVbForStmt = class(TfsStatement) + private + FBeginValue: TfsCustomExpression; + FEndValue: TfsCustomExpression; + FStep: TfsCustomExpression; + FVariable: TfsCustomVariable; + public + destructor Destroy; override; + procedure Execute; override; + property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue; + property EndValue: TfsCustomExpression read FEndValue write FEndValue; + property Step: TfsCustomExpression read FStep write FStep; + property Variable: TfsCustomVariable read FVariable write FVariable; + end; + + TfsCppForStmt = class(TfsStatement) + private + FFirstStmt: TfsStatement; + FExpression: TfsCustomExpression; + FSecondStmt: TfsStatement; + public + constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override; + destructor Destroy; override; + procedure Execute; override; + property FirstStmt: TfsStatement read FFirstStmt write FFirstStmt; + property Expression: TfsCustomExpression read FExpression write FExpression; + property SecondStmt: TfsStatement read FSecondStmt write FSecondStmt; + end; + + TfsTryStmt = class(TfsStatement) + private + FIsExcept: Boolean; + FExceptStmt: TfsStatement; + public + constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override; + destructor Destroy; override; + procedure Execute; override; + property IsExcept: Boolean read FIsExcept write FIsExcept; + property ExceptStmt: TfsStatement read FExceptStmt write FExceptStmt; + end; + + TfsBreakStmt = class(TfsStatement) + public + procedure Execute; override; + end; + + TfsContinueStmt = class(TfsStatement) + public + procedure Execute; override; + end; + + TfsExitStmt = class(TfsStatement) + public + procedure Execute; override; + end; + + TfsWithStmt = class(TfsStatement) + private + FDesignator: TfsDesignator; + FVariable: TfsCustomVariable; + public + destructor Destroy; override; + procedure Execute; override; + property Designator: TfsDesignator read FDesignator write FDesignator; + property Variable: TfsCustomVariable read FVariable write FVariable; + end; + +{ TfsCustomVariable is the generic class for variables, constants, arrays, + properties, methods and procedures/functions } + + TfsParamItem = class; + + TfsCustomVariable = class(TfsItemList) + private + FAddedBy: TObject; + FIsMacro: Boolean; + FIsReadOnly: Boolean; + FName: String; + FNeedResult: Boolean; + FRefItem: TfsCustomVariable; + FSourcePos: String; + FSourceUnit: String; + FTyp: TfsVarType; + FTypeName: String; + FUppercaseName: String; + FValue: Variant; + FOnGetVarValue: TfsGetVariableValueEvent; + function GetParam(Index: Integer): TfsParamItem; + function GetPValue: PVariant; + protected + procedure SetValue(const Value: Variant); virtual; + function GetValue: Variant; virtual; + public + constructor Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String); + function GetFullTypeName: String; + function GetNumberOfRequiredParams: Integer; + + property AddedBy: TObject read FAddedBy write FAddedBy; + property IsMacro: Boolean read FIsMacro write FIsMacro; + property IsReadOnly: Boolean read FIsReadOnly write FIsReadOnly; + property Name: String read FName; + property NeedResult: Boolean read FNeedResult write FNeedResult; + property Params[Index: Integer]: TfsParamItem read GetParam; default; + property PValue: PVariant read GetPValue; + property RefItem: TfsCustomVariable read FRefItem write FRefItem; + property SourcePos: String read FSourcePos write FSourcePos; + property SourceUnit: String read FSourceUnit write FSourceUnit; + property Typ: TfsVarType read FTyp write FTyp; + property TypeName: String read FTypeName write FTypeName; + property Value: Variant read GetValue write SetValue; + property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue; + end; + +{ TfsVariable represents constant or variable } + + TfsVariable = class(TfsCustomVariable) + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + end; + + TfsTypeVariable = class(TfsCustomVariable) + end; + + TfsStringVariable = class(TfsVariable) + private + FStr: String; + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + end; + +{ TfsParamItem describes one parameter of procedure/function/method call } + + TfsParamItem = class(TfsCustomVariable) + private + FDefValue: Variant; + FIsOptional: Boolean; + FIsVarParam: Boolean; + public + constructor Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String; AIsOptional, AIsVarParam: Boolean); + property DefValue: Variant read FDefValue write FDefValue; + property IsOptional: Boolean read FIsOptional; + property IsVarParam: Boolean read FIsVarParam; + end; + +{ TfsProcVariable is a local internal procedure/function. Formal parameters + are in Params, and statement to execute is in Prog: TfsScript } + + TfsProcVariable = class(TfsCustomVariable) + private + FExecuting: Boolean; + FIsFunc: Boolean; + FProgram: TfsScript; + protected + function GetValue: Variant; override; + public + constructor Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True); + destructor Destroy; override; + + property Executing: Boolean read FExecuting; + property IsFunc: Boolean read FIsFunc; + property Prog: TfsScript read FProgram; + end; + + TfsCustomExpression = class(TfsCustomVariable) + end; + +{ TfsCustomHelper is the generic class for the "helpers". Helper is + a object that takes the data from the parent object and performs some + actions. Helpers needed for properties, methods and arrays } + + TfsCustomHelper = class(TfsCustomVariable) + private + FParentRef: TfsCustomVariable; + FParentValue: Variant; + FProgram: TfsScript; + public + property ParentRef: TfsCustomVariable read FParentRef write FParentRef; + + property ParentValue: Variant read FParentValue write FParentValue; + + property Prog: TfsScript read FProgram write FProgram; + end; + +{ TfsArrayHelper performs access to array elements } + + TfsArrayHelper = class(TfsCustomHelper) + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + constructor Create(const AName: String; DimCount: Integer; Typ: TfsVarType; + const TypeName: String); + destructor Destroy; override; + end; + +{ TfsStringHelper performs access to string elements } + + TfsStringHelper = class(TfsCustomHelper) + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + constructor Create; + end; + +{ TfsPropertyHelper gets/sets the property value. Object instance is + stored as Integer in the ParentValue property } + + TfsPropertyHelper = class(TfsCustomHelper) + private + FClassRef: TClass; + FIsPublished: Boolean; + FOnGetValue: TfsGetValueEvent; + FOnSetValue: TfsSetValueEvent; + FOnGetValueNew: TfsGetValueNewEvent; + FOnSetValueNew: TfsSetValueNewEvent; + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + property IsPublished: Boolean read FIsPublished; + property OnGetValue: TfsGetValueEvent read FOnGetValue write FOnGetValue; + property OnSetValue: TfsSetValueEvent read FOnSetValue write FOnSetValue; + property OnGetValueNew: TfsGetValueNewEvent read FOnGetValueNew write FOnGetValueNew; + property OnSetValueNew: TfsSetValueNewEvent read FOnSetValueNew write FOnSetValueNew; + end; + +{ TfsMethodHelper gets/sets the method value. Object instance is + stored as Integer in the ParentValue property. SetValue is called + if the method represents the indexes property. } + + TfsMethodHelper = class(TfsCustomHelper) + private + FCategory: String; + FClassRef: TClass; + FDescription: String; + FIndexMethod: Boolean; + FOnCall: TfsCallMethodEvent; + FOnCallNew: TfsCallMethodNewEvent; + FSetValue: Variant; + FSyntax: String; + FVarArray: Variant; + function GetVParam(Index: Integer): Variant; + procedure SetVParam(Index: Integer; const Value: Variant); + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + constructor Create(const Syntax: String; Script: TfsScript); + destructor Destroy; override; + + property Category: String read FCategory write FCategory; + property Description: String read FDescription write FDescription; + property IndexMethod: Boolean read FIndexMethod; + property Params[Index: Integer]: Variant read GetVParam write SetVParam; default; + property Syntax: String read FSyntax; + property OnCall: TfsCallMethodEvent read FOnCall write FOnCall; + property OnCallNew: TfsCallMethodNewEvent read FOnCallNew write FOnCallNew; + end; + +{ TfsComponentHelper gets the component inside an owner, e.g. Form1.Button1 } + + TfsComponentHelper = class(TfsCustomHelper) + private + FComponent: TComponent; + protected + function GetValue: Variant; override; + public + constructor Create(Component: TComponent); + end; + +{ Event helper maintains VCL events } + + TfsCustomEvent = class(TObject) + private + FHandler: TfsProcVariable; + FInstance: TObject; + protected + procedure CallHandler(Params: array of const); + public + constructor Create(AObject: TObject; AHandler: TfsProcVariable); virtual; + function GetMethod: Pointer; virtual; abstract; + property Handler: TfsProcVariable read FHandler; + property Instance: TObject read FInstance; + end; + + TfsEventClass = class of TfsCustomEvent; + + TfsEventHelper = class(TfsCustomHelper) + private + FClassRef: TClass; + FEvent: TfsEventClass; + protected + procedure SetValue(const Value: Variant); override; + function GetValue: Variant; override; + public + constructor Create(const Name: String; AEvent: TfsEventClass); + end; + +{ TfsClassVariable holds information about external class. Call to + AddXXX methods adds properties and methods items to the items list } + + TfsClassVariable = class(TfsCustomVariable) + private + FAncestor: String; + FClassRef: TClass; + FDefProperty: TfsCustomHelper; + FMembers: TfsItemList; + FProgram: TfsScript; + procedure AddComponent(c: TComponent); + procedure AddPublishedProperties(AClass: TClass); + function GetMembers(Index: Integer): TfsCustomHelper; + function GetMembersCount: Integer; + protected + function GetValue: Variant; override; + public + constructor Create(AClass: TClass; const Ancestor: String); + destructor Destroy; override; + + { Adds a contructor. Example: + AddConstructor('constructor Create(AOwner: TComponent)', MyCallEvent) } + procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodNewEvent); overload; + procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent); overload; + { Adds a property. Example: + AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) } + procedure AddProperty(const Name, Typ: String; + GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil); + procedure AddPropertyEx(const Name, Typ: String; + GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent = nil); + { Adds a default property. Example: + AddDefaultProperty('Cell', 'Integer,Integer', 'String', MyCallEvent) + will describe real property Cell[Index1, Index2: Integer]: String + Note: in the CallEvent you'll get the MethodName parameter + 'CELL.GET' and 'CELL.SET', not 'CELL' } + procedure AddDefaultProperty(const Name, Params, Typ: String; + CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload; + procedure AddDefaultProperty(const Name, Params, Typ: String; + CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload; + { Adds an indexed property. Example and behavior are the same as + for AddDefaultProperty } + procedure AddIndexProperty(const Name, Params, Typ: String; + CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload; + procedure AddIndexProperty(const Name, Params, Typ: String; + CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload; + { Adds a method. Example: + AddMethod('function IsVisible: Boolean', MyCallEvent) } + procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent); overload; + procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent); overload; + { Adds an event. Example: + AddEvent('OnClick', TfsNotifyEvent) } + procedure AddEvent(const Name: String; AEvent: TfsEventClass); + function Find(const Name: String): TfsCustomHelper; + + property Ancestor: String read FAncestor; + property ClassRef: TClass read FClassRef; + property DefProperty: TfsCustomHelper read FDefProperty; + property Members[Index: Integer]: TfsCustomHelper read GetMembers; + property MembersCount: Integer read GetMembersCount; + end; + +{ TfsDesignator holds the parts of function/procedure/variable/method/property + calls. Items are of type TfsDesignatorItem. + For example, Table1.FieldByName('N').AsString[1] will be represented as + items[0]: name 'Table1', no params + items[1]: name 'FieldByName', 1 param: 'N' + items[2]: name 'AsString', no params + items[3]: name '[', 1 param: '1' + Call to Value calculates and returns the designator value } + + TfsDesignatorKind = (dkOther, dkVariable, dkStringArray, dkArray); + + TfsDesignatorItem = class(TfsItemList) + private + FFlag: Boolean; { needed for index methods } + FRef: TfsCustomVariable; + FSourcePos: String; + function GetItem(Index: Integer): TfsCustomExpression; + public + property Items[Index: Integer]: TfsCustomExpression read GetItem; default; + property Flag: Boolean read FFlag write FFlag; + property Ref: TfsCustomVariable read FRef write FRef; + property SourcePos: String read FSourcePos write FSourcePos; + end; + + TfsDesignator = class(TfsCustomVariable) + private + FKind: TfsDesignatorKind; + FMainProg: TfsScript; + FProgram: TfsScript; + FRef1: TfsCustomVariable; + FRef2: TfsDesignatorItem; + FLateBindingXmlSource: TfsXMLItem; + procedure CheckLateBinding; + function DoCalc(const AValue: Variant; Flag: Boolean): Variant; + function GetItem(Index: Integer): TfsDesignatorItem; + protected + function GetValue: Variant; override; + procedure SetValue(const Value: Variant); override; + public + constructor Create(AProgram: TfsScript); + destructor Destroy; override; + procedure Borrow(ADesignator: TfsDesignator); + procedure Finalize; + property Items[Index: Integer]: TfsDesignatorItem read GetItem; default; + property Kind: TfsDesignatorKind read FKind; + property LateBindingXmlSource: TfsXMLItem read FLateBindingXmlSource + write FLateBindingXmlSource; + end; + + TfsVariableDesignator = class(TfsDesignator) + protected + function GetValue: Variant; override; + procedure SetValue(const Value: Variant); override; + end; + + TfsStringDesignator = class(TfsDesignator) + protected + function GetValue: Variant; override; + procedure SetValue(const Value: Variant); override; + end; + + TfsArrayDesignator = class(TfsDesignator) + protected + function GetValue: Variant; override; + procedure SetValue(const Value: Variant); override; + end; + +{ TfsSetExpression represents a set of values like ['_', '0'..'9'] } + + TfsSetExpression = class(TfsCustomVariable) + private + function GetItem(Index: Integer): TfsCustomExpression; + protected + function GetValue: Variant; override; + public + function Check(const Value: Variant): Boolean; + property Items[Index: Integer]: TfsCustomExpression read GetItem; + end; + + TfsRTTIModule = class(TObject) + private + FScript: TfsScript; + public + constructor Create(AScript: TfsScript); virtual; + property Script: TfsScript read FScript; + end; + + +function fsGlobalUnit: TfsScript; +function fsRTTIModules: TList; + + +implementation + +uses + TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser, + fs_itools, fs_iconst +{$IFDEF CLX} +, QForms, QDialogs, Types +{$ELSE} + {$IFDEF FPC} + {$IFDEF NOFORMS} + // nothing + {$ELSE} + , Forms, Dialogs + {$ENDIF} + {$ELSE} + , Windows + {$IFDEF NOFORMS} + , Messages + {$ELSE} + , Forms, Dialogs + {$ENDIF} + {$ENDIF} +{$ENDIF}; + +var + FGlobalUnit: TfsScript = nil; + FGlobalUnitDestroyed: Boolean = False; + FRTTIModules: TList = nil; + FRTTIModulesDestroyed: Boolean = False; + + +{ TfsItemsList } + +constructor TfsItemList.Create; +begin + FItems := TList.Create; +end; + +destructor TfsItemList.Destroy; +begin + Clear; + FItems.Free; + inherited; +end; + +procedure TfsItemList.Clear; +begin + while FItems.Count > 0 do + begin + TObject(FItems[0]).Free; + FItems.Delete(0); + end; +end; + +function TfsItemList.Count: Integer; +begin + Result := FItems.Count; +end; + +procedure TfsItemList.Add(Item: TObject); +begin + FItems.Add(Item); +end; + +procedure TfsItemList.Remove(Item: TObject); +begin + FItems.Remove(Item); +end; + + +{ TfsCustomVariable } + +constructor TfsCustomVariable.Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String); +begin + inherited Create; + FName := AName; + FTyp := ATyp; + FTypeName := ATypeName; + FValue := Null; + FNeedResult := True; + FUppercaseName := AnsiUppercase(FName); +end; + +function TfsCustomVariable.GetValue: Variant; +begin + Result := FValue; +end; + +procedure TfsCustomVariable.SetValue(const Value: Variant); +begin + if not FIsReadOnly then + FValue := Value; +end; + +function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem; +begin + Result := FItems[Index]; +end; + +function TfsCustomVariable.GetPValue: PVariant; +begin + Result := @FValue; +end; + +function TfsCustomVariable.GetFullTypeName: String; +begin + case FTyp of + fvtInt: Result := 'Integer'; + fvtBool: Result := 'Boolean'; + fvtFloat: Result := 'Extended'; + fvtChar: Result := 'Char'; + fvtString: Result := 'String'; + fvtClass: Result := FTypeName; + fvtArray: Result := 'Array'; + fvtEnum: Result := FTypeName; + else + Result := 'Variant'; + end; +end; + +function TfsCustomVariable.GetNumberOfRequiredParams: Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Count - 1 do + if not Params[i].IsOptional then + Inc(Result); +end; + + +{ TfsStringVariable } + +function TfsStringVariable.GetValue: Variant; +begin + Result := FStr; + if Assigned(FOnGetVarValue) then + begin + Result := FOnGetVarValue(FName, FTyp, FStr); + if Result = null then Result := FStr; + end; +end; + +procedure TfsStringVariable.SetValue(const Value: Variant); +begin + FStr := Value; +end; + + +{ TfsParamItem } + +constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String; AIsOptional, AIsVarParam: Boolean); +begin + inherited Create(AName, ATyp, ATypeName); + FIsOptional := AIsOptional; + FIsVarParam := AIsVarParam; + FDefValue := Null; +end; + + +{ TfsProcVariable } + +constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType; + const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True); +begin + inherited Create(AName, ATyp, ATypeName); + FIsReadOnly := True; + FIsFunc := AIsFunc; + FProgram := TfsScript.Create(nil); + FProgram.Parent := AParent; + if FProgram.Parent <> nil then + FProgram.UseClassLateBinding := FProgram.Parent.UseClassLateBinding; + if FIsFunc then + begin + FRefItem := TfsVariable.Create('Result', ATyp, ATypeName); + FProgram.Add('Result', FRefItem); + end; +end; + + + +destructor TfsProcVariable.Destroy; +var + i: Integer; +begin + { avoid destroying the param objects twice } + for i := 0 to Count - 1 do + FProgram.FItems.Delete(FProgram.FItems.IndexOfObject(Params[i])); + + FProgram.Free; + inherited; +end; + +function TfsProcVariable.GetValue: Variant; +var + Temp: Boolean; + ParentProg, SaveProg: TfsScript; +begin + Temp := FExecuting; + FExecuting := True; + if FIsFunc then + FRefItem.Value := Unassigned; + + ParentProg := FProgram; + SaveProg := nil; + while ParentProg <> nil do + if ParentProg.FMainProg then + begin + SaveProg := ParentProg.FProgRunning; + ParentProg.FProgRunning := FProgram; + break; + end + else + ParentProg := ParentProg.FParent; + + try +// avoid trial message +// same as FProgram.Execute + with FProgram do + begin + FExitCalled := False; + FTerminated := False; + FIsRunning := True; + try + FStatement.Execute; + finally + FExitCalled := False; + FTerminated := False; + FIsRunning := False; + end; + end; +// + + if FIsFunc then + Result := FRefItem.Value else + Result := Null; + finally + if ParentProg <> nil then + ParentProg.FProgRunning := SaveProg; + FExecuting := Temp; + end; +end; + + +{ TfsPropertyHelper } + +function TfsPropertyHelper.GetValue: Variant; +var + p: PPropInfo; + Instance: TObject; +begin + + Result := Null; + Instance := TObject(Integer(ParentValue)); + + if FIsPublished and Assigned(Instance) then + begin + p := GetPropInfo(Instance.ClassInfo, Name); + if p <> nil then + case p.PropType^.Kind of + tkInteger, tkSet, tkEnumeration, tkClass: + Result := GetOrdProp(Instance, p); + + tkFloat: + Result := GetFloatProp(Instance, p); + +// tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}: +// Result := GetStrProp(Instance, p); + + tkChar, tkWChar: + Result := Chr(GetOrdProp(Instance, p)); + + tkVariant: + Result := GetVariantProp(Instance, p); +{$IFDEF Delphi12} + tkString, tkLString: + Result := GetAnsiStrProp(Instance, p); + tkWString, tkUString: + Result := GetUnicodeStrProp(Instance, p); +{$ELSE} + tkString, tkLString, tkWString: + Result := GetStrProp(Instance, p); +{$ENDIF} + end; + end + else if Assigned(FOnGetValue) then + Result := FOnGetValue(Instance, FClassRef, FUppercaseName) + else if Assigned(FOnGetValueNew) then + Result := FOnGetValueNew(Instance, FClassRef, FUppercaseName, Self); + + if Typ = fvtBool then + if Result = 0 then + Result := False else + Result := True; + +end; + +procedure TfsPropertyHelper.SetValue(const Value: Variant); +var + p: PPropInfo; + Instance: TObject; + IntVal: Integer; +begin + + if IsReadOnly then Exit; + Instance := TObject(Integer(ParentValue)); + + + + if FIsPublished then + begin + p := GetPropInfo(Instance.ClassInfo, Name); + if p <> nil then + case p.PropType^.Kind of + tkInteger, tkSet, tkEnumeration, tkClass: + begin +{$IFNDEF Delphi4} + if VarType(Value) <> varInteger then + begin + SetSetProp(Instance, p, fsSetToString(p, Value)); + end + else +{$ENDIF} + begin + if Typ = fvtBool then + if Value = True then + IntVal := 1 else + IntVal := 0 + else + IntVal := Integer(Value); + SetOrdProp(Instance, p, IntVal); + end; + end; + + tkFloat: + SetFloatProp(Instance, p, Extended(Value)); + +// tkString, tkLString: +// SetStrProp(Instance, p, String(Value)); + +// tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}: +// SetStrProp(Instance, p, WideString(Value)); + + tkChar, tkWChar: + SetOrdProp(Instance, p, Ord(String(Value)[1])); + + tkVariant: + SetVariantProp(Instance, p, Value); + +{$IFDEF Delphi12} + tkString, tkLString: + SetAnsiStrProp(Instance, p, AnsiString(Value)); + tkWString, tkUString: + SetUnicodeStrProp(Instance, p, WideString(Value)); +{$ELSE} + tkString, tkLString, tkWString: + SetStrProp(Instance, p, String(Value)); +{$ENDIF} + end; + end + else if Assigned(FOnSetValue) then + FOnSetValue(Instance, FClassRef, FUppercaseName, Value) + else if Assigned(FOnSetValueNew) then + FOnSetValueNew(Instance, FClassRef, FUppercaseName, Value, Self); + +end; + + +{ TfsMethodHelper } + +constructor TfsMethodHelper.Create(const Syntax: String; Script: TfsScript); +var + i: Integer; + v: TfsCustomVariable; +begin + v := ParseMethodSyntax(Syntax, Script); + inherited Create(v.Name, v.Typ, v.TypeName); + FIsReadOnly := True; + FSyntax := Syntax; + IsMacro := v.IsMacro; + + { copying params } + for i := 0 to v.Count - 1 do + Add(v.Params[i]); + while v.Count > 0 do + v.FItems.Delete(0); + v.Free; + + // FPC and Delphi do this different way. FPC implementation more honest, so + // if Count = 0 then we get exception about bad bounds + if Count > 0 then + FVarArray := VarArrayCreate([0, Count - 1], varVariant); +end; + +destructor TfsMethodHelper.Destroy; +begin + FVarArray := Null; + inherited; +end; + +function TfsMethodHelper.GetVParam(Index: Integer): Variant; +begin + if Index = Count then + Result := FSetValue + else + Result := TfsParamItem(FItems[Index]).Value; +end; + +procedure TfsMethodHelper.SetVParam(Index: Integer; const Value: Variant); +begin + TfsParamItem(FItems[Index]).Value := Value; +end; + +function TfsMethodHelper.GetValue: Variant; +var + i: Integer; + Instance: TObject; +begin + if Assigned(FOnCall) then + begin + for i := 0 to Count - 1 do + FVarArray[i] := inherited Params[i].Value; + + Instance := nil; + if not VarIsNull(ParentValue) then + Instance := TObject(Integer(ParentValue)); + + if FIndexMethod then + Result := FOnCall(Instance, FClassRef, FUppercaseName + '.GET', FVarArray) + else + Result := FOnCall(Instance, FClassRef, FUppercaseName, FVarArray); + for i := 0 to Count - 1 do + if inherited Params[i].IsVarParam then + inherited Params[i].Value := FVarArray[i]; + end + else if Assigned(FOnCallNew) then + begin + Instance := nil; + if not VarIsNull(ParentValue) then + Instance := TObject(Integer(ParentValue)); + + if FIndexMethod then + Result := FOnCallNew(Instance, FClassRef, FUppercaseName + '.GET', Self) + else + Result := FOnCallNew(Instance, FClassRef, FUppercaseName, Self); + end + else + Result := 0; +end; + +procedure TfsMethodHelper.SetValue(const Value: Variant); +var + v: Variant; + i: Integer; +begin + if FIndexMethod then + if Assigned(FOnCall) then + begin + v := VarArrayCreate([0, Count], varVariant); + for i := 0 to Count - 1 do + v[i] := inherited Params[i].Value; + v[Count] := Value; + + FOnCall(TObject(Integer(ParentValue)), FClassRef, FUppercaseName + '.SET', v); + v := Null; + end + else if Assigned(FOnCallNew) then + begin + FSetValue := Value; + FOnCallNew(TObject(Integer(ParentValue)), FClassRef, FUppercaseName + '.SET', Self); + FSetValue := Null; + end; +end; + + +{ TfsComponentHelper } + +constructor TfsComponentHelper.Create(Component: TComponent); +begin + inherited Create(Component.Name, fvtClass, Component.ClassName); + FComponent := Component; +end; + +function TfsComponentHelper.GetValue: Variant; +begin + Result := Integer(FComponent); +end; + + +{ TfsEventHelper } + +constructor TfsEventHelper.Create(const Name: String; AEvent: TfsEventClass); +begin + inherited Create(Name, fvtString, ''); + FEvent := AEvent; +end; + +function TfsEventHelper.GetValue: Variant; +begin + Result := ''; +end; + +procedure TfsEventHelper.SetValue(const Value: Variant); +var + Instance: TPersistent; + v: TfsCustomVariable; + e: TfsCustomEvent; + p: PPropInfo; + m: TMethod; +begin + + Instance := TPersistent(Integer(ParentValue)); + if VarToStr(Value) = '0' then + begin + m.Code := nil; + m.Data := nil; + end + else + begin + v := FProgram.Find(Value); + if (v = nil) or not (v is TfsProcVariable) then + raise Exception.Create(SEventError); + + e := TfsCustomEvent(FEvent.NewInstance); + e.Create(Instance, TfsProcVariable(v)); + FProgram.Add('', e); + m.Code := e.GetMethod; + m.Data := e; + end; + + p := GetPropInfo(Instance.ClassInfo, Name); + SetMethodProp(Instance, p, m); +end; + + +{ TfsClassVariable } + +constructor TfsClassVariable.Create(AClass: TClass; const Ancestor: String); +begin + inherited Create(AClass.ClassName, fvtClass, AClass.ClassName); + FMembers := TfsItemList.Create; + FAncestor := Ancestor; + FClassRef := AClass; + + AddPublishedProperties(AClass); + Add(TfsParamItem.Create('', fvtVariant, '', True, False)); +end; + +destructor TfsClassVariable.Destroy; +begin + FMembers.Free; + inherited; +end; + +function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper; +begin + Result := FMembers.FItems[Index]; +end; + +function TfsClassVariable.GetMembersCount: Integer; +begin + Result := FMembers.Count; +end; + +procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent); +var + i: Integer; +begin + i := Pos(' ', Syntax); + Delete(Syntax, 1, i - 1); + Syntax := 'function' + Syntax + ': ' + 'Constructor'; + AddMethod(Syntax, CallEvent); +end; + +procedure TfsClassVariable.AddConstructor(Syntax: String; + CallEvent: TfsCallMethodNewEvent); +var + i: Integer; +begin + i := Pos(' ', Syntax); + Delete(Syntax, 1, i - 1); + Syntax := 'function' + Syntax + ': ' + 'Constructor'; + AddMethod(Syntax, CallEvent); +end; + +procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent); +var + m: TfsMethodHelper; +begin + m := TfsMethodHelper.Create(Syntax, FProgram); + m.FOnCall := CallEvent; + m.FClassRef := FClassRef; + FMembers.Add(m); +end; + +procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent); +var + m: TfsMethodHelper; +begin + m := TfsMethodHelper.Create(Syntax, FProgram); + m.FOnCallNew := CallEvent; + m.FClassRef := FClassRef; + FMembers.Add(m); +end; + +procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass); +var + e: TfsEventHelper; +begin + e := TfsEventHelper.Create(Name, AEvent); + e.FClassRef := FClassRef; + FMembers.Add(e); +end; + +procedure TfsClassVariable.AddProperty(const Name, Typ: String; + GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent); +var + p: TfsPropertyHelper; +begin + p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ); + p.FClassRef := FClassRef; + p.FOnGetValue := GetEvent; + p.FOnSetValue := SetEvent; + p.IsReadOnly := not Assigned(SetEvent); + FMembers.Add(p); +end; + +procedure TfsClassVariable.AddPropertyEx(const Name, Typ: String; + GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent); +var + p: TfsPropertyHelper; +begin + p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ); + p.FClassRef := FClassRef; + p.FOnGetValueNew := GetEvent; + p.FOnSetValueNew := SetEvent; + p.IsReadOnly := not Assigned(SetEvent); + FMembers.Add(p); +end; + +procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String; + CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); +begin + AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly); + FDefProperty := Members[FMembers.Count - 1]; +end; + +procedure TfsClassVariable.AddDefaultProperty(const Name, Params, + Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean); +begin + AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly); + FDefProperty := Members[FMembers.Count - 1]; +end; + +procedure TfsClassVariable.AddIndexProperty(const Name, Params, + Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); +var + i: Integer; + sl: TStringList; + s: String; +begin + sl := TStringList.Create; + sl.CommaText := Params; + + s := ''; + for i := 0 to sl.Count - 1 do + s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; '; + + SetLength(s, Length(s) - 2); + try + AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent); + with TfsMethodHelper(Members[FMembers.Count - 1]) do + begin + IsReadOnly := AReadOnly; + FIndexMethod := True; + end; + finally + sl.Free; + end; +end; + +procedure TfsClassVariable.AddIndexProperty(const Name, Params, + Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean); +var + i: Integer; + sl: TStringList; + s: String; +begin + sl := TStringList.Create; + sl.CommaText := Params; + + s := ''; + for i := 0 to sl.Count - 1 do + s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; '; + + SetLength(s, Length(s) - 2); + try + AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent); + with TfsMethodHelper(Members[FMembers.Count - 1]) do + begin + IsReadOnly := AReadOnly; + FIndexMethod := True; + end; + finally + sl.Free; + end; +end; + +procedure TfsClassVariable.AddComponent(c: TComponent); +begin + FMembers.Add(TfsComponentHelper.Create(c)); +end; + +procedure TfsClassVariable.AddPublishedProperties(AClass: TClass); +var + TypeInfo: PTypeInfo; + PropCount: Integer; + PropList: PPropList; + i: Integer; + cl: String; + t: TfsVarType; + FClass: TClass; + p: TfsPropertyHelper; +begin + TypeInfo := AClass.ClassInfo; + if TypeInfo = nil then Exit; + + PropCount := GetPropList(TypeInfo, tkProperties, nil); + GetMem(PropList, PropCount * SizeOf(PPropInfo)); + GetPropList(TypeInfo, tkProperties, PropList); + + try + for i := 0 to PropCount - 1 do + begin + t := fvtInt; + cl := ''; + + case PropList[i].PropType^.Kind of + tkInteger: + t := fvtInt; + tkSet: + begin + t := fvtEnum; + cl := String(PropList[i].PropType^.Name); + end; + tkEnumeration: + begin + t := fvtEnum; + cl := String(PropList[i].PropType^.Name); + if (CompareText(cl, 'Boolean') = 0) or (CompareText(cl, 'bool') = 0) then + t := fvtBool; + end; + tkFloat: + t := fvtFloat; + tkChar, tkWChar: + t := fvtChar; + tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}: + t := fvtString; + tkVariant: + t := fvtVariant; + tkClass: + begin + t := fvtClass; + {$IFNDEF FPC} + FClass := GetTypeData(PropList[i].PropType^).ClassType; + {$ELSE} + FClass := GetTypeData(PropList[i].PropType).ClassType; + {$ENDIF} + cl := FClass.ClassName; + end; + end; + + p := TfsPropertyHelper.Create(String(PropList[i].Name), t, cl); + p.FClassRef := FClassRef; + p.FIsPublished := True; + FMembers.Add(p); + end; + + finally + FreeMem(PropList, PropCount * SizeOf(PPropInfo)); + end; +end; + +function TfsClassVariable.Find(const Name: String): TfsCustomHelper; +var + cl: TfsClassVariable; + + function DoFind(const Name: String): TfsCustomHelper; + var + i: Integer; + begin + Result := nil; + for i := 0 to FMembers.Count - 1 do + if CompareText(Name, Members[i].Name) = 0 then + begin + Result := Members[i]; + Exit; + end; + end; + +begin + Result := DoFind(Name); + if Result = nil then + begin + cl := FProgram.FindClass(FAncestor); + if cl <> nil then + Result := cl.Find(Name); + end; +end; + +function TfsClassVariable.GetValue: Variant; +begin + if Params[0].Value = Null then + Result := Integer(FClassRef.NewInstance) else { constructor call } + Result := Params[0].Value; { typecast } + Params[0].Value := Null; +end; + + +{ TfsDesignatorItem } + +function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression; +begin + Result := FItems[Index]; +end; + + +{ TfsDesignator } + +constructor TfsDesignator.Create(AProgram: TfsScript); +var + ParentProg: TfsScript; +begin + inherited Create('', fvtInt, ''); + FProgram := AProgram; + FMainProg := FProgram; + ParentProg := FProgram; + while ParentProg <> nil do + if ParentProg.FMainProg then + begin + FMainProg := ParentProg; + break; + end + else + ParentProg := ParentProg.FParent; + FProgram.UseClassLateBinding := FMainProg.UseClassLateBinding; +end; + +destructor TfsDesignator.Destroy; +begin + if FLateBindingXMLSource <> nil then + FLateBindingXMLSource.Free; + inherited; +end; + +procedure TfsDesignator.Borrow(ADesignator: TfsDesignator); +var + SaveItems: TList; +begin + SaveItems := FItems; + FItems := ADesignator.FItems; + ADesignator.FItems := SaveItems; + FKind := ADesignator.FKind; + FRef1 := ADesignator.FRef1; + FRef2 := ADesignator.FRef2; + FTyp := ADesignator.Typ; + FTypeName := ADesignator.TypeName; + FIsReadOnly := ADesignator.IsReadOnly; + RefItem := ADesignator.RefItem; +end; + +procedure TfsDesignator.Finalize; +var + Item: TfsDesignatorItem; +begin + Item := Items[Count - 1]; + FTyp := Item.Ref.Typ; + FTypeName := Item.Ref.TypeName; + if FTyp = fvtConstructor then + begin + FTyp := fvtClass; + FTypeName := Items[Count - 2].Ref.TypeName; + end; + + FIsReadOnly := Item.Ref.IsReadOnly; + + { speed optimization for access to single variable, string element or array } + if (Count = 1) and (Items[0].Ref is TfsVariable) then + begin + RefItem := Items[0].Ref; + FKind := dkVariable; + end + else if (Count = 2) and (Items[0].Ref is TfsStringVariable) then + begin + RefItem := Items[0].Ref; + FRef1 := Items[1][0]; + FKind := dkStringArray; + end + else if (Count = 2) and (Items[0].Ref is TfsVariable) and (Items[0].Ref.Typ = fvtArray) then + begin + RefItem := Items[0].Ref; + FRef1 := RefItem.RefItem; + FRef2 := Items[1]; + FKind := dkArray; + end + else + FKind := dkOther; +end; + +function TfsDesignator.GetItem(Index: Integer): TfsDesignatorItem; +begin + Result := FItems[Index]; +end; + +function TfsDesignator.DoCalc(const AValue: Variant; Flag: Boolean): Variant; +var + i, j: Integer; + Item: TfsCustomVariable; + Val: Variant; + Ref: TfsCustomVariable; + Temp, Temp1: array of Variant; + + { copy local variables to Temp } + procedure SaveLocalVariables(Item: TfsCustomVariable); + var + i: Integer; + begin + with TfsProcVariable(Item) do + begin + SetLength(Temp, Prog.Count); + + for i := 0 to Prog.Count - 1 do + if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then + Temp[i] := Prog.Items[i].Value; + end; + end; + + { restore local variables from Temp} + procedure RestoreLocalVariables(Item: TfsCustomVariable); + var + i: Integer; + begin + with TfsProcVariable(Item) do + for i := 0 to Prog.Count - 1 do + if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then + Prog.Items[i].Value := Temp[i]; + + Temp := nil; + end; + +begin + Ref := nil; + Val := Null; + + for i := 0 to Count - 1 do + begin + Item := Items[i].Ref; + + if Item is TfsDesignator then { it is true for "WITH" statements } + begin + Ref := Item; + Val := Item.Value; + continue; + end; + + try + { we're trying to call the local procedure that is already executing - + i.e. we have a recursion } + if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then + SaveLocalVariables(Item); + + if Item.Count > 0 then + begin + SetLength(Temp1, Item.Count); + try + { calculate params and copy param values to the temp1 array } + for j := 0 to Item.Count - 1 do + if Item.IsMacro then + Temp1[j] := TfsExpression(Items[i][j]).Source + else + Temp1[j] := Items[i][j].Value; + { copy calculated values to the item params } + for j := 0 to Item.Count - 1 do + Item.Params[j].Value := Temp1[j]; + finally + Temp1 := nil; + end; + end; + + { copy value and var reference to the helper object } + if Item is TfsCustomHelper then + begin + TfsCustomHelper(Item).ParentRef := Ref; + TfsCustomHelper(Item).ParentValue := Val; + TfsCustomHelper(Item).Prog := FProgram; + end; + + Ref := Item; + { assign a value to the last designator node if called from SetValue } + if Flag and (i = Count - 1) then + begin + Item.Value := AValue + end + else + begin + Item.NeedResult := (i <> Count - 1) or NeedResult; + Val := Item.Value; + end; + + { copy back var params } + for j := 0 to Item.Count - 1 do + if Item.Params[j].IsVarParam then + Items[i][j].Value := Item.Params[j].Value; + + finally + { restore proc variables if it was called from itself } + if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then + RestoreLocalVariables(Item); + end; + end; + + Result := Val; +end; + +procedure TfsDesignator.CheckLateBinding; +var + NewDesignator: TfsDesignator; + Parser: TfsILParser; +begin + if FLateBindingXMLSource <> nil then + begin + Parser := TfsILParser.Create(FProgram); + try + NewDesignator := Parser.DoDesignator(FLateBindingXMLSource, FProgram); + Borrow(NewDesignator); + NewDesignator.Free; + finally + Parser.Free; + FLateBindingXMLSource.Free; + FLateBindingXMLSource := nil; + end; + end; +end; + +function TfsDesignator.GetValue: Variant; +begin + CheckLateBinding; + Result := DoCalc(Null, False); +end; + +procedure TfsDesignator.SetValue(const Value: Variant); +begin + CheckLateBinding; + DoCalc(Value, True); +end; + + +{ TfsVariableDesignator } + +function TfsVariableDesignator.GetValue: Variant; +begin + Result := RefItem.Value; +end; + +procedure TfsVariableDesignator.SetValue(const Value: Variant); +begin + RefItem.Value := Value; +end; + + +{ TfsStringDesignator } + +function TfsStringDesignator.GetValue: Variant; +begin + Result := TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)]; +end; + +procedure TfsStringDesignator.SetValue(const Value: Variant); +begin + TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)] := VarToStr(Value)[1]; +end; + + +{ TfsArrayDesignator } + +function TfsArrayDesignator.GetValue: Variant; +var + i: Integer; +begin + TfsCustomHelper(FRef1).ParentRef := RefItem; + for i := 0 to FRef2.Count - 1 do + FRef1.Params[i].Value := FRef2[i].Value; + Result := FRef1.Value; +end; + +procedure TfsArrayDesignator.SetValue(const Value: Variant); +var + i: Integer; +begin + TfsCustomHelper(FRef1).ParentRef := RefItem; + for i := 0 to FRef2.Count - 1 do + FRef1.Params[i].Value := FRef2[i].Value; + FRef1.Value := Value; +end; + + +{ TfsSetExpression } + +function TfsSetExpression.Check(const Value: Variant): Boolean; +var + i: Integer; + Expr: TfsCustomExpression; +begin + Result := False; + + (* TfsSetExpression encapsulates the set like [1,2,3..10] + In the example above we'll have the following Items: + TfsExpression {1} + TfsExpression {2} + TfsExpression {3} + nil (indicates the range ) + TfsExpression {10} *) + + i := 0; + while i < Count do + begin + Expr := Items[i]; + + if (i < Count - 1) and (Items[i + 1] = nil) then { subrange } + begin + Result := (Value >= Expr.Value) and (Value <= Items[i + 2].Value); + Inc(i, 2); + end + else + Result := Value = Expr.Value; + + if Result then break; + Inc(i); + end; +end; + +function TfsSetExpression.GetItem(Index: Integer): TfsCustomExpression; +begin + Result := FItems[Index]; +end; + +function TfsSetExpression.GetValue: Variant; +var + i: Integer; +begin + Result := VarArrayCreate([0, Count - 1], varVariant); + + for i := 0 to Count - 1 do + if Items[i] = nil then + Result[i] := Null else + Result[i] := Items[i].Value; +end; + + +{ TfsScript } + +constructor TfsScript.Create(AOwner: TComponent); +begin + inherited; + FEvaluteRiseError := False; + FItems := TStringList.Create; + FItems.Sorted := True; + FItems.Duplicates := dupAccept; + FLines := TStringList.Create; + FMacros := TStringList.Create; + FIncludePath := TStringList.Create; + FIncludePath.Add(''); + FStatement := TfsStatement.Create(Self, '', ''); + FSyntaxType := 'PascalScript'; + FUnitLines := TStringList.Create; + FUseClassLateBinding := False; +end; + +destructor TfsScript.Destroy; +begin + inherited; + Clear; + ClearRTTI; + FItems.Free; + FLines.Free; + FMacros.Free; + FIncludePath.Free; + FStatement.Free; + FUnitLines.Free; +end; + +procedure TfsScript.Add(const Name: String; Item: TObject); +begin + FItems.AddObject(Name, Item); + if Item is TfsCustomVariable then + TfsCustomVariable(Item).AddedBy := FAddedBy; +end; + +function TfsScript.Count: Integer; +begin + Result := FItems.Count; +end; + +procedure TfsScript.Remove(Item: TObject); +begin + FItems.Delete(FItems.IndexOfObject(Item)); +end; + +procedure TfsScript.Clear; +var + i: Integer; + item: TObject; +begin + i := 0; + while i < FItems.Count do + begin + item := FItems.Objects[i]; + if (item is TfsRTTIModule) or + ((item is TfsCustomVariable) and + (TfsCustomVariable(item).AddedBy = TObject(1))) then + Inc(i) + else + begin + item.Free; + FItems.Delete(i); + end; + end; + FStatement.Clear; + + + for i := 0 to FUnitLines.Count - 1 do + FUnitLines.Objects[i].Free; + + FUnitLines.Clear; + + FErrorPos := ''; + FErrorMsg := ''; + FErrorUnit := ''; +end; + +procedure TfsScript.ClearItems(Owner: TObject); +var + i: Integer; +begin + RemoveItems(Owner); + FStatement.Clear; + + for i := 0 to FUnitLines.Count - 1 do + FUnitLines.Objects[i].Free; + + FUnitLines.Clear; +end; + +procedure TfsScript.RemoveItems(Owner: TObject); +var + i: Integer; +begin + for i := Count - 1 downto 0 do + if Items[i].AddedBy = Owner then + begin + Items[i].Free; + Remove(Items[i]); + end; +end; + +function TfsScript.GetItem(Index: Integer): TfsCustomVariable; +begin + Result := TfsCustomVariable(FItems.Objects[Index]); +end; + +function TfsScript.Find(const Name: String): TfsCustomVariable; +begin + Result := FindLocal(Name); + + { trying to find the identifier in all parent programs } + if (Result = nil) and (FParent <> nil) then + Result := FParent.Find(Name); +end; + +function TfsScript.FindLocal(const Name: String): TfsCustomVariable; +var + i: Integer; +begin + Result := nil; + i := FItems.IndexOf(Name); + if (i <> -1) and (FItems.Objects[i] is TfsCustomVariable) then + Result := TfsCustomVariable(FItems.Objects[i]); +end; + +function TfsScript.Compile: Boolean; +var + p: TfsILParser; +begin + Result := False; + FErrorMsg := ''; + + p := TfsILParser.Create(Self); + try + p.SelectLanguage(FSyntaxType); + if p.MakeILScript(FLines.Text) then + p.ParseILScript; + finally + p.Free; + end; + + if FErrorMsg = '' then + begin + Result := True; + FErrorPos := ''; + end +end; + +procedure TfsScript.Execute; +begin + + FExitCalled := False; + FTerminated := False; + FIsRunning := True; + FMainProg := True; + try + FStatement.Execute; + finally + FExitCalled := False; + FTerminated := False; + FIsRunning := False; + end; +end; + +function TfsScript.Run: Boolean; +begin + Result := Compile; + if Result then + Execute; +end; + +function TfsScript.GetILCode(Stream: TStream): Boolean; +var + p: TfsILParser; +begin + Result := False; + FErrorMsg := ''; + + p := TfsILParser.Create(Self); + try + p.SelectLanguage(FSyntaxType); + if p.MakeILScript(FLines.Text) then + p.ILScript.SaveToStream(Stream); + finally + p.Free; + end; + + if FErrorMsg = '' then + begin + Result := True; + FErrorPos := ''; + end; +end; + +function TfsScript.SetILCode(Stream: TStream): Boolean; +var + p: TfsILParser; +begin + Result := False; + FErrorMsg := ''; + + p := TfsILParser.Create(Self); + try + p.ILScript.LoadFromStream(Stream); + p.ParseILScript; + finally + p.Free; + end; + + if FErrorMsg = '' then + begin + Result := True; + FErrorPos := ''; + end; +end; + +procedure TfsScript.AddType(const TypeName: String; ParentType: TfsVarType); +var + v: TfsTypeVariable; +begin + if Find(TypeName) <> nil then Exit; + v := TfsTypeVariable.Create(TypeName, ParentType, ''); + Add(TypeName, v); +end; + +function TfsScript.AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable; +var + cl: TfsClassVariable; +begin + Result := nil; + if Find(AClass.ClassName) <> nil then Exit; + + Result := TfsClassVariable.Create(AClass, Ancestor); + Result.FProgram := Self; + Add(Result.Name, Result); + + cl := TfsClassVariable(Find(Ancestor)); + if cl <> nil then + Result.FDefProperty := cl.DefProperty; +end; + +procedure TfsScript.AddConst(const Name, Typ: String; const Value: Variant); +var + v: TfsVariable; +begin + if Find(Name) <> nil then Exit; + + v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ); + v.Value := Value; + v.IsReadOnly := True; + Add(v.Name, v); +end; + +procedure TfsScript.AddEnum(const Typ, Names: String); +var + i: Integer; + v: TfsVariable; + sl: TStringList; +begin + v := TfsVariable.Create(Typ, fvtEnum, Typ); + Add(v.Name, v); + + sl := TStringList.Create; + sl.CommaText := Names; + + try + for i := 0 to sl.Count - 1 do + begin + v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ); + v.Value := i; + v.IsReadOnly := True; + Add(v.Name, v); + end; + finally + sl.Free; + end; +end; + +procedure TfsScript.AddEnumSet(const Typ, Names: String); +var + i, j: Integer; + v: TfsVariable; + sl: TStringList; +begin + v := TfsVariable.Create(Typ, fvtEnum, Typ); + Add(v.Name, v); + + sl := TStringList.Create; + sl.CommaText := Names; + + try + j := 1; + for i := 0 to sl.Count - 1 do + begin + v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ); + v.Value := j; + v.IsReadOnly := True; + Add(v.Name, v); + j := j * 2; + end; + finally + sl.Free; + end; +end; + +procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent; + const Category: String = ''; const Description: String = ''); +var + v: TfsMethodHelper; +begin + v := TfsMethodHelper.Create(Syntax, Self); + v.FOnCall := CallEvent; + if Description = '' then + v.FDescription := v.Name else + v.FDescription := Description; + v.FCategory := Category; + Add(v.Name, v); +end; + +procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent; + const Category: String = ''; const Description: String = ''); +var + v: TfsMethodHelper; +begin + v := TfsMethodHelper.Create(Syntax, Self); + v.FOnCallNew := CallEvent; + if Description = '' then + v.FDescription := v.Name else + v.FDescription := Description; + v.FCategory := Category; + Add(v.Name, v); +end; + +procedure TfsScript.AddObject(const Name: String; Obj: TObject); +begin + AddVariable(Name, Obj.ClassName, Integer(Obj)); +end; + +procedure TfsScript.AddVariable(const Name, Typ: String; const Value: Variant); +var + v: TfsVariable; +begin + if Find(Name) <> nil then Exit; + + v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ); + v.Value := Value; + v.OnGetVarValue := FOnGetVarValue; + Add(v.Name, v); +end; + +procedure TfsScript.AddForm(Form: TComponent); +begin + AddComponent(Form); +end; + +procedure TfsScript.AddComponent(Form: TComponent); +{$IFNDEF NOFORMS} +var + i: Integer; + v: TfsClassVariable; +{$ENDIF} +begin +{$IFNDEF NOFORMS} + v := FindClass(Form.ClassName); + if v = nil then + begin + if Form.InheritsFrom(TForm) then + AddClass(Form.ClassType, 'TForm') + else if Form.InheritsFrom(TDataModule) then + AddClass(Form.ClassType, 'TDataModule') +{$IFDEF Delphi5} + else if Form.InheritsFrom(TFrame) then + AddClass(Form.ClassType, 'TFrame') +{$ENDIF} + else + Exit; + v := FindClass(Form.ClassName); + end; + + for i := 0 to Form.ComponentCount - 1 do + v.AddComponent(Form.Components[i]); + AddObject(Form.Name, Form); +{$ENDIF} +end; + +procedure TfsScript.AddRTTI; +var + i: Integer; + rtti: TfsRTTIModule; + obj: TClass; +begin + if FRTTIAdded then Exit; + + AddedBy := TObject(1); // do not clear + for i := 0 to FRTTIModules.Count - 1 do + begin + obj := TClass(FRTTIModules[i]); + rtti := TfsRTTIModule(obj.NewInstance); + rtti.Create(Self); + Add('', rtti); + end; + AddedBy := nil; + + FRTTIAdded := True; +end; + +procedure TfsScript.ClearRTTI; +var + i: Integer; + item: TObject; +begin + if not FRTTIAdded then Exit; + + i := 0; + while i < FItems.Count do + begin + item := FItems.Objects[i]; + if (item is TfsRTTIModule) or + ((item is TfsCustomVariable) and + (TfsCustomVariable(item).AddedBy = TObject(1))) then + begin + item.Free; + FItems.Delete(i); + end + else + Inc(i); + end; + + FRTTIAdded := False; +end; + +function TfsScript.CallFunction(const Name: String; const Params: Variant): Variant; +var + i: Integer; + v: TfsCustomVariable; + p: TfsProcVariable; +begin + v := FindLocal(Name); + if (v <> nil) and (v is TfsProcVariable) then + begin + p := TfsProcVariable(v); + + if VarIsArray(Params) then + for i := 0 to VarArrayHighBound(Params, 1) do + p.Params[i].Value := Params[i]; + Result := p.Value; + end + else + begin + Result := Null; + end +end; + +function TfsScript.CallFunction1(const Name: String; var Params: Variant): Variant; +var + i: Integer; + v: TfsCustomVariable; + p: TfsProcVariable; +begin + v := FindLocal(Name); + if (v <> nil) and (v is TfsProcVariable) then + begin + p := TfsProcVariable(v); + + if VarIsArray(Params) then + for i := 0 to VarArrayHighBound(Params, 1) do + p.Params[i].Value := Params[i]; + Result := p.Value; + if VarIsArray(Params) then + for i := 0 to VarArrayHighBound(Params, 1) do + Params[i] := p.Params[i].Value; + end + else + Result := Null; +end; + +function TfsScript.CallFunction2(const Func: TfsProcVariable; const Params: Variant): Variant; +var + i: Integer; +begin + if (Func <> nil) then + begin + if VarIsArray(Params) then + for i := 0 to VarArrayHighBound(Params, 1) do + Func.Params[i].Value := Params[i]; + Result := Func.Value; + end + else + begin + Result := Null; + end +end; + +function TfsScript.Evaluate(const Expression: String): Variant; +var + p: TfsScript; + Prog: TfsScript; + SaveEvent: TfsRunLineEvent; +begin + FEvaluteRiseError := False; + Result := Null; + if FProgRunning = nil then + p := Self else + p := FProgRunning; + + Prog := TfsScript.Create(nil); + if not p.FRTTIAdded then + Prog.AddRTTI; + Prog.Parent := p; + Prog.OnGetVarValue := p.OnGetVarValue; + SaveEvent := FOnRunLine; + FOnRunLine := nil; + try + prog.SyntaxType := SyntaxType; + if CompareText(SyntaxType, 'PascalScript') = 0 then + Prog.Lines.Text := 'function fsEvaluateFUNC: Variant; begin Result := ' + Expression + ' end; begin end.' + else if CompareText(SyntaxType, 'C++Script') = 0 then + Prog.Lines.Text := 'Variant fsEvaluateFUNC() { return ' + Expression + '; } {}' + else if CompareText(SyntaxType, 'BasicScript') = 0 then + Prog.Lines.Text := 'function fsEvaluateFUNC' + #13#10 + 'return ' + Expression + #13#10 + 'end function' + else if CompareText(SyntaxType, 'JScript') = 0 then + Prog.Lines.Text := 'function fsEvaluateFUNC() { return (' + Expression + '); }'; + if not Prog.Compile then + begin + Result := Prog.ErrorMsg; + FEvaluteRiseError := True; + end + else + Result := Prog.FindLocal('fsEvaluateFUNC').Value; + finally + Prog.Free; + FOnRunLine := SaveEvent; + end; +end; + +function TfsScript.FindClass(const Name: String): TfsClassVariable; +var + Item: TfsCustomVariable; +begin + Item := Find(Name); + if (Item <> nil) and (Item is TfsClassVariable) then + Result := TfsClassVariable(Item) else + Result := nil +end; + +procedure TfsScript.RunLine(const UnitName, Index: String); +var + p: TfsScript; +begin + p := Self; + while p <> nil do + if Assigned(p.FOnRunLine) then + begin + p.FOnRunLine(Self, UnitName, Index); + break; + end + else + p := p.FParent; +end; + +function TfsScript.GetVariables(Index: String): Variant; +var + v: TfsCustomVariable; +begin + v := Find(Index); + if v <> nil then + Result := v.Value else + Result := Null; +end; + +procedure TfsScript.SetVariables(Index: String; const Value: Variant); +var + v: TfsCustomVariable; +begin + v := Find(Index); + if v <> nil then + v.Value := Value else + AddVariable(Index, 'Variant', Value); +end; + +procedure TfsScript.SetLines(const Value: TStrings); +begin + FLines.Assign(Value); +end; + +procedure TfsScript.Terminate; + + procedure TerminateAll(Script: TfsScript); + var + i: Integer; + begin + Script.FExitCalled := True; + Script.FTerminated := True; + for i := 0 to Script.Count - 1 do + if Script.Items[i] is TfsProcVariable then + TerminateAll(TfsProcVariable(Script.Items[i]).Prog); + end; + +begin + TerminateAll(Self); +end; + +procedure TfsScript.AddCodeLine(const UnitName, APos: String); +var + sl: TStringList; + LineN: String; + i : Integer; +begin + i := FUnitLines.IndexOf(UnitName); + + if (i = -1) then + begin + sl := TStringList.Create; + sl.Sorted := True; + FUnitLines.AddObject(UnitName, sl); + end else + begin + sl := TStringList(FUnitLines.Objects[i]); + end; + + LineN := Copy(APos, 1, Pos(':', APos) - 1); + if sl.IndexOf(LineN) = -1 then + begin + sl.Add(LineN); + end; +end; + +function TfsScript.IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean; +var + sl: TStringList; + i: Integer; +begin + Result := False; + + i := FUnitLines.IndexOf(UnitName); + if (i = -1) then Exit; + + sl := TStringList(FUnitLines.Objects[i]); + if sl.IndexOf(IntToStr(LineN)) <> -1 then + Result := True; +end; + + + + +{ TfsStatement } + +constructor TfsStatement.Create(AProgram: TfsScript; const UnitName, + SourcePos: String); +begin + inherited Create; + FProgram := AProgram; + FSourcePos := SourcePos; + FUnitName := UnitName; +end; + +function TfsStatement.GetItem(Index: Integer): TfsStatement; +begin + Result := FItems[Index]; +end; + +procedure TfsStatement.Execute; +var + i: Integer; +begin + for i := 0 to Count - 1 do + begin + if FProgram.FTerminated then break; + Items[i].Execute; + if FProgram.FBreakCalled or FProgram.FContinueCalled or + FProgram.FExitCalled then break; + end; +end; + +procedure TfsStatement.RunLine; +begin + FProgram.RunLine(FUnitName, FSourcePos); +end; + + +{ TfsAssignmentStmt } + +destructor TfsAssignmentStmt.Destroy; +begin + FDesignator.Free; + FExpression.Free; + inherited; +end; + +procedure TfsAssignmentStmt.Optimize; +begin + FVar := FDesignator; + FExpr := FExpression; + + if FDesignator is TfsVariableDesignator then + FVar := FDesignator.RefItem; + if TfsExpression(FExpression).SingleItem <> nil then + FExpr := TfsExpression(FExpression).SingleItem; +end; + +procedure TfsAssignmentStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FVar.Value := FExpr.Value; +end; + +procedure TfsAssignPlusStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FVar.Value := FVar.Value + FExpr.Value; +end; + +procedure TfsAssignMinusStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FVar.Value := FVar.Value - FExpr.Value; +end; + +procedure TfsAssignMulStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FVar.Value := FVar.Value * FExpr.Value; +end; + +procedure TfsAssignDivStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FVar.Value := FVar.Value / FExpr.Value; +end; + + +{ TfsCallStmt } + +destructor TfsCallStmt.Destroy; +begin + FDesignator.Free; + inherited; +end; + +procedure TfsCallStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + if FModificator = '' then + begin + FDesignator.NeedResult := False; + FDesignator.Value; + end + else if FModificator = '+' then + FDesignator.Value := FDesignator.Value + 1 + else if FModificator = '-' then + FDesignator.Value := FDesignator.Value - 1 +end; + + +{ TfsIfStmt } + +constructor TfsIfStmt.Create(AProgram: TfsScript; const UnitName, + SourcePos: String); +begin + inherited; + FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos); +end; + +destructor TfsIfStmt.Destroy; +begin + FCondition.Free; + FElseStmt.Free; + inherited; +end; + +procedure TfsIfStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + if Boolean(FCondition.Value) = True then + inherited Execute else + FElseStmt.Execute; +end; + + +{ TfsRepeatStmt } + +destructor TfsRepeatStmt.Destroy; +begin + FCondition.Free; + inherited; +end; + +procedure TfsRepeatStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + + repeat + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + until Boolean(FCondition.Value) = not FInverseCondition; + + FProgram.FBreakCalled := False; +end; + + +{ TfsWhileStmt } + +destructor TfsWhileStmt.Destroy; +begin + FCondition.Free; + inherited; +end; + +procedure TfsWhileStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + + while Boolean(FCondition.Value) = True do + begin + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + end; + + FProgram.FBreakCalled := False; +end; + + +{ TfsForStmt } + +destructor TfsForStmt.Destroy; +begin + FBeginValue.Free; + FEndValue.Free; + inherited; +end; + +procedure TfsForStmt.Execute; +var + i, bValue, eValue: Integer; +begin + bValue := FBeginValue.Value; + eValue := FEndValue.Value; + RunLine; + if FProgram.FTerminated then Exit; + + if FDown then + for i := bValue downto eValue do + begin + FVariable.FValue := i; + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + end + else + for i := bValue to eValue do + begin + FVariable.FValue := i; + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + end; + + FProgram.FBreakCalled := False; +end; + + +{ TfsVbForStmt } + +destructor TfsVbForStmt.Destroy; +begin + FBeginValue.Free; + FEndValue.Free; + if FStep <> nil then + FStep.Free; + inherited; +end; + +procedure TfsVbForStmt.Execute; +var + i, bValue, eValue, sValue: Variant; + Down: Boolean; +begin + bValue := FBeginValue.Value; + eValue := FEndValue.Value; + if FStep <> nil then + sValue := FStep.Value else + sValue := 1; + Down := sValue < 0; + + RunLine; + if FProgram.FTerminated then Exit; + i := bValue; + if Down then + while i >= eValue do + begin + FVariable.FValue := i; + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + i := i + sValue; + end + else + while i <= eValue do + begin + FVariable.FValue := i; + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + i := i + sValue; + end; + + FProgram.FBreakCalled := False; +end; + + +{ TfsCppForStmt } + +constructor TfsCppForStmt.Create(AProgram: TfsScript; const UnitName, + SourcePos: String); +begin + inherited; + FFirstStmt := TfsStatement.Create(FProgram, UnitName, SourcePos); + FSecondStmt := TfsStatement.Create(FProgram, UnitName, SourcePos); +end; + +destructor TfsCppForStmt.Destroy; +begin + FFirstStmt.Free; + FExpression.Free; + FSecondStmt.Free; + inherited; +end; + +procedure TfsCppForStmt.Execute; +begin + RunLine; + if FProgram.FTerminated then Exit; + FFirstStmt.Execute; + if FProgram.FTerminated then Exit; + while Boolean(FExpression.Value) = True do + begin + inherited Execute; + if FProgram.FBreakCalled or FProgram.FExitCalled then break; + FProgram.FContinueCalled := False; + FSecondStmt.Execute; + end; + + FProgram.FBreakCalled := False; +end; + + +{ TfsCaseSelector } + +destructor TfsCaseSelector.Destroy; +begin + FSetExpression.Free; + inherited; +end; + +function TfsCaseSelector.Check(const Value: Variant): Boolean; +begin + Result := FSetExpression.Check(Value); +end; + + +{ TfsCaseStmt } + +constructor TfsCaseStmt.Create(AProgram: TfsScript; const UnitName, + SourcePos: String); +begin + inherited; + FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos); +end; + +destructor TfsCaseStmt.Destroy; +begin + FCondition.Free; + FElseStmt.Free; + inherited; +end; + +procedure TfsCaseStmt.Execute; +var + i: Integer; + Value: Variant; + Executed: Boolean; +begin + Value := FCondition.Value; + Executed := False; + + RunLine; + if FProgram.FTerminated then Exit; + for i := 0 to Count - 1 do + if TfsCaseSelector(Items[i]).Check(Value) then + begin + Items[i].Execute; + Executed := True; + break; + end; + + if not Executed then + FElseStmt.Execute; +end; + + +{ TfsTryStmt } + +constructor TfsTryStmt.Create(AProgram: TfsScript; const UnitName, + SourcePos: String); +begin + inherited; + FExceptStmt := TfsStatement.Create(AProgram, UnitName, SourcePos); +end; + +destructor TfsTryStmt.Destroy; +begin + FExceptStmt.Free; + inherited; +end; + +procedure TfsTryStmt.Execute; +var + SaveExitCalled: Boolean; +begin + RunLine; + if FProgram.FTerminated then Exit; + if IsExcept then + begin + try + inherited Execute; + except + on E: Exception do + begin + FProgram.SetVariables('ExceptionClassName', E.ClassName); + FProgram.SetVariables('ExceptionMessage', E.Message); + ExceptStmt.Execute; + end; + end; + end + else + begin + try + inherited Execute; + finally + SaveExitCalled := FProgram.FExitCalled; + FProgram.FExitCalled := False; + ExceptStmt.Execute; + FProgram.FExitCalled := SaveExitCalled; + end + end; +end; + + +{ TfsBreakStmt } + +procedure TfsBreakStmt.Execute; +begin + FProgram.FBreakCalled := True; +end; + + +{ TfsContinueStmt } + +procedure TfsContinueStmt.Execute; +begin + FProgram.FContinueCalled := True; +end; + + +{ TfsExitStmt } + +procedure TfsExitStmt.Execute; +begin + RunLine; + FProgram.FExitCalled := True; +end; + + +{ TfsWithStmt } + +destructor TfsWithStmt.Destroy; +begin + FDesignator.Free; + inherited; +end; + +procedure TfsWithStmt.Execute; +begin + inherited; + FVariable.Value := FDesignator.Value; +end; + + +{ TfsArrayHelper } + +constructor TfsArrayHelper.Create(const AName: String; DimCount: Integer; + Typ: TfsVarType; const TypeName: String); +var + i: Integer; +begin + inherited Create(AName, Typ, TypeName); + + if DimCount <> -1 then + begin + for i := 0 to DimCount - 1 do + Add(TfsParamItem.Create('', fvtInt, '', False, False)); + end + else + for i := 0 to 2 do + Add(TfsParamItem.Create('', fvtInt, '', i > 0, False)); +end; + +destructor TfsArrayHelper.Destroy; +begin + inherited; +end; + +function TfsArrayHelper.GetValue: Variant; +var + DimCount: Integer; +begin + DimCount := VarArrayDimCount(ParentRef.PValue^); + case DimCount of + 1: Result := ParentRef.PValue^[Params[0].Value]; + 2: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value]; + 3: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value]; + else + Result := Null; + end; +end; + +procedure TfsArrayHelper.SetValue(const Value: Variant); +var + DimCount: Integer; +begin + DimCount := VarArrayDimCount(ParentRef.PValue^); + case DimCount of + 1: ParentRef.PValue^[Params[0].Value] := Value; + 2: ParentRef.PValue^[Params[0].Value, Params[1].Value] := Value; + 3: ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value] := Value; + end; +end; + + +{ TfsStringHelper } + +constructor TfsStringHelper.Create; +begin + inherited Create('__StringHelper', fvtChar, ''); + Add(TfsParamItem.Create('', fvtInt, '', False, False)); +end; + +function TfsStringHelper.GetValue: Variant; +begin + Result := String(ParentValue)[Integer(Params[0].Value)]; +end; + +procedure TfsStringHelper.SetValue(const Value: Variant); +var + s: String; +begin + s := ParentValue; + s[Integer(Params[0].Value)] := String(Value)[1]; + TfsCustomVariable(Integer(ParentRef)).Value := s; +end; + + +{ TfsCustomEvent } + +constructor TfsCustomEvent.Create(AObject: TObject; AHandler: TfsProcVariable); +begin + FInstance := AObject; + FHandler := AHandler; +end; + +procedure TfsCustomEvent.CallHandler(Params: array of const); +var + i: Integer; +begin + if FHandler.Executing then Exit; + for i := 0 to FHandler.Count - 1 do + FHandler.Params[i].Value := VarRecToVariant(Params[i]); + FHandler.Value; +end; + + +{ TfsRTTIModule } + +constructor TfsRTTIModule.Create(AScript: TfsScript); +begin + FScript := AScript; +end; + + +function fsGlobalUnit: TfsScript; +begin + if (FGlobalUnit = nil) and not FGlobalUnitDestroyed then + begin + FGlobalUnit := TfsScript.Create(nil); + FGlobalUnit.AddRTTI; + end; + Result := FGlobalUnit; +end; + +function fsRTTIModules: TList; +begin + if (FRTTIModules = nil) and not FRTTIModulesDestroyed then + begin + FRTTIModules := TList.Create; + FRTTIModules.Add(TfsSysFunctions); + end; + Result := FRTTIModules; +end; + +{ TfsVariable } + +function TfsVariable.GetValue: Variant; +begin + Result := inherited GetValue; + if Assigned(FOnGetVarValue) then + begin + Result := FOnGetVarValue(FName, FTyp, FValue); + if Result = null then Result := FValue; + end; +end; + +procedure TfsVariable.SetValue(const Value: Variant); +begin + if not FIsReadOnly then + case FTyp of + fvtInt: FValue := VarAsType(Value, varInteger); + fvtBool: FValue := VarAsType(Value, varBoolean); + fvtFloat: FValue := VarAsType(Value, varDouble); + fvtString: FValue := VarAsType(Value, varString); + else + FValue := Value; + end; +end; + +initialization + FGlobalUnitDestroyed := False; + FRTTIModulesDestroyed := False; + fsRTTIModules; + +finalization + if FGlobalUnit <> nil then + FGlobalUnit.Free; + FGlobalUnit := nil; + FGlobalUnitDestroyed := True; + FRTTIModules.Free; + FRTTIModules := nil; + FRTTIModulesDestroyed := True; + +end. diff --git a/official/4.8.11/FastScript/fs_ijs.pas b/official/4.8.11/FastScript/fs_ijs.pas new file mode 100644 index 0000000..a3d6d5d --- /dev/null +++ b/official/4.8.11/FastScript/fs_ijs.pas @@ -0,0 +1,146 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ JScript grammar } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ijs; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_itools; + +type + TfsJScript = class(TComponent); + + +implementation + +const + JS_GRAMMAR = + '' + + '' + + '<' + + 'loop text=","><' + + 'char text="!" add="op" addtext="not"/>' + + '<' + + 'char text="-" add="op"/><' + + 'expression err="err2"/>' + + '<' + + 'forstmtitem/>'; + + +initialization + fsRegisterLanguage('JScript', JS_GRAMMAR); + +end. diff --git a/official/4.8.11/FastScript/fs_imenusrtti.pas b/official/4.8.11/FastScript/fs_imenusrtti.pas new file mode 100644 index 0000000..eed5da5 --- /dev/null +++ b/official/4.8.11/FastScript/fs_imenusrtti.pas @@ -0,0 +1,176 @@ +{**********************************************} +{ } +{ FastScript v1.9 } +{ Menus } +{ } +{ Copyright (c) 1998-2007 } +{ by Fast Reports Inc. } +{ } +{ Copyright (c) 2006 by Кропотин Иван } +{ Copyright (c) 2006-2007 by Stalker SoftWare } +{ } +{**********************************************} + +unit fs_imenusrtti; + +interface + +{$I fs.inc} + +uses + SysUtils, Classes, Menus, fs_iinterpreter, fs_ievents, ImgList +{$IFDEF Delphi6} +, Types , Variants +{$ENDIF}; + +type + TfsMenusRTTI = class(TComponent); // fake component + +implementation + +type + TFunctions = class(TfsRTTIModule) + private + function CallMethod(Instance: TObject; ClassType: TClass; const MethodName: + string; Caller: TfsMethodHelper): Variant; + function GetProp(Instance: TObject; ClassType: TClass; const PropName: + string): Variant; + procedure SetProp(Instance: TObject; ClassType: TClass; const PropName: + string; Value: Variant); + public + constructor Create(AScript: TfsScript); override; + end; + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + + with AScript do + begin + + AddType('TPopupAlignment', fvtInt); + + AddClass(TCustomImageList, 'TComponent'); + + with AddClass(TMenuItem, 'TComponent') do + begin + AddMethod('procedure Add(Item: TMenuItem)', CallMethod); + AddMethod('procedure Clear', CallMethod); + AddMethod('procedure Delete(Index: Integer)', CallMethod); + AddMethod('procedure Insert(Index: Integer; Item: TMenuItem)', + CallMethod); + AddMethod('procedure Remove(Item: TMenuItem)', CallMethod); + AddMethod('function GetParentMenu: TMenu', CallMethod); + AddEvent('OnClick', TfsNotifyEvent); + AddProperty('Count', 'Integer', GetProp); + AddDefaultProperty('Items', 'Integer', 'TMenuItem', CallMethod, True); + end; { with } + + with AddClass(TMenu, 'TComponent') do + AddIndexProperty('Items', 'Integer', 'TMenuItem', CallMethod, True); + + with AddClass(TPopupMenu, 'TMenu') do + begin + AddEvent('OnPopup', TfsNotifyEvent); + AddMethod('procedure Popup(X, Y: Extended)', CallMethod); + AddProperty('PopupComponent', 'TComponent', GetProp, SetProp); + AddProperty('Images', 'TCustomImageList', GetProp, SetProp); + end; { with } + + end; { with } + +end; { Create } + +function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; const + MethodName: string; Caller: TfsMethodHelper): Variant; +var + oMenuItem: TMenuItem; +begin + Result := 0; + + if ClassType = TMenuItem then + begin + + oMenuItem := TMenuItem(Instance); + + if MethodName = 'ADD' then + oMenuItem.Add(TMenuItem(Integer(Caller.Params[0]))) +{$IFDEF Delphi5} + else if MethodName = 'CLEAR' then + oMenuItem.Clear +{$ENDIF} + else if MethodName = 'DELETE' then + oMenuItem.Delete(Caller.Params[0]) + else if MethodName = 'INSERT' then + oMenuItem.Insert(Caller.Params[0], TMenuItem(Integer(Caller.Params[1]))) + else if MethodName = 'REMOVE' then + oMenuItem.Remove(TMenuItem(Integer(Caller.Params[0]))) + else if MethodName = 'ITEMS.GET' then + Result := Integer(oMenuItem.Items[Caller.Params[0]]) + else if MethodName = 'GETPARENTMENU' then + Result := Integer(oMenuItem.GetParentMenu()); + + end + else if ClassType = TMenu then + begin + + if MethodName = 'ITEMS.GET' then + Result := Integer(TMenu(Instance).Items[Caller.Params[0]]) + + end + else if ClassType = TPopupMenu then + begin + + if MethodName = 'POPUP' then + TPopupMenu(Instance).Popup(Caller.Params[0], Caller.Params[1]); + + end; { if } + +end; { CallMethod } + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; const + PropName: string): Variant; +begin + Result := 0; + + if ClassType = TMenuItem then + begin + + if PropName = 'COUNT' then + Result := TMenuItem(Instance).Count; + + end + else if ClassType = TPopupMenu then + begin + + if PropName = 'POPUPCOMPONENT' then + Result := Integer(TPopupMenu(Instance).PopupComponent) + else if PropName = 'IMAGES' then + Result := Integer(TPopupMenu(Instance).Images) + + end; { if } + +end; { GetProp } + +procedure TFunctions.SetProp(Instance: TObject; ClassType: TClass; const + PropName: string; Value: Variant); +begin + if ClassType = TPopupMenu then + begin + if PropName = 'IMAGES' then + TPopupMenu(Instance).Images := TCustomImageList(Integer(Value)) + else if PropName = 'POPUPCOMPONENT' then + TPopupMenu(Instance).PopupComponent := TComponent(Integer(Value)) + + end; { if } + +end; { SetProp } + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + fsRTTIModules.Remove(TFunctions); + +end. + diff --git a/official/4.8.11/FastScript/fs_iparser.pas b/official/4.8.11/FastScript/fs_iparser.pas new file mode 100644 index 0000000..789e254 --- /dev/null +++ b/official/4.8.11/FastScript/fs_iparser.pas @@ -0,0 +1,751 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Parser } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_iparser; + +interface + +{$i fs.inc} + +uses +{$IFNDEF CROSS_COMPILE} + Windows, +{$ENDIF} + SysUtils, Classes; + + +type + TfsIdentifierCharset = set of AnsiChar; + + { TfsParser parser the source text and return such elements as identifiers, + keywords, punctuation, strings and numbers. } + + TfsParser = class(TObject) + private + FCaseSensitive: Boolean; + FCommentBlock1: String; + FCommentBlock11: String; + FCommentBlock12: String; + FCommentBlock2: String; + FCommentBlock21: String; + FCommentBlock22: String; + FCommentLine1: String; + FCommentLine2: String; + FHexSequence: String; + FIdentifierCharset: TfsIdentifierCharset; + FKeywords: TStrings; + FLastPosition: Integer; + FPosition: Integer; + FSize: Integer; + FSkiPChar: String; + FSkipEOL: Boolean; + FSkipSpace: Boolean; + FStringQuotes: String; + FText: String; + FUseY: Boolean; + FYList: TList; + FSpecStrChar: Boolean; + function DoDigitSequence: Boolean; + function DoHexDigitSequence: Boolean; + function DoScaleFactor: Boolean; + function DoUnsignedInteger: Boolean; + function DoUnsignedReal: Boolean; + procedure SetPosition(const Value: Integer); + procedure SetText(const Value: String); + function Ident: String; + procedure SetCommentBlock1(const Value: String); + procedure SetCommentBlock2(const Value: String); + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure ConstructCharset(const s: String); + + { skip all #0..#31 symbols } + procedure SkipSpaces; + { get EOL symbol } + function GetEOL: Boolean; + { get any valid ident except keyword } + function GetIdent: String; + { get any valid punctuation symbol like ,.;: } + function GetChar: String; + { get any valid ident or keyword } + function GetWord: String; + { get valid hex/int/float number } + function GetNumber: String; + { get valid quoted/control string like 'It''s'#13#10'working' } + function GetString: String; + { get FR-specific string - variable or db field like [main data."field 1"] } + function GetFRString: String; + { get Y:X position } + function GetXYPosition: String; + { get plain position from X:Y } + function GetPlainPosition(pt: TPoint): Integer; + { is this keyword? } + function IsKeyWord(const s: String): Boolean; + + // Language-dependent elements + // For Pascal: + // CommentLine1 := '//'; + // CommentBlock1 := '{,}'; + // CommentBlock2 := '(*,*)'; + // HexSequence := '$' + // IdentifierCharset := ['_', '0'..'9', 'a'..'z', 'A'..'Z']; + // Keywords: 'begin','end', ... + // StringQuotes := '''' + property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive; + property CommentBlock1: String read FCommentBlock1 write SetCommentBlock1; + property CommentBlock2: String read FCommentBlock2 write SetCommentBlock2; + property CommentLine1: String read FCommentLine1 write FCommentLine1; + property CommentLine2: String read FCommentLine2 write FCommentLine2; + property HexSequence: String read FHexSequence write FHexSequence; + property IdentifierCharset: TfsIdentifierCharset read FIdentifierCharset + write FIdentifierCharset; + property Keywords: TStrings read FKeywords; + property SkiPChar: String read FSkiPChar write FSkiPChar; + property SkipEOL: Boolean read FSkipEOL write FSkipEOL; + property SkipSpace: Boolean read FSkipSpace write FSkipSpace; + property StringQuotes: String read FStringQuotes write FStringQuotes; + property SpecStrChar: Boolean read FSpecStrChar write FSpecStrChar; + property UseY: Boolean read FUseY write FUseY; + + { Current position } + property Position: Integer read FPosition write SetPosition; + { Text to parse } + property Text: String read FText write SetText; + end; + + +implementation + + +{ TfsParser } + +constructor TfsParser.Create; +begin + FKeywords := TStringList.Create; + TStringList(FKeywords).Sorted := True; + FYList := TList.Create; + FUseY := True; + Clear; +end; + +destructor TfsParser.Destroy; +begin + FKeywords.Free; + FYList.Free; + inherited; +end; + +procedure TfsParser.Clear; +begin + FKeywords.Clear; + FSpecStrChar := False; + FCommentLine1 := '//'; + CommentBlock1 := '{,}'; + CommentBlock2 := '(*,*)'; + FHexSequence := '$'; + FIdentifierCharset := ['_', '0'..'9', 'a'..'z', 'A'..'Z']; + FSkipChar := ''; + FSkipEOL := True; + FStringQuotes := ''''; + FSkipSpace := True; +end; + +procedure TfsParser.SetCommentBlock1(const Value: String); +var + sl: TStringList; +begin + FCommentBlock1 := Value; + FCommentBlock11 := ''; + FCommentBlock12 := ''; + + sl := TStringList.Create; + sl.CommaText := FCommentBlock1; + if sl.Count > 0 then + FCommentBlock11 := sl[0]; + if sl.Count > 1 then + FCommentBlock12 := sl[1]; + sl.Free; +end; + +procedure TfsParser.SetCommentBlock2(const Value: String); +var + sl: TStringList; +begin + FCommentBlock2 := Value; + FCommentBlock21 := ''; + FCommentBlock22 := ''; + + sl := TStringList.Create; + sl.CommaText := FCommentBlock2; + if sl.Count > 0 then + FCommentBlock21 := sl[0]; + if sl.Count > 1 then + FCommentBlock22 := sl[1]; + sl.Free; +end; + +procedure TfsParser.SetPosition(const Value: Integer); +begin + FPosition := Value; + FLastPosition := Value; +end; + +procedure TfsParser.SetText(const Value: String); +var + i: Integer; +begin + FText := Value + #0; + FLastPosition := 1; + FPosition := 1; + FSize := Length(Value); + + if FUseY then + begin + FYList.Clear; + FYList.Add(TObject(0)); + for i := 1 to FSize do + if FText[i] = #10 then + FYList.Add(TObject(i)); + end; +end; + +procedure TfsParser.ConstructCharset(const s: String); +var + i: Integer; +begin + FIdentifierCharset := []; + for i := 1 to Length(s) do + FIdentifierCharset := FIdentifierCharset + [s[i]]; +end; + +function TfsParser.GetEOL: Boolean; +begin + SkipSpaces; +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], [#10, #13]) then +{$ELSE} + if FText[FPosition] in [#10, #13] then +{$ENDIF} + begin + Result := True; +{$IFDEF Delphi12} + while CharInSet(FText[FPosition], [#10, #13]) do +{$ELSE} + while FText[FPosition] in [#10, #13] do +{$ENDIF} + Inc(FPosition); + end + else + Result := False; +end; + +procedure TfsParser.SkipSpaces; +var + s1, s2: String; + Flag, CLine: Boolean; + Spaces: set of AnsiChar; +begin + Spaces := [#0..#32]; + if not FSkipEOL then +{$IFDEF LINUX} + Spaces := Spaces - [#10]; +{$ELSE} + Spaces := Spaces - [#13]; +{$ENDIF} +{$IFDEF Delphi12} + while (FPosition <= FSize) and (CharInSet(FText[FPosition], Spaces)) do +{$ELSE} + while (FPosition <= FSize) and (FText[FPosition] in Spaces) do +{$ENDIF} + Inc(FPosition); + { skip basic '_' } + if (FPosition <= FSize) and (FSkipChar <> '') and (FText[FPosition] = FSkipChar[1]) then + begin + Inc(FPosition); + GetEOL; + SkipSpaces; + end; + + if FPosition < FSize then + begin + if FCommentLine1 <> '' then + s1 := Copy(FText, FPosition, Length(FCommentLine1)) else + s1 := ' '; + if FCommentLine2 <> '' then + s2 := Copy(FText, FPosition, Length(FCommentLine2)) else + s2 := ' '; + + if (s1 = FCommentLine1) or (s2 = FCommentLine2) then + begin + CLine := (FPosition - 1 > 0) and (FText[FPosition - 1] <> #10) and not FSkipEOL; + while (FPosition <= FSize) and (FText[FPosition] <> #10) do + begin + if (FText[FPosition] = {$IFDEF LINUX}#10{$ELSE}#13{$ENDIF}) and CLine then break; + Inc(FPosition); + end; + SkipSpaces; + end + else + begin + Flag := False; + + if FCommentBlock1 <> '' then + begin + s1 := Copy(FText, FPosition, Length(FCommentBlock11)); + if s1 = FCommentBlock11 then + begin + Flag := True; + s2 := FCommentBlock12; + end; + end; + + if not Flag and (FCommentBlock2 <> '') then + begin + s1 := Copy(FText, FPosition, Length(FCommentBlock21)); + if s1 = FCommentBlock21 then + begin + Flag := True; + s2 := FCommentBlock22; + end; + end; + + if Flag then + begin + Inc(FPosition, Length(s2)); + while (FPosition <= FSize) and (Copy(FText, FPosition, Length(s2)) <> s2) do + Inc(FPosition); + Inc(FPosition, Length(s2)); + SkipSpaces; + end; + end; + end; + + FLastPosition := FPosition; +end; + +function TfsParser.Ident: String; +begin + if FSkipSpace then + SkipSpaces; +{$IFDEF Delphi12} + if (CharInSet(FText[FPosition], FIdentifierCharset - ['0'..'9'])) + or ((FText[FPosition] >= Char($007F)) and (FText[FPosition] <= Char($FFFF))) then + begin + while CharInSet(FText[FPosition], FIdentifierCharset) + or ((FText[FPosition] >= Char($007F)) and (FText[FPosition] <= Char($FFFF))) do +{$ELSE} + if (FText[FPosition] in FIdentifierCharset - ['0'..'9']) then + begin + while (FText[FPosition] in FIdentifierCharset) do +{$ENDIF} + Inc(FPosition); + Result := Copy(FText, FLastPosition, FPosition - FLastPosition); + end + else + Result := ''; +end; + +function TfsParser.IsKeyWord(const s: String): Boolean; +var + i: Integer; +begin + if FCaseSensitive then + begin + Result := False; + for i := 0 to FKeywords.Count - 1 do + begin + Result := FKeywords[i] = s; + if Result then break; + end; + end + else + Result := FKeywords.IndexOf(s) <> -1; +end; + +function TfsParser.GetIdent: String; +begin + Result := Ident; + if IsKeyWord(Result) then + Result := ''; +end; + +function TfsParser.GetWord: String; +begin + Result := Ident; +end; + +function TfsParser.GetChar: String; +begin +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['!', '@', '#', '$', '%', '^', '&', '|', '\', + '.', ',', ':', ';', '?', '''', '"', '~', '`', '_', '[', ']', '{', '}', + '(', ')', '+', '-', '*', '/', '=', '<', '>']) then +{$ELSE} + if FText[FPosition] in ['!', '@', '#', '$', '%', '^', '&', '|', '\', + '.', ',', ':', ';', '?', '''', '"', '~', '`', '_', '[', ']', '{', '}', + '(', ')', '+', '-', '*', '/', '=', '<', '>'] then +{$ENDIF} + begin + Result := FText[FPosition]; + Inc(FPosition); + end + else + Result := ''; +end; + +function TfsParser.GetString: String; +var + Flag: Boolean; + Str: String; + FError: Boolean; + FCpp: Boolean; + + function DoQuotedString: Boolean; + var + i, j: Integer; + begin + Result := False; + i := FPosition; + + if FText[FPosition] = FStringQuotes[1] then + begin + repeat + Inc(FPosition); + + if FCpp and (FText[FPosition] = '\') then + begin + {$IFNDEF FPC} + {$IFDEF Delphi12} + case Lowercase(Char(FText[FPosition + 1]))[1] of + {$ELSE} + case Lowercase(FText[FPosition + 1])[1] of + {$ENDIF} + {$ELSE} + case Lowercase(FText[FPosition + 1]) of + {$ENDIF} + 'n': + begin + Str := Str + #10; + Inc(FPosition); + end; + 'r': + begin + Str := Str + #13; + Inc(FPosition); + end; + 'x': + begin + Inc(FPosition, 2); + j := FPosition; + Result := DoHexDigitSequence; + if Result then + Str := Str + Chr(StrToInt('$' + Copy(FText, j, FPosition - j))) else + FPosition := j; + Dec(FPosition); + end + else + begin + Str := Str + FText[FPosition + 1]; + Inc(FPosition); + end; + end; + end + else if FText[FPosition] = FStringQuotes[1] then + begin + if not FCpp and (FText[FPosition + 1] = FStringQuotes[1]) then + begin + Str := Str + FStringQuotes[1]; + Inc(FPosition); + end + else + break + end + else + Str := Str + FText[FPosition]; +{$IFDEF Delphi12} + until CharInSet(FText[FPosition], [#0..#31] - [#9]); +{$ELSE} + until FText[FPosition] in [#0..#31] - [#9]; +{$ENDIF} + if FText[FPosition] = FStringQuotes[1] then + begin + Inc(FPosition); + Result := True; + end + else + FPosition := i; + end; + end; + + function DoControlString: Boolean; + var + i: Integer; + begin + Result := False; + i := FPosition; + + if FText[FPosition] = '#' then + begin + Inc(FPosition); + Result := DoUnsignedInteger; + if Result then + Str := Chr(StrToInt(Copy(FText, i + 1, FPosition - i - 1))) else + FPosition := i; + end; + end; + +begin + Result := ''; + if FSkipSpace then + SkipSpaces; + Flag := True; + FError := False; + FCpp := {FStringQuotes = '"'} FSpecStrChar; + + repeat + Str := ''; + if DoQuotedString or DoControlString then + Result := Result + Str + else + begin + FError := Flag; + break; + end; + + Flag := False; + until False; + + if not FError then + Result := '''' + Result + ''''; +end; + +function TfsParser.DoDigitSequence: Boolean; +begin + Result := False; + +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['0'..'9']) then + begin + while CharInSet(FText[FPosition], ['0'..'9']) do +{$ELSE} + if FText[FPosition] in ['0'..'9'] then + begin + while FText[FPosition] in ['0'..'9'] do +{$ENDIF} + Inc(FPosition); + Result := True; + end; +end; + +function TfsParser.DoHexDigitSequence: Boolean; +begin + Result := False; + +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['0'..'9', 'a'..'f', 'A'..'F']) then + begin + while CharInSet(FText[FPosition], ['0'..'9', 'a'..'f', 'A'..'F']) do +{$ELSE} + if FText[FPosition] in ['0'..'9', 'a'..'f', 'A'..'F'] then + begin + while FText[FPosition] in ['0'..'9', 'a'..'f', 'A'..'F'] do +{$ENDIF} + Inc(FPosition); + Result := True; + end; +end; + +function TfsParser.DoUnsignedInteger: Boolean; +var + Pos1: Integer; + s: String; +begin + Pos1 := FPosition; + + s := Copy(FText, FPosition, Length(FHexSequence)); + if s = FHexSequence then + begin + Inc(FPosition, Length(s)); + Result := DoHexDigitSequence; + end + else + Result := DoDigitSequence; + + if not Result then + FPosition := Pos1; +end; + +function TfsParser.DoUnsignedReal: Boolean; +var + Pos1, Pos2: Integer; +begin + Pos1 := FPosition; + Result := DoUnsignedInteger; + + if Result then + begin + if FText[FPosition] = '.' then + begin + Inc(FPosition); + Result := DoDigitSequence; + end; + + if Result then + begin + Pos2 := FPosition; + if not DoScaleFactor then + FPosition := Pos2; + end; + end; + + if not Result then + FPosition := Pos1; +end; + +function TfsParser.DoScaleFactor: Boolean; +begin + Result := False; +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['e', 'E']) then +{$ELSE} + if FText[FPosition] in ['e', 'E'] then +{$ENDIF} + begin + Inc(FPosition); +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['+', '-']) then +{$ELSE} + if FText[FPosition] in ['+', '-'] then +{$ENDIF} + Inc(FPosition); + Result := DoDigitSequence; + end; +end; + +function TfsParser.GetNumber: String; +var + Pos1: Integer; +begin + Result := ''; + if FSkipSpace then + SkipSpaces; + Pos1 := FPosition; + + if DoUnsignedReal or DoUnsignedInteger then + Result := Copy(FText, FLastPosition, FPosition - FLastPosition) else + FPosition := Pos1; + + if FHexSequence <> '$' then + while Pos(FHexSequence, Result) <> 0 do + begin + Pos1 := Pos(FHexSequence, Result); + Delete(Result, Pos1, Length(FHexSequence)); + Insert('$', Result, Pos1); + end; +end; + +function TfsParser.GetFRString: String; +var + i, c: Integer; + fl1, fl2: Boolean; +begin + Result := ''; + i := FPosition; + fl1 := True; + fl2 := True; + c := 1; + + Dec(FPosition); + repeat + Inc(FPosition); +{ if FText[FPosition] in [#10, #13] then + begin + FPosition := i; + break; + end;} + if fl1 and fl2 then +{$IFDEF Delphi12} + if CharInSet(FText[FPosition], ['<', '[']) then +{$ELSE} + if FText[FPosition] in ['<', '['] then +{$ENDIF} + Inc(c) +{$IFDEF Delphi12} + else if CharInSet(FText[FPosition], ['>', ']']) then +{$ELSE} + else if FText[FPosition] in ['>', ']'] then +{$ENDIF} + Dec(c); + if fl1 then + if FText[FPosition] = '"' then + fl2 := not fl2; + if fl2 then + if FText[FPosition] = '''' then + fl1 := not fl1; + until (c = 0) or (FPosition >= Length(FText)); + + Result := Copy(FText, i, FPosition - i); +end; + +function TfsParser.GetXYPosition: String; +var + i, i0, i1, c, pos, X, Y: Integer; +begin + i0 := 0; + i1 := FYList.Count - 1; + + while i0 <= i1 do + begin + i := (i0 + i1) div 2; + pos := Integer(FYList[i]); + + if pos = FPosition then + c := 0 + else if pos > FPosition then + c := 1 + else + c := -1; + + if c < 0 then + i0 := i + 1 + else + begin + i1 := i - 1; + if c = 0 then + i0 := i; + end; + end; + + X := 1; + Y := i0; + i := Integer(FYList[i0 - 1]) + 1; + + while i < FPosition do + begin + Inc(i); + Inc(X); + end; + Result := IntToStr(Y) + ':' + IntToStr(X) +end; + +function TfsParser.GetPlainPosition(pt: TPoint): Integer; +var + i: Integer; +begin + Result := -1; + i := pt.Y - 1; + if (i >= 0) and (i < FYList.Count) then + Result := Integer(FYList[i]) + pt.X; +end; + +end. diff --git a/official/4.8.11/FastScript/fs_ipascal.pas b/official/4.8.11/FastScript/fs_ipascal.pas new file mode 100644 index 0000000..f7d51d7 --- /dev/null +++ b/official/4.8.11/FastScript/fs_ipascal.pas @@ -0,0 +1,183 @@ + +{******************************************} +{ } +{ FastScript v1.9 } +{ Pascal grammar } +{ } +{ (c) 2003-2007 by Alexander Tzyganenko, } +{ Fast Reports Inc } +{ } +{******************************************} + +unit fs_ipascal; + +interface + +{$i fs.inc} + +uses + SysUtils, Classes, fs_itools; + +type + TfsPascal = class(TComponent); + +procedure fsModifyPascalForFR2; + +implementation + +const + PASCAL_GRAMMAR = + '
<' + + 'except/>, , tags + else if (i + 1 <= Length(s)) and (s[i + 1] = '/') then + begin + if (i + 3 <= Length(s)) and (s[i + 3] = '>') then + begin + case s[i + 2] of + 'b','B': FStyle := FStyle - [fsBold]; + 'i','I': FStyle := FStyle - [fsItalic]; + 'u','U': FStyle := FStyle - [fsUnderline]; + else + b := False; + end; + if b then + begin + System.Delete(s, i, 4); + Inc(FPosition, 4); + continue; + end; + end + else if (Pos('STRIKE>', AnsiUpperCase(s)) = i + 2) then + begin + FStyle := FStyle - [fsStrikeOut]; + System.Delete(s, i, 9); + Inc(FPosition, 9); + continue; + end + else if (Pos('NOWRAP>', AnsiUpperCase(s)) = i + 2) then + begin + FDontWRAP := False; + System.Delete(s, i, 9); + Inc(FPosition, 9); + continue; + end + else if Pos('FONT>', AnsiUpperCase(s)) = i + 2 then + begin + FColor := FDefColor; + System.Delete(s, i, 7); + Inc(FPosition, 7); + continue; + end + else if (Pos('SUB>', AnsiUpperCase(s)) = i + 2) or + (Pos('SUP>', AnsiUpperCase(s)) = i + 2) then + begin + FSize := FDefSize; + FAddY := 0; + System.Delete(s, i, 6); + Inc(FPosition, 6); + continue; + end + end + + // tag + else if Pos('FONT COLOR', AnsiUpperCase(s)) = i + 1 then + begin + j := i + 11; + while (j <= Length(s)) and (s[j] <> '=') do + Inc(j); + Inc(j); + while (j <= Length(s)) and (s[j] = ' ') do + Inc(j); + j1 := j; + while (j <= Length(s)) and (s[j] <> '>') do + Inc(j); + + cl := Copy(s, j1, j - j1); + if cl <> '' then + begin + if (Length(cl) > 3) and (cl[1] = '"') and (cl[2] = '#') and + (cl[Length(cl)] = '"') then + begin + cl := '$' + Copy(cl, 3, Length(cl) - 3); + FColor := StrToInt(cl); + FColor := (FColor and $00FF0000) div 65536 + + (FColor and $000000FF) * 65536 + + (FColor and $0000FF00); + System.Delete(s, i, j - i + 1); + Inc(FPosition, j - i + 1); + continue; + end + else if IdentToColor('cl' + cl, FColor) then + begin + System.Delete(s, i, j - i + 1); + Inc(FPosition, j - i + 1); + continue; + end; + end; + end + end; + + AddTag; + Inc(i); + Inc(FPosition); + end; + + if Length(s) = 0 then + begin + AddTag; + s := ' '; + end; +end; + +function TfrxHTMLTagsList.FillCharSpacingArray(var ar: PIntArray; const s: WideString; + Canvas: TCanvas; LineIndex, Add: Integer; Convert: Boolean; DefCharset: Boolean): Integer; +var + i, n, addI: Integer; + Tags: TfrxHTMLTags; + Tag: TfrxHTMLTag; + AnsiStr: AnsiString; + AddNext, Is2ByteCodepage: Boolean; + + procedure BreakArray; + var + i, j, offs: Integer; + Size: TSize; + begin + if {(Win32Platform <> VER_PLATFORM_WIN32_NT) or ((Canvas.Font.Charset <> DEFAULT_CHARSET) and not FUseDefaultCharset)} DefCharset then + begin + GetTextExtentExPointA(Canvas.Handle, PAnsiChar(AnsiStr), n, 0, nil, + @FTempArray[0], Size); + end + else + GetTextExtentExPointW(Canvas.Handle, PWideChar(s), n, 0, nil, + @FTempArray[0], Size); + i := 0; + repeat + if FTempArray[i] = 32767 then + begin + offs := FTempArray[i - 1]; + if {(Win32Platform <> VER_PLATFORM_WIN32_NT) or ((Canvas.Font.Charset <> DEFAULT_CHARSET) and not FUseDefaultCharset)} DefCharset then + begin + GetTextExtentExPointA(Canvas.Handle, PAnsiChar(AnsiStr) + i, n - i, 0, nil, + @FTempArray[i], Size); + end + else + GetTextExtentExPointW(Canvas.Handle, PWideChar(s) + i, n - i, 0, nil, + @FTempArray[i], Size); + for j := i to n - 1 do + if FTempArray[j] = 32767 then + begin + i := j - 1; + break; + end + else + FTempArray[j] := FTempArray[j] + offs; + end; + Inc(i); + until i >= n; + end; + +begin + Result := 0; + DefCharset := (Win32Platform <> VER_PLATFORM_WIN32_NT) or ((Canvas.Font.Charset <> DEFAULT_CHARSET) and not DefCharset); + addI := 0; + AddNext := True; + Is2ByteCodepage := False; + if {((Canvas.Font.Charset <> DEFAULT_CHARSET) and not FUseDefaultCharset) or (Win32Platform <> VER_PLATFORM_WIN32_NT)} DefCharset then + begin + AnsiStr := _UnicodeToAnsi(s, Canvas.Font.Charset); + n := Length(AnsiStr); + Is2ByteCodepage := (n > Length(s)) + end + else n := Length(s); + + Tags := Items[LineIndex]; + Tag := Tags.Items[0]; + if not Tag.Default then + Canvas.Font.Style := Tag.Style; + + BreakArray; + + for i := 0 to n - 1 do + begin + Tag := Tags.Items[i - addI]; + if (i <> 0) and not Tag.Default then + begin + Canvas.Font.Style := Tag.Style; + BreakArray; + end; + + { needs for some codepage like CHINESEBIG5_CHARSET, } + { for spec. characters it use two bytes like in UTF8, } + { but FHTMLTags works only with unicode, and we correct index here} + if Is2ByteCodepage and (Byte(AnsiStr[i + 1]) > $7F) and AddNext then + begin + Inc(addI); + AddNext := False; + end + else AddNext := True; + + if i > 0 then + Ar[i] := FTempArray[i] - FTempArray[i - 1] + Add else + Ar[i] := FTempArray[i] + Add; + if Tag.Small then + Ar[i] := Round(Ar[i] / 1.5); + Inc(Result, Ar[i]); + if Convert and (i > 0) then + Inc(Ar[i], Ar[i - 1]); + end; +end; + + +{ TfrxDrawText } + +constructor TfrxDrawText.Create; +begin + FBMP := TBitmap.Create; + FCanvas := FBMP.Canvas; + FDefPPI := 600; + FScrPpi := 96; + FHTMLTags := TfrxHTMLTagsList.Create; +{$IFDEF Delphi10} + FText := TfrxWideStrings.Create; +{$ELSE} + FText := TWideStrings.Create; +{$ENDIF} + FWysiwyg := True; + GetMem(FTempArray, SizeOf(Integer) * 32768); +end; + +destructor TfrxDrawText.Destroy; +begin + FBMP.Free; + FHTMLTags.Free; + FText.Free; + FreeMem(FTempArray, SizeOf(Integer) * 32768); + inherited; +end; + +procedure TfrxDrawText.SetFont(Font: TFont); +var + h: Integer; +begin + FFontSize := Font.Size; + h := -Round(FFontSize * FDefPPI / 72); // height is as in the 600 dpi printer + FCanvas.Lock; + try + with FCanvas.Font do + begin + if Name <> Font.Name then + Name := Font.Name; + if Height <> h then + Height := h; + if Style <> Font.Style then + Style := Font.Style; + if Charset <> Font.Charset then + Charset := Font.Charset; + if Color <> Font.Color then + Color := Font.Color; + end; + finally + FCanvas.Unlock; + end; +end; + +procedure TfrxDrawText.SetOptions(WordWrap, HTMLTags, RTLReading, + WordBreak, Clipped, Wysiwyg: Boolean; Rotation: Integer); +begin + FWordWrap := WordWrap; + FHTMLTags.AllowTags := HTMLTags; + FRTLReading := RTLReading; + FOptions := 0; + if RTLReading then + FOptions := ETO_RTLREADING; + if Clipped then + FOptions := FOptions or ETO_CLIPPED; + FWordBreak := WordBreak; + FRotation := Rotation mod 360; + FWysiwyg := Wysiwyg; +end; + +procedure TfrxDrawText.SetDimensions(ScaleX, ScaleY, PrintScale: Extended; + OriginalRect, ScaledRect: TRect); +begin + FScaleX := ScaleX; + FScaleY := ScaleY; + FPrintScale := PrintScale; + FOriginalRect := OriginalRect; + FScaledRect := ScaledRect; +end; + +procedure TfrxDrawText.SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended); +begin + FParagraphGap := ParagraphGap; + FCharSpacing := CharSpacing; + FLineSpacing := LineSpacing; +end; + +procedure TfrxDrawText.SetText(Text: TWideStrings); +var + i, j, n, Width: Integer; + s: WideString; + Style: TFontStyles; + FPPI: Extended; +begin + FCanvas.Lock; + try + FPlainText := ''; + FText.Clear; + finally + FCanvas.Unlock; + end; + + n := Text.Count; + if n = 0 then Exit; + + FCanvas.Lock; + try + // set up html engine + FHTMLTags.SetDefaults(FCanvas.Font.Color, FFontSize, FCanvas.Font.Style); + Style := FCanvas.Font.Style; + + // width of the wrap area + Width := FOriginalRect.Right - FOriginalRect.Left; + if ((FRotation >= 90) and (FRotation < 180)) or + ((FRotation >= 270) and (FRotation < 360)) then + Width := FOriginalRect.Bottom - FOriginalRect.Top; + + for i := 0 to n - 1 do + begin + j := FText.Count; + s := Text[i]; + if s = '' then + s := ' '; + FPlainText := FPlainText + s + #13#10; + FPPI := FDefPPI / FScrPPI; + WrapTextLine(s, + Round(Width * FPPI), + Round((Width - FParagraphGap) * FPPI), + Round(FCharSpacing * FPPI)); + if FText.Count <> j then + begin + FText.Objects[j] := Pointer(1); // mark the begin of paragraph: + if FText.Count - 1 = j then // it will be needed in DrawText + FText.Objects[j] := Pointer(3) else // both begin and end at one line + FText.Objects[FText.Count - 1] := Pointer(2); // mark the end of paragraph + end; + end; + + FCanvas.Font.Style := Style; + finally + FCanvas.Unlock; + end; +end; + +procedure TfrxDrawText.SetParaBreaks(FirstParaBreak, LastParaBreak: Boolean); +begin + if FText.Count = 0 then Exit; + + if FirstParaBreak then + FText.Objects[0] := Pointer(Integer(FText.Objects[0]) and not 1); + if LastParaBreak then + FText.Objects[FText.Count - 1] := Pointer(Integer(FText.Objects[FText.Count - 1]) and not 2); +end; + +function TfrxDrawText.DeleteTags(const Txt: WideString): WideString; +begin + Result := Txt; + FHTMLTags.ExpandHTMLTags(Result); +end; + +procedure TfrxDrawText.WrapTextLine(s: WideString; + Width, FirstLineWidth, CharSpacing: Integer); +var + n, i, Offset, LineBegin, LastSpace, BreakPos: Integer; + sz: TSize; + TheWord: WideString; + WasBreak: Boolean; + Tag: TfrxHTMLTag; + + function BreakWord(const s: WideString; LineBegin, CurPos, LineEnd: Integer): WideString; + var + i, BreakPos: Integer; + TheWord, Breaks: WideString; + begin + // get the whole word + i := CurPos; + while (i <= LineEnd) and (Pos(s[i], ' .,-;') = 0) do + Inc(i); + TheWord := Copy(s, LineBegin, i - LineBegin); + // get available break positions + Breaks := BreakRussianWord(AnsiUpperCase(TheWord)); + // find the closest position + BreakPos := CurPos - LineBegin; + for i := Length(Breaks) downto 1 do + if Ord(Breaks[i]) < BreakPos then + begin + BreakPos := Ord(Breaks[i]); + break; + end; + if BreakPos <> CurPos - LineBegin then + Result := Copy(TheWord, 1, BreakPos) else + Result := ''; + end; + +begin +// remove all HTML tags and build the tag list + FHTMLTags.NewLine; + FHTMLTags.ExpandHTMLTags(s); + FHTMLTags.FPosition := FHTMLTags.FPosition + 2; + + n := Length(s); + if (n < 2) or not FWordWrap then // no need to wrap a string with 0 or 1 symbol + begin + FText.Add(s); + Tag := FHTMLTags.Items[FHTMLTags.Count - 1].Items[0]; + if not Tag.Default then + Canvas.Font.Style := Tag.Style; + Exit; + end; + +// get the intercharacter spacing table and calculate the width + FCanvas.Lock; + try + sz.cx := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas, + FHTMLTags.Count - 1, CharSpacing, True, FUseDefaultCharset); + finally + FCanvas.Unlock; + end; + +// text fits, no need to wrap it + if sz.cx < FirstLineWidth then + begin + FText.Add(s); + Exit; + end; + + Offset := 0; + i := 1; + LineBegin := 1; // index of the first symbol in the current line + LastSpace := 1; // index of the last space symbol in the current line + + while i <= n do + begin + if (s[i] = ' ') then + if (FHTMLTags.AllowTags) and (FHTMLTags.Count > 0) then + begin + if (not FHTMLTags[FHTMLTags.Count - 1].Items[i - LineBegin].DontWRAP) then + LastSpace := i; + end + else + LastSpace := i; + + if FTempArray[i - 1] - Offset > FirstLineWidth then // need wrap + begin + if LastSpace = LineBegin then // there is only one word without spaces... + begin + if i <> LineBegin then // ... and it has more than 1 symbol + begin + if FWordBreak then + begin + TheWord := BreakWord(s, LineBegin, i, n); + WasBreak := TheWord <> ''; + if not WasBreak then + TheWord := Copy(s, LineBegin, i - LineBegin); + if WasBreak then + FText.Add(TheWord + '-') else + FText.Add(TheWord); + BreakPos := Length(TheWord); + FHTMLTags.Wrap(BreakPos, WasBreak); + LastSpace := LineBegin + BreakPos - 1; + end + else + begin + FText.Add(Copy(s, LineBegin, i - LineBegin)); + FHTMLTags.Wrap(i - LineBegin, False); + LastSpace := i - 1; + end; + end + else + begin + FText.Add(s[LineBegin]); // can't wrap 1 symbol, just add it to the new line + FHTMLTags.Wrap(1, False); + end; + end + else // we have a space symbol inside + begin + if FWordBreak then + begin + TheWord := BreakWord(s, LastSpace + 1, i, n); + WasBreak := TheWord <> ''; + if WasBreak then + FText.Add(Copy(s, LineBegin, LastSpace - LineBegin + 1) + TheWord + '-') else + FText.Add(Copy(s, LineBegin, LastSpace - LineBegin)); + BreakPos := LastSpace - LineBegin + Length(TheWord) + 1; + FHTMLTags.Wrap(BreakPos, WasBreak); + if WasBreak then + LastSpace := LineBegin + BreakPos - 1; + end + else + begin + FText.Add(Copy(s, LineBegin, LastSpace - LineBegin)); + FHTMLTags.Wrap(LastSpace - LineBegin + 1, False); + end; + end; + + Offset := FTempArray[LastSpace - 1]; // starting a new line + i := LastSpace; + Inc(LastSpace); + LineBegin := LastSpace; + FirstLineWidth := Width; // this line is not first, so use Width + end; + + Inc(i); + end; + + if n - LineBegin + 1 > 0 then // put the rest of line to FText + FText.Add(Copy(s, LineBegin, n - LineBegin + 1)); +end; + +procedure TfrxDrawText.DrawTextLine(C: TCanvas; const s: WideString; + X, Y, DX, LineIndex: Integer; Align: TfrxHAlign; var fh, oldfh: HFont); +var + spaceAr: PIntArray; + n, i, j, cw, neededSize, extraSize, spaceCount: Integer; + add1, add2, add3, addCount, addI : Integer; + ratio: Extended; + Sz, prnSz, PPI: Integer; + Tag: TfrxHTMLTag; + CosA, SinA: Extended; + Style: TFontStyles; + FPPI: Extended; + AnsiStr: AnsiString; + AddNext, Is2ByteCodepage: Boolean; + + function CountSpaces: Integer; + var + i: Integer; + begin + Result := 0; + for i := 0 to n - 1 do + begin + spaceAr[i] := 0; + if (s[i + 1] = ' ') or (s[i + 1] = #$A0) then + begin + Inc(Result); + spaceAr[i] := 1; + end; + end; + end; + + function CalcWidth(Index, Count: Integer): Integer; + var + i: Integer; + begin + Result := 0; + for i := Index to Index + Count - 1 do + Result := Result + FTempArray[i]; + end; + +begin + Is2ByteCodepage := False; + addI := 0; + AddNext := True; + if ((C.Font.Charset <> DEFAULT_CHARSET) and not FUseDefaultCharset) or (Win32Platform <> VER_PLATFORM_WIN32_NT) then + begin + AnsiStr := _UnicodeToAnsi(s, C.Font.Charset); + n := Length(AnsiStr); + Is2ByteCodepage := (n > Length(s)) + end + else n := Length(s); + + if n = 0 then Exit; + + spaceAr := nil; + FCanvas.Lock; + + try + Style := C.Font.Style; + FHTMLTags.FDefStyle := Style; + FCanvas.Font.Style := Style; + FPPI := FDefPPI / FScrPPI; + + PrnSz := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas, LineIndex, + Round(FCharSpacing * FPPI), False, FUseDefaultCharset) - Round(FCharSpacing * FPPI); + Sz := FHTMLTags.FillCharSpacingArray(FTempArray, s, C, LineIndex, + Round(FCharSpacing * FScaleX), False, FUseDefaultCharset) - Round(FCharSpacing * FScaleX); //!Den + C.Font.Style := Style; + if FHTMLTags.AllowTags and (FRotation <> 0) then + begin + SelectObject(C.Handle, oldfh); + DeleteObject(fh); + fh := CreateRotatedFont(C.Font, FRotation); + oldfh := SelectObject(C.Handle, fh); + end; + + PPI := GetDeviceCaps(C.Handle, LOGPIXELSX); + if PPI = 0 then + PPI := 96; + ratio := FDefPPI / PPI; + if IsPrinter(C) then + neededSize := Round(prnSz * FPrintScale / ratio) else + neededSize := Round(prnSz / (FDefPPI / 96) * FScaleX); + if not FWysiwyg then + neededSize := Sz; + extraSize := neededSize - Sz; + + CosA := Cos(pi / 180 * FRotation); + SinA := Sin(pi / 180 * FRotation); + if Align = haRight then + begin + X := x + Round((dx - neededSize + 1) * CosA); + Y := y - Round((dx - neededSize + 1) * SinA); + + Dec(X, 1); + if (fsBold in Style) or (fsItalic in Style) then + if FRotation = 0 then + Dec(X, 1); + end + else if Align = haCenter then + begin + X := x + Round((dx - neededSize) / 2 * CosA); + Y := y - Round((dx - neededSize) / 2 * SinA); + end; + + + if Align = haBlock then + begin + GetMem(spaceAr, SizeOf(Integer) * n); + spaceCount := CountSpaces; + if spaceCount = 0 then + Align := haLeft else + extraSize := Abs(dx) - Sz; + end + else + spaceCount := 0; + + if extraSize < 0 then + begin + extraSize := -extraSize; + add3 := -1; + end + else + add3 := 1; + + if Align <> haBlock then + begin + if extraSize < n then + IncArray(FTempArray, 0, n - 1, extraSize, add3) + else + begin + add1 := extraSize div n * add3; + for i := 0 to n - 1 do + Inc(FTempArray[i], add1); + IncArray(FTempArray, 0, n - 1, extraSize - add1 * n * add3, add3) + end; + end + else + begin + add1 := extraSize div spaceCount; + add2 := extraSize mod spaceCount; + addCount := 0; + for i := 0 to n - 1 do + if spaceAr[i] = 1 then + begin + Inc(FTempArray[i], add1 * add3); + if addCount <= add2 then + begin + Inc(FTempArray[i], add3); + Inc(addCount); + end; + end; + end; + + + i := 0; + Tag := FHTMLTags[LineIndex].Items[0]; + add1 := Round(Tag.AddY * Tag.Size * FScaleY); + + repeat + j := i; + while i < n do + begin + Tag := FHTMLTags[LineIndex].Items[i - addI]; + if not Tag.Default then + begin + Tag.Default := True; + break; + end; + { needs for some codepage like CHINESEBIG5_CHARSET, } + { for spec. characters it use two bytes like in UTF8, } + { but FHTMLTags works only with unicode, and we correct index here} + if Is2ByteCodepage and (Byte(AnsiStr[i + 1]) > $7F) and AddNext then + begin + Inc(addI); + AddNext := False; + end + else AddNext := True; + Inc(i); + end; + + if ((C.Font.Charset = DEFAULT_CHARSET) or FUseDefaultCharset) and (Win32Platform = VER_PLATFORM_WIN32_NT) then + if FWysiwyg then + ExtTextOutW(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA), + FOptions, @FScaledRect, PWideChar(s) + j, i - j, @FTempArray[j]) + else + ExtTextOutW(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA), + FOptions, @FScaledRect, PWideChar(s) + j, i - j, nil) + else + {AnsiStr := _UnicodeToAnsi(s, C.Font.Charset); + if C.Font.Charset = OEM_CHARSET then + AnsiStr := OemToStr(AnsiStr);} + if FWysiwyg then + ExtTextOutA(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA), + FOptions, @FScaledRect, PAnsiChar(AnsiStr) + j, i - j , @FTempArray[j]) + else + ExtTextOutA(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA), + FOptions, @FScaledRect, PAnsiChar(AnsiStr) + j, i - j, nil); + if i < n then + begin + if IsPrinter(C) then + C.Font.Height := -Round(Tag.Size * PPI * FPrintScale / 72) else + C.Font.Height := -Round(Tag.Size * FScaleY * 96 / 72); + C.Font.Style := Tag.Style; + C.Font.Color := Tag.Color; + add1 := Round(Tag.AddY * Tag.Size * FScaleY); + + cw := CalcWidth(j, i - j); + if FRotation = 0 then + X := X + cw + else + begin + X := X + Round(cw * CosA); + Y := Y - Round(cw * SinA); + + SelectObject(C.Handle, oldfh); + DeleteObject(fh); + fh := CreateRotatedFont(C.Font, FRotation); + oldfh := SelectObject(C.Handle, fh); + end; + end; + until i >= n; + + if spaceAr <> nil then + FreeMem(spaceAr, SizeOf(Integer) * n); + + finally + FCanvas.Unlock; + end; +end; + +procedure TfrxDrawText.DrawText(C: TCanvas; HAlign: TfrxHAlign; VAlign: TfrxVAlign); +var + Ar: PIntArray; + i, n, neededSize, extraSize, add1, add3: Integer; + ratio: Extended; + al: TfrxHAlign; + x, y, par: Integer; + Sz, prnSz: Integer; + Tag: TfrxHTMLTag; + fh, oldfh: HFont; + h, PPI, dx, gx: Integer; + CosA, SinA: Extended; + + procedure CalcRotatedCoords; + var + AbsCosA, AbsSinA: Extended; + dy: Integer; + begin + FRotation := (FRotation + 360) mod 360; + CosA := Cos(pi / 180 * FRotation); + SinA := Sin(pi / 180 * FRotation); + AbsCosA := Abs(CosA); + AbsSinA := Abs(SinA); + + dy := 0; + with FScaledRect do + case FRotation of + 0: + begin + x := Left; + y := Top; + dx := Right - Left; + dy := Bottom - Top; + end; + + 1..89: + begin + x := Left; + dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA); + y := Top + Round(dx * AbsSinA); + dy := Bottom - y - Round(neededsize * AbsCosA) + neededsize; + CosA := 1; SinA := 0; + end; + + 90: + begin + x := Left; + y := Bottom; + dx := Bottom - Top; + dy := Right - Left; + end; + + 91..179: + begin + y := Bottom; + dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA); + x := Left + Round(dx * AbsCosA); + dy := Bottom - Top - Round(neededsize * AbsCosA + dx * AbsSinA) + neededsize; + CosA := -1; SinA := 0; + end; + + 180: + begin + x := Right; + y := Bottom; + dx := Right - Left; + dy := Bottom - Top; + end; + + 181..269: + begin + x := Right; + dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA); + y := Bottom - Round(dx * AbsSinA); + dy := y - Top - Round(neededsize * AbsCosA) + neededsize; + CosA := -1; SinA := 0; + end; + + 270: + begin + x := Right; + y := Top; + dx := Bottom - Top; + dy := Right - Left; + end; + + 271..359: + begin + y := Top; + dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA); + x := Left + Round(neededsize * AbsSinA); + dy := Bottom - Top - Round(dx * AbsSinA + neededsize * AbsCosA) + neededsize; + CosA := 1; SinA := 0; + end; + end; + + if VAlign = vaBottom then + begin + y := y + Round(CosA * (dy - neededSize)); + x := x + Round(SinA * (dy - neededSize)); + end + else if VAlign = vaCenter then + begin + y := y + Round(CosA * (dy - neededSize) / 2); + x := x + Round(SinA * (dy - neededSize) / 2); + end; + + CosA := cos(pi / 180 * FRotation); + SinA := sin(pi / 180 * FRotation); + end; + +begin + n := FText.Count; + if (n = 0) or (FHTMLTags.Count = 0) then exit; // no text to draw + + FCanvas.Lock; + try + PPI := GetDeviceCaps(C.Handle, LOGPIXELSY); + if IsPrinter(C) then + h := -Round(FFontSize * PPI * FPrintScale / 72) else + h := -Round(FFontSize * FScaleY * 96 / 72); + C.Font := FCanvas.Font; + C.Font.Height := h; + + if FHTMLTags[0].Count > 0 then + begin + Tag := FHTMLTags[0].Items[0]; + if not Tag.Default then + begin + C.Font.Style := Tag.Style; + C.Font.Color := Tag.Color; + if IsPrinter(C) then + C.Font.Height := -Round(Tag.Size * PPI * FPrintScale / 72) else + C.Font.Height := -Round(Tag.Size * FScaleY * 96 / 72); + end; + Tag.Default := True; + end; + + fh := 0; oldfh := 0; + if FRotation <> 0 then + begin + fh := CreateRotatedFont(C.Font, FRotation); + oldfh := SelectObject(C.Handle, fh); + end; + + Sz := -C.Font.Height; + PrnSz := -FCanvas.Font.Height; + if IsPrinter(C) then + begin + ratio := FDefPPI / PPI / FPrintScale; + neededSize := Round((prnSz * n + FLineSpacing * FScaleY * ratio * n) / ratio) + end + else + begin + ratio := FDefPPI / 96; + neededSize := Round((prnSz * n + FLineSpacing * ratio * n) / ratio * FScaleY); + end; + extraSize := neededSize - (Sz * n + Round(FLineSpacing * FScaleY) * n); + + if not FWysiwyg then + extraSize := 0; + + CalcRotatedCoords; + + GetMem(Ar, SizeOf(Integer) * n); + for i := 0 to n - 2 do + Ar[i] := Round(FLineSpacing * FScaleY) + Sz; + + if extraSize < 0 then + begin + extraSize := -extraSize; + add3 := -1; + end + else + add3 := 1; + + if n > 1 then + if extraSize < n then + IncArray(Ar, 0, n - 2, extraSize, add3) + else if n > 1 then + begin + add1 := extraSize div (n - 1) * add3; + for i := 0 to n - 2 do + Inc(Ar[i], add1); + IncArray(Ar, 0, n - 2, extraSize - add1 * (n - 1) * add3, add3) + end; + + SetBkMode(C.Handle, Transparent); + + for i := 0 to n - 1 do + begin + gx := 0; + al := HAlign; + par := Integer(FText.Objects[i]); + if (par and 1) <> 0 then + if HAlign in [haLeft, haBlock] then + gx := Round(FParagraphGap * FScaleX); + if (par and 2) <> 0 then + if HAlign = haBlock then + if FRTLReading then + al := haRight else + al := haLeft; + + DrawTextLine(C, FText[i], x + gx, y, dx - gx, i, al, fh, oldfh); + Inc(y, Round(Ar[i] * CosA)); + Inc(x, Round(Ar[i] * SinA)); + end; + + FreeMem(Ar, SizeOf(Integer) * n); + + if FRotation <> 0 then + begin + SelectObject(C.Handle, oldfh); + DeleteObject(fh); + end; + + finally + FCanvas.Unlock; + end; +end; + +function TfrxDrawText.UnusedSpace: Extended; +var + PrnSz: Integer; + n: Integer; + ratio: Extended; +begin + FCanvas.Lock; + try + PrnSz := -FCanvas.Font.Height; + ratio := FDefPPI / FScrPPI; + + // number of lines that will fit in the bounds + n := Trunc((FOriginalRect.Bottom - FOriginalRect.Top + 1) / + (PrnSz / ratio + FLineSpacing)); + if n = 0 then + Result := 0 + else + begin + Result := (FOriginalRect.Bottom - FOriginalRect.Top + 1) - + (PrnSz / ratio + FLineSpacing) * n; + if Result = 0 then + Result := 1e-4; + end; + finally + FCanvas.Unlock; + end; +end; + +function TfrxDrawText.CalcHeight: Extended; +var + PrnSz: Integer; + n: Integer; + ratio: Extended; +begin + n := FText.Count; + if n = 0 then + begin + Result := 0; + Exit; + end; + FCanvas.Lock; + try + PrnSz := -FCanvas.Font.Height; + finally + FCanvas.Unlock; + end; + + ratio := FDefPPI / FScrPPI; + Result := (PrnSz / ratio + FLineSpacing) * n; + if FLineSpacing < 0 then + Result := Result - FLineSpacing +end; + +function TfrxDrawText.CalcWidth: Extended; +var + Sz, tSz: TSize; + s: WideString; + LineIndex, Ln, i, j, maxWidth, par: Integer; + ratio: Extended; + Tag: TfrxHTMLTag; + TmpStyle: TFontStyles; +begin + if FText.Count = 0 then + begin + Result := 0; + Exit; + end; + + ratio := FDefPPI / FScrPPI; + maxWidth := 0; + FCanvas.Lock; + try + for LineIndex := 0 to FText.Count - 1 do + begin + Sz.cx := 0; + s := FText[LineIndex]; + i := 0; + {search for HTML tags styles} + if (FHTMLTags.FAllowTags) and (FHTMLTags.Count <> 0) and (FHTMLTags[LineIndex].Count > 0) then + begin + TmpStyle := FCanvas.Font.Style; + Ln := FHTMLTags[LineIndex].Count; + Tag := FHTMLTags[LineIndex].Items[0]; + FCanvas.Font.Style := Tag.Style; + repeat + j := i; + while i < Ln do + begin + Tag := FHTMLTags[LineIndex].Items[i]; + if not Tag.Default then + begin + Tag.Default := True; + break; + end; + Inc(i); + end; + GetTextExtentPointW(FCanvas.Handle, PWideChar(s) + j, i - j, tSz); + FCanvas.Font.Style := Tag.Style; + Sz.cx := Sz.cx + tSz.cx; + until i >= Ln; + FCanvas.Font.Style := TmpStyle; + end + else + GetTextExtentPointW(FCanvas.Handle, PWideChar(s), Length(s), Sz); + + Inc(Sz.cx, Round(Length(s) * FCharSpacing * ratio)); + + par := Integer(FText.Objects[LineIndex]); + if (par and 1) <> 0 then + Inc(Sz.cx, Round(FParagraphGap * ratio)); + + if maxWidth < Sz.cx then + maxWidth := Sz.cx; + end; + finally + FCanvas.Unlock; + end; + + Result := maxWidth / ratio; +end; + +function TfrxDrawText.LineHeight: Extended; +var + PrnSz: Integer; + ratio: Extended; +begin + FCanvas.Lock; + try + PrnSz := -FCanvas.Font.Height; + finally + FCanvas.Unlock; + end; + ratio := FDefPPI / FScrPPI; + Result := PrnSz / ratio + FLineSpacing; +end; + +function TfrxDrawText.GetOutBoundsText(var ParaBreak: Boolean): WideString; +var + PrnSz: Integer; + n, vl, Ln: Integer; + ratio: Extended; + Tag: TfrxHTMLTags; + cl: LongInt; +begin + ParaBreak := False; + Result := ''; + n := FText.Count; + if n = 0 then Exit; + + FCanvas.Lock; + try + PrnSz := -FCanvas.Font.Height; + ratio := FDefPPI / FScrPPI; + + // number of lines that will fit in the bounds + vl := Trunc((FOriginalRect.Bottom - FOriginalRect.Top + 1) / (PrnSz / ratio + FLineSpacing)); + if vl > n then + vl := n; + + if vl < FHTMLTags.Count then + begin + // deleting all outbounds text + while FText.Count > vl do + FText.Delete(FText.Count - 1); + + if (vl > 0) and (Integer(FText.Objects[vl - 1]) in [0, 1]) then + ParaBreak := True; + + Tag := FHTMLTags[vl]; + Result := Copy(FPlainText, Tag[0].Position, Length(FPlainText) - Tag[0].Position + 1); + if ParaBreak then + if (Length(Result) > 0) and (Result[1] = ' ') then + Delete(Result, 1, 1); + Delete(FPlainText, Tag[0].Position, Length(FPlainText) - Tag[0].Position + 1); + Ln := Length(FText.Text); + if (Ln > 2) and FWordBreak and (FText.Text[Ln - 2] = '-') then + FPlainText := FPlainText + '-'; + + if FHTMLTags.AllowTags then + begin + if fsBold in Tag[0].Style then + Result := '' + Result; + if fsItalic in Tag[0].Style then + Result := '' + Result; + if fsUnderline in Tag[0].Style then + Result := '' + Result; + cl := ColorToRGB(Tag[0].Color); + cl := (cl and $00FF0000) div 65536 + (cl and $000000FF) * 65536 + (cl and $0000FF00); + Result := '' + Result; + end; + end; + finally + FCanvas.Unlock; + end; +end; + +function TfrxDrawText.GetInBoundsText: WideString; +begin + Result := FPlainText; +end; + +function TfrxDrawText.IsPrinter(C: TCanvas): Boolean; +begin + Result := C is TfrxPrinterCanvas; +end; + +procedure TfrxDrawText.Lock; +begin +// commented by Samuray +// while FLocked do +// Application.ProcessMessages; +// FLocked := True; + GraphCS.Enter; // added by Samuray +end; + +procedure TfrxDrawText.Unlock; +begin +// FLocked := False; commented by Samuray + GraphCS.Leave; // added by Samuray +end; + +function TfrxDrawText.GetWrappedText: WideString; +begin + Result := FText.Text; +end; + +function TfrxDrawText.TextHeight: Extended; +var + PrnSz: Integer; + ratio: Extended; +begin + FCanvas.Lock; + try + PrnSz := -FCanvas.Font.Height; + finally + FCanvas.Unlock; + end; + ratio := FDefPPI / FScrPPI; + Result := PrnSz / ratio; +end; + +initialization + frxDrawText := TfrxDrawText.Create; + GraphCS := TCriticalSection.Create; + +finalization + frxDrawText.Free; + GraphCS.Free; + + +end. + + + +// diff --git a/official/4.8.11/Source/frxIBO4.bpk b/official/4.8.11/Source/frxIBO4.bpk new file mode 100644 index 0000000..22710e8 --- /dev/null +++ b/official/4.8.11/Source/frxIBO4.bpk @@ -0,0 +1,190 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = frxIBO4.bpl +OBJFILES = frxRegIBO.obj frxIBO4.obj +RESFILES = frx4.res frxReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +LIBRARIES = +SPARELIBS = VCL40.lib +PACKAGES = vcl40.bpi vclsmp40.bpi fs4.bpi frx4.bpi IBO40CRT_C4.bpi IBO40FRT_C4.bpi IBO40TRT_C4.bpi IBO40VRT_C4.bpi IBO40XRT_C4.bpi + +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release;..\FastScript +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -D"FastReport 4.0 IBO Components" -aa \ + -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxIBO4.cpp b/official/4.8.11/Source/frxIBO4.cpp new file mode 100644 index 0000000..3fcbcba --- /dev/null +++ b/official/4.8.11/Source/frxIBO4.cpp @@ -0,0 +1,24 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("frx4.res"); +USEPACKAGE("vcl40.bpi"); +USEUNIT("frxRegIBO.pas"); +USERES("frxReg.dcr"); +USEPACKAGE("IBO40CRT_C4.bpi"); +USEPACKAGE("IBO40FRT_C4.bpi"); +USEPACKAGE("IBO40TRT_C4.bpi"); +USEPACKAGE("IBO40VRT_C4.bpi"); +USEPACKAGE("IBO40XRT_C4.bpi"); +USEPACKAGE("fs4.bpi"); +USEPACKAGE("frx4.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxIBO4.dpk b/official/4.8.11/Source/frxIBO4.dpk new file mode 100644 index 0000000..22ef3d8 --- /dev/null +++ b/official/4.8.11/Source/frxIBO4.dpk @@ -0,0 +1,44 @@ +// Package file for Delphi 4 + +package frxIBO4; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, + IBO40CRT_D4, + IBO40FRT_D4, + IBO40TRT_D4, + IBO40VRT_D4, + IBO40XRT_D4, + frx4, + fs4; + +contains + frxIBOSet in 'frxIBOSet.pas'; + +end. diff --git a/official/4.8.11/Source/frxIBO5.bpk b/official/4.8.11/Source/frxIBO5.bpk new file mode 100644 index 0000000..2257ae9 --- /dev/null +++ b/official/4.8.11/Source/frxIBO5.bpk @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + + \ No newline at end of file diff --git a/official/4.8.11/Source/frxIBO5.cpp b/official/4.8.11/Source/frxIBO5.cpp new file mode 100644 index 0000000..0439cc5 --- /dev/null +++ b/official/4.8.11/Source/frxIBO5.cpp @@ -0,0 +1,24 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("frx5.res"); +USEUNIT("frxRegIBO.pas"); +USERES("frxReg.dcr"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("IBO40CRT_C5.bpi"); +USEPACKAGE("IBO40FRT_C5.bpi"); +USEPACKAGE("IBO40TRT_C5.bpi"); +USEPACKAGE("IBO40VRT_C5.bpi"); +USEPACKAGE("IBO40XRT_C5.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("frx5.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxIBO5.dpk b/official/4.8.11/Source/frxIBO5.dpk new file mode 100644 index 0000000..ddc33e4 --- /dev/null +++ b/official/4.8.11/Source/frxIBO5.dpk @@ -0,0 +1,44 @@ +// Package file for Delphi 5 + +package frxIBO5; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, + IBO40CRT_D5, + IBO40FRT_D5, + IBO40TRT_D5, + IBO40VRT_D5, + IBO40XRT_D5, + frx5, + fs5; + +contains + frxIBOSet in 'frxIBOSet.pas'; + +end. diff --git a/official/4.8.11/Source/frxIBO6.bpk b/official/4.8.11/Source/frxIBO6.bpk new file mode 100644 index 0000000..e615af5 --- /dev/null +++ b/official/4.8.11/Source/frxIBO6.bpk @@ -0,0 +1,136 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\Projects;$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\Projects;$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/Source/frxIBO6.cpp b/official/4.8.11/Source/frxIBO6.cpp new file mode 100644 index 0000000..48ce892 --- /dev/null +++ b/official/4.8.11/Source/frxIBO6.cpp @@ -0,0 +1,18 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/Source/frxIBO6.dpk b/official/4.8.11/Source/frxIBO6.dpk new file mode 100644 index 0000000..fe3a07f --- /dev/null +++ b/official/4.8.11/Source/frxIBO6.dpk @@ -0,0 +1,44 @@ +// Package file for Delphi 6 + +package frxIBO6; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + IBO40CRT_D6, + IBO40FRT_D6, + IBO40TRT_D6, + IBO40VRT_D6, + IBO40XRT_D6, + frx6, + fs6; + +contains + frxIBOSet in 'frxIBOSet.pas'; + +end. diff --git a/official/4.8.11/Source/frxIBO7.dpk b/official/4.8.11/Source/frxIBO7.dpk new file mode 100644 index 0000000..aa9d09e --- /dev/null +++ b/official/4.8.11/Source/frxIBO7.dpk @@ -0,0 +1,44 @@ +// Package file for Delphi 7 + +package frxIBO7; + +{$I frx.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, + IBO40CRT_D7, + IBO40FRT_D7, + IBO40TRT_D7, + IBO40VRT_D7, + IBO40XRT_D7, + frx7, + fs7; + +contains + frxIBOSet in 'frxIBOSet.pas'; + +end. diff --git a/official/4.8.11/Source/frxIBOSet.pas b/official/4.8.11/Source/frxIBOSet.pas new file mode 100644 index 0000000..fd51c7c --- /dev/null +++ b/official/4.8.11/Source/frxIBOSet.pas @@ -0,0 +1,401 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ IBO DB dataset } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxIBOSet; + +interface + +{$I frx.inc} + +uses + SysUtils, Windows, Messages, Classes, frxClass, IB_Components, IB_Header +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TfrxIBODataset = class(TfrxCustomDBDataset) + private + FBookmark: String; + FDataSet: TIB_DataSet; + FDataSource: TIB_DataSource; + FEof: Boolean; + procedure SetDataSet(Value: TIB_DataSet); + procedure SetDataSource(Value: TIB_DataSource); + function DataSetActive: Boolean; + function IsDataSetStored: Boolean; + protected + FDS: TIB_DataSet; + function GetDisplayText(Index: String): WideString; override; + function GetDisplayWidth(Index: String): Integer; override; + function GetFieldType(Index: String): TfrxFieldType; override; + function GetValue(Index: String): Variant; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + procedure Initialize; override; + procedure Finalize; override; + procedure First; override; + procedure Next; override; + procedure Prior; override; + procedure Open; override; + procedure Close; override; + function Eof: Boolean; override; + + function GetDataSet: TIB_DataSet; + function IsBlobField(const fName: String): Boolean; override; + procedure AssignBlobTo(const fName: String; Obj: TObject); override; + procedure GetFieldList(List: TStrings); override; + published + property DataSet: TIB_DataSet read FDataSet write SetDataSet stored IsDataSetStored; + property DataSource: TIB_DataSource read FDataSource write SetDataSource stored IsDataSetStored; + end; + + +implementation + +uses frxUtils, frxRes, frxUnicodeUtils +{$IFDEF Delphi10} + , WideStrings +{$ENDIF}; + +type + EDSError = class(Exception); + + +{ TfrxIBODataset } + +procedure TfrxIBODataset.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then + if AComponent = FDataSource then + DataSource := nil + else if AComponent = FDataSet then + DataSet := nil +end; + +procedure TfrxIBODataset.SetDataSet(Value: TIB_DataSet); +begin + FDataSet := Value; + if Value <> nil then + FDataSource := nil; + FDS := GetDataSet; +end; + +procedure TfrxIBODataset.SetDataSource(Value: TIB_DataSource); +begin + FDataSource := Value; + if Value <> nil then + FDataSet := nil; + FDS := GetDataSet; +end; + +function TfrxIBODataset.DataSetActive: Boolean; +begin + Result := (FDS <> nil) and FDS.Active; +end; + +function TfrxIBODataset.GetDataset: TIB_DataSet; +begin + if FDataSet <> nil then + Result := FDataSet + else if (FDataSource <> nil) and (FDataSource.DataSet <> nil) then + Result := FDataSource.DataSet + else + Result := nil; +end; + +function TfrxIBODataset.IsDataSetStored: Boolean; +begin + Result := Report = nil; +end; + +procedure TfrxIBODataset.Initialize; +begin + if FDS = nil then + raise Exception.Create(Format(frxResources.Get('dbNotConn'), [Name])); + + FEof := False; + FInitialized := False; +end; + +procedure TfrxIBODataset.Finalize; +begin + if FDS = nil then Exit; + if FBookMark <> '' then + FDS.Bookmark := FBookmark; + FBookMark := ''; + + if CloseDataSource then + Close; + FInitialized := False; +end; + +procedure TfrxIBODataset.Open; +var + i: Integer; +begin + if FInitialized then + Exit; + + FInitialized := True; + FDS.Open; + if (RangeBegin = rbCurrent) or (RangeEnd = reCurrent) then + FBookmark := FDS.Bookmark else + FBookmark := ''; + + GetFieldList(Fields); + for i := 0 to Fields.Count - 1 do + Fields.Objects[i] := FDS.FindField(ConvertAlias(Fields[i])); + + inherited; +end; + +procedure TfrxIBODataset.Close; +begin + inherited; + + if FBookMark <> '' then + FDS.Bookmark := FBookmark; + FBookMark := ''; + + FInitialized := False; + FDS.Close; +end; + +procedure TfrxIBODataset.First; +begin + if not FInitialized then + Open; + + if RangeBegin = rbFirst then + FDS.First else + FDS.Bookmark := FBookmark; + FEof := False; + inherited First; +end; + +procedure TfrxIBODataset.Next; +begin + if not FInitialized then + Open; + + FEof := False; + if RangeEnd = reCurrent then + begin + if FDS.Bookmark = FBookmark then + FEof := True; + Exit; + end; + if not Eof then FDS.Next; + inherited Next; +end; + +procedure TfrxIBODataset.Prior; +begin + if not FInitialized then + Open; + + FDS.Prior; + inherited Prior; +end; + +function TfrxIBODataset.Eof: Boolean; +begin + if not FInitialized then + Open; + + Result := inherited Eof or FDS.Eof or FEof; + if FDS.Eof then + begin + if not FDS.Bof then + try + FDS.Prior; + except + end; + FEof := True; + end; +end; + +function TfrxIBODataset.GetDisplayText(Index: String): WideString; +var + i: Integer; +begin + if not FInitialized then + Open; + + if DataSetActive then + if Fields.Count = 0 then + Result := FDS.FieldByName(Index).DisplayText + else + begin + i := Fields.IndexOf(Index); + if i <> -1 then + Result := TIB_Column(Fields.Objects[i]).DisplayText + else + begin + Result := frxResources.Get('dbFldNotFound') + ' ' + UserName + '."' + + Index + '"'; + ReportRef.Errors.Add(ReportRef.CurObject + ': ' + Result); + end; + end + else + Result := UserName + '."' + Index + '"'; +end; + +function TfrxIBODataset.GetValue(Index: String): Variant; +var + i: Integer; + f: TIB_Column; +begin + if not FInitialized then + Open; + + i := Fields.IndexOf(Index); + if i <> -1 then + begin + f := TIB_Column(Fields.Objects[i]); + if f.IsCurrencyDataType then + Result := f.AsCurrency + else + Result := f.Value + end + else + begin + Result := Null; + ReportRef.Errors.Add(ReportRef.CurObject + ': ' + + frxResources.Get('dbFldNotFound') + ' ' + UserName + '."' + Index + '"'); + end; +end; + +function TfrxIBODataset.GetDisplayWidth(Index: String): Integer; +var + f: TIB_Column; +// fDef: TFieldDef; +begin + Result := 10; + Index := ConvertAlias(Index); + f := FDS.FindField(Index); + if f <> nil then + Result := f.DisplayWidth div 7 +{ else + begin + try + if not FDS.FieldDefs.Updated then + FDS.FieldDefs.Update; + except + end; + fDef := FDS.FieldDefs.Find(Index); + if fDef <> nil then + case fDef.DataType of + ftString: Result := fDef.Size; + ftLargeInt: Result := 15; + ftDateTime: Result := 20; + end; + end;} +end; + +function TfrxIBODataset.GetFieldType(Index: String): TfrxFieldType; +var + f: TIB_Column; +begin + Result := fftNumeric; + f := FDS.FindField(ConvertAlias(Index)); + if f <> nil then + if (f.SqlType = SQL_TEXT) or (f.SqlType = SQL_TEXT_) or + (f.SqlType = SQL_VARYING) or (f.SqlType = SQL_VARYING_) then + Result := fftString + else if f.IsBoolean then + Result := fftBoolean; +end; + +procedure TfrxIBODataset.AssignBlobTo(const fName: String; Obj: TObject); +var + Field: TIB_Column; + BlobStream: TStream; + sl: TStringList; +begin + if not FInitialized then + Open; + Field := TIB_Column(Fields.Objects[Fields.IndexOf(fName)]); + + if Obj is {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF} then + begin + BlobStream := TMemoryStream.Create; + sl := TStringList.Create; + try + Field.AssignTo(BlobStream); + BlobStream.Position := 0; + sl.LoadFromStream(BlobStream); + {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}(Obj).Assign(sl); + finally + BlobStream.Free; + sl.Free; + end; + end + else if Obj is TStream then + begin + Field.AssignTo(Obj); + TStream(Obj).Position := 0; + end; +end; + +procedure TfrxIBODataset.GetFieldList(List: TStrings); +var + i: Integer; + tempList: TStringList; +begin + List.Clear; + tempList := TStringList.Create; + + if FieldAliases.Count = 0 then + begin + if FDS <> nil then + try + FDS.Prepare; + FDS.GetFieldNamesList(tempList); + for i := 0 to tempList.Count - 1 do + List.Add(Copy(tempList[i], Pos('.', tempList[i]) + 1, 255)); + except + end; + end + else + begin + for i := 0 to FieldAliases.Count - 1 do + List.Add(FieldAliases.Values[FieldAliases.Names[i]]); + end; + + tempList.Free; +end; + +function TfrxIBODataset.IsBlobField(const fName: String): Boolean; +var + Field: TIB_Column; + i: Integer; +begin + if not FInitialized then + Open; + + Result := False; + i := Fields.IndexOf(fName); + if i <> -1 then + begin + Field := TIB_Column(Fields.Objects[i]); + Result := (Field <> nil) and (Field.SQLType >= 520) and (Field.SQLType <= 541); + end; +end; + + +end. + + +// diff --git a/official/4.8.11/Source/frxInheritError.dfm b/official/4.8.11/Source/frxInheritError.dfm new file mode 100644 index 0000000..4748d12 Binary files /dev/null and b/official/4.8.11/Source/frxInheritError.dfm differ diff --git a/official/4.8.11/Source/frxInheritError.pas b/official/4.8.11/Source/frxInheritError.pas new file mode 100644 index 0000000..d552fed --- /dev/null +++ b/official/4.8.11/Source/frxInheritError.pas @@ -0,0 +1,76 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Inherit error dialog } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxInheritError; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ImgList, ExtCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TfrxInheritErrorForm = class(TForm) + OkB: TButton; + CancelB: TButton; + MessageL: TLabel; + DeleteRB: TRadioButton; + RenameRB: TRadioButton; + PaintBox1: TPaintBox; + ImageList1: TImageList; + procedure FormCreate(Sender: TObject); + procedure PaintBox1Paint(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + +implementation + +{$R *.dfm} + +uses frxRes; + +procedure TfrxInheritErrorForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(6000); + OkB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + MessageL.Caption := frxGet(6001); + DeleteRB.Caption := frxGet(6002); + RenameRB.Caption := frxGet(6003); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxInheritErrorForm.PaintBox1Paint(Sender: TObject); +begin + with PaintBox1 do + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(Rect(0, 0, 32, 32)); + ImageList1.Draw(Canvas, 0, 0, 0); + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxInsp.dfm b/official/4.8.11/Source/frxInsp.dfm new file mode 100644 index 0000000..5e5dc0b Binary files /dev/null and b/official/4.8.11/Source/frxInsp.dfm differ diff --git a/official/4.8.11/Source/frxInsp.pas b/official/4.8.11/Source/frxInsp.pas new file mode 100644 index 0000000..8b1c491 --- /dev/null +++ b/official/4.8.11/Source/frxInsp.pas @@ -0,0 +1,1152 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Object Inspector } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxInsp; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, ExtCtrls, StdCtrls, Buttons, frxDsgnIntf, frxPopupForm, + frxClass, Menus, ComCtrls +{$IFDEF UseTabset} +, Tabs +{$ENDIF} +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxObjectInspector = class(TForm) + ObjectsCB: TComboBox; + PopupMenu1: TPopupMenu; + N11: TMenuItem; + N21: TMenuItem; + N31: TMenuItem; + BackPanel: TPanel; + Box: TScrollBox; + PB: TPaintBox; + Edit1: TEdit; + EditPanel: TPanel; + EditBtn: TSpeedButton; + ComboPanel: TPanel; + ComboBtn: TSpeedButton; + HintPanel: TScrollBox; + Splitter1: TSplitter; + PropL: TLabel; + DescrL: TLabel; + N41: TMenuItem; + N51: TMenuItem; + N61: TMenuItem; + procedure PBPaint(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure PBMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure PBMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure PBMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure Edit1KeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure Edit1KeyPress(Sender: TObject; var Key: Char); + procedure EditBtnClick(Sender: TObject); + procedure ComboBtnClick(Sender: TObject); + procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure ObjectsCBClick(Sender: TObject); + procedure ObjectsCBDrawItem(Control: TWinControl; Index: Integer; + Rect: TRect; State: TOwnerDrawState); + procedure PBDblClick(Sender: TObject); + procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure FormEndDock(Sender, Target: TObject; X, Y: Integer); + procedure ComboBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure FormShow(Sender: TObject); + procedure TabChange(Sender: TObject); + procedure N11Click(Sender: TObject); + procedure N21Click(Sender: TObject); + procedure N31Click(Sender: TObject); + procedure FormDeactivate(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + FDesigner: TfrxCustomDesigner; + FDisableDblClick: Boolean; + FDisableUpdate: Boolean; + FDown: Boolean; + FEventList: TfrxPropertyList; + FHintWindow: THintWindow; + FItemIndex: Integer; + FLastPosition: String; + FList: TfrxPropertyList; + FPopupForm: TfrxPopupForm; + FPopupLB: TListBox; + FPopupLBVisible: Boolean; + FPropertyList: TfrxPropertyList; + FPanel: TPanel; + FRowHeight: Integer; + FSelectedObjects: TList; + FSplitterPos: Integer; +{$IFDEF UseTabset} + FTabs: TTabSet; +{$ELSE} + FTabs: TTabControl; +{$ENDIF} + FTempBMP: TBitmap; + FTempList: TList; + FTickCount: UInt; + FUpdatingObjectsCB: Boolean; + FUpdatingPB: Boolean; + FOnSelectionChanged: TNotifyEvent; + FOnModify: TNotifyEvent; + + function Count: Integer; + function GetItem(Index: Integer): TfrxPropertyItem; + function GetName(Index: Integer): String; + function GetOffset(Index: Integer): Integer; + function GetType(Index: Integer): TfrxPropertyAttributes; + function GetValue(Index: Integer): String; + procedure AdjustControls; + procedure CMMouseLeave(var Msg: TMessage); message CM_MouseLeave; + procedure DrawOneLine(i: Integer; Selected: Boolean); + procedure DoModify; + procedure SetObjects(Value: TList); + procedure SetItemIndex(Value: Integer); + procedure SetSelectedObjects(Value: TList); + procedure SetValue(Index: Integer; Value: String); + procedure LBClick(Sender: TObject); + function GetSplitter1Pos: Integer; + procedure SetSplitter1Pos(const Value: Integer); + public + { Public declarations } + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure DisableUpdate; + procedure EnableUpdate; + procedure Inspect(AObjects: array of TPersistent); + procedure SetColor(Color: TColor); + procedure UpdateProperties; + property Objects: TList write SetObjects; + property ItemIndex: Integer read FItemIndex write SetItemIndex; + property SelectedObjects: TList read FSelectedObjects write SetSelectedObjects; + property SplitterPos: Integer read FSplitterPos write FSplitterPos; + property Splitter1Pos: Integer read GetSplitter1Pos write SetSplitter1Pos; + property OnModify: TNotifyEvent read FOnModify write FOnModify; + property OnSelectionChanged: TNotifyEvent read FOnSelectionChanged write FOnSelectionChanged; + end; + + +implementation + +{$R *.DFM} + +uses frxUtils, frxRes, frxrcInsp; + + +type + TInspPanel = class(TPanel) + protected + procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND; + procedure Paint; override; + end; + + THackWinControl = class(TWinControl); + + +{ TInspPanel } + +procedure TInspPanel.WMEraseBackground(var Message: TMessage); +begin +// empty method +end; + +procedure TInspPanel.Paint; +begin +// empty method +end; + + +{ TfrxObjectInspector } + +constructor TfrxObjectInspector.Create(AOwner: TComponent); +begin + if not (AOwner is TfrxCustomDesigner) then + raise Exception.Create('The Owner of the object inspector should be TfrxCustomDesigner'); + inherited Create(AOwner); + FItemIndex := -1; + FTempBMP := TBitmap.Create; + FTempList := TList.Create; + FDesigner := TfrxCustomDesigner(AOwner); + FHintWindow := THintWindow.Create(Self); + FHintWindow.Color := clInfoBk; + + FPanel := TInspPanel.Create(Self); + with FPanel do + begin + Parent := Box; + BevelInner := bvNone; + BevelOuter := bvNone; + end; + PB.Parent := FPanel; + ComboPanel.Parent := FPanel; + EditPanel.Parent := FPanel; + Edit1.Parent := FPanel; +{$IFDEF UseTabset} + Box.BevelKind := bkFlat; + HintPanel.BevelKind := bkFlat; +{$ELSE} + Box.BorderStyle := bsSingle; + HintPanel.BorderStyle := bsSingle; +{$IFDEF Delphi7} + Box.ControlStyle := Box.ControlStyle + [csNeedsBorderPaint]; + HintPanel.ControlStyle := HintPanel.ControlStyle + [csNeedsBorderPaint]; +{$ENDIF} +{$ENDIF} + + FRowHeight := Canvas.TextHeight('Wg') + 3; + with Box.VertScrollBar do + begin + Increment := FRowHeight; + Tracking := True; + end; + +{$IFDEF UseTabset} + FTabs := TTabSet.Create(Self); + FTabs.OnClick := TabChange; + FTabs.ShrinkToFit := True; + FTabs.Style := tsSoftTabs; + FTabs.TabPosition := tpTop; +{$ELSE} + FTabs := TTabControl.Create(Self); + FTabs.OnChange := TabChange; +{$ENDIF} + FTabs.Parent := Self; + FTabs.SendToBack; + FTabs.Tabs.Add(frxResources.Get('oiProp')); + FTabs.Tabs.Add(frxResources.Get('oiEvent')); + FTabs.TabIndex := 0; + + if Screen.PixelsPerInch > 96 then + ObjectsCB.ItemHeight := 19; + FSplitterPos := PB.Width div 2; + AutoScroll := False; + + FormResize(nil); + + Caption := frxGet(2000); +end; + +destructor TfrxObjectInspector.Destroy; +begin + FTempBMP.Free; + FTempList.Free; + if FPropertyList <> nil then + FPropertyList.Free; + if FEventList <> nil then + FEventList.Free; + inherited; +end; + +procedure TfrxObjectInspector.UpdateProperties; +begin + SetSelectedObjects(FSelectedObjects); +end; + +procedure TfrxObjectInspector.Inspect(AObjects: array of TPersistent); +var + i: Integer; +begin + FTempList.Clear; + for i := Low(AObjects) to High(AObjects) do + FTempList.Add(AObjects[i]); + Objects := FTempList; + SelectedObjects := FTempList; +end; + +function TfrxObjectInspector.GetSplitter1Pos: Integer; +begin + Result := HintPanel.Height; +end; + +procedure TfrxObjectInspector.SetSplitter1Pos(const Value: Integer); +begin + HintPanel.Height := Value; +end; + +procedure TfrxObjectInspector.DisableUpdate; +begin + FDisableUpdate := True; +end; + +procedure TfrxObjectInspector.EnableUpdate; +begin + FDisableUpdate := False; +end; + +procedure TfrxObjectInspector.SetColor(Color: TColor); +begin + ObjectsCB.Color := Color; + Box.Color := Color; + PB.Repaint; +end; + +procedure TfrxObjectInspector.SetObjects(Value: TList); +var + i: Integer; + s: String; +begin + ObjectsCB.Items.Clear; + for i := 0 to Value.Count - 1 do + begin + if TObject(Value[i]) is TComponent then + s := TComponent(Value[i]).Name + ': ' + TComponent(Value[i]).ClassName else + s := ''; + ObjectsCB.Items.AddObject(s, Value[i]); + end; +end; + +procedure TfrxObjectInspector.SetSelectedObjects(Value: TList); +var + i: Integer; + s: String; + + procedure CreateLists; + var + i: Integer; + p: TfrxPropertyItem; + s: String; + begin + if FPropertyList <> nil then + FPropertyList.Free; + if FEventList <> nil then + FEventList.Free; + FEventList := nil; + + FPropertyList := frxCreatePropertyList(Value, FDesigner); + if FPropertyList <> nil then + begin + FEventList := TfrxPropertyList.Create(FDesigner); + + i := 0; + while i < FPropertyList.Count do + begin + p := FPropertyList[i]; + s := String(p.Editor.PropInfo.PropType^.Name); + if (Pos('Tfrx', s) = 1) and (Pos('Event', s) = Length(s) - 4) then + p.Collection := FEventList else + Inc(i); + end; + end; + + if FTabs.TabIndex = 0 then + FList := FPropertyList else + FList := FEventList; + end; + +begin + FSelectedObjects := Value; + CreateLists; + + FUpdatingObjectsCB := True; + if FSelectedObjects.Count = 1 then + begin + ObjectsCB.ItemIndex := ObjectsCB.Items.IndexOfObject(FSelectedObjects[0]); + if ObjectsCB.ItemIndex = -1 then + begin + s := TComponent(FSelectedObjects[0]).Name + ': ' + + TComponent(FSelectedObjects[0]).ClassName; + ObjectsCB.Items.AddObject(s, FSelectedObjects[0]); + ObjectsCB.ItemIndex := ObjectsCB.Items.IndexOfObject(FSelectedObjects[0]); + end; + end + else + ObjectsCB.ItemIndex := -1; + FUpdatingObjectsCB := False; + + FItemIndex := -1; + FormResize(nil); + if Count > 0 then + begin + for i := 0 to Count - 1 do + if GetName(i) = FLastPosition then + begin + ItemIndex := i; + Exit; + end; + s := FLastPosition; + ItemIndex := 0; + FLastPosition := s; + end; +end; + +function TfrxObjectInspector.Count: Integer; + + function EnumProperties(p: TfrxPropertyList): Integer; + var + i: Integer; + begin + Result := 0; + for i := 0 to p.Count - 1 do + begin + Inc(Result); + if (p[i].SubProperty <> nil) and p[i].Expanded then + Inc(Result, EnumProperties(p[i].SubProperty)); + end; + end; + +begin + if FList <> nil then + Result := EnumProperties(FList) else + Result := 0; +end; + +function TfrxObjectInspector.GetItem(Index: Integer): TfrxPropertyItem; + + function EnumProperties(p: TfrxPropertyList; var Index: Integer): TfrxPropertyItem; + var + i: Integer; + begin + Result := nil; + for i := 0 to p.Count - 1 do + begin + Dec(Index); + if Index < 0 then + begin + Result := p[i]; + break; + end; + if (p[i].SubProperty <> nil) and p[i].Expanded then + Result := EnumProperties(p[i].SubProperty, Index); + if Index < 0 then + break; + end; + end; + +begin + if (Index >= 0) and (Index < Count) then + Result := EnumProperties(FList, Index) else + Result := nil; +end; + +function TfrxObjectInspector.GetOffset(Index: Integer): Integer; +var + p: TfrxPropertyList; +begin + Result := 0; + p := TfrxPropertyList(GetItem(Index).Collection); + while p.Parent <> nil do + begin + Inc(Result); + p := p.Parent; + end; +end; + +function TfrxObjectInspector.GetName(Index: Integer): String; +begin + Result := GetItem(Index).Editor.GetName; +end; + +function TfrxObjectInspector.GetType(Index: Integer): TfrxPropertyAttributes; +begin + Result := GetItem(Index).Editor.GetAttributes; +end; + +function TfrxObjectInspector.GetValue(Index: Integer): String; +begin + Result := GetItem(Index).Editor.Value; +end; + +procedure TfrxObjectInspector.DoModify; +var + i: Integer; +begin + if FSelectedObjects.Count = 1 then + begin + i := ObjectsCB.Items.IndexOfObject(FSelectedObjects[0]); + if TObject(FSelectedObjects[0]) is TComponent then + ObjectsCB.Items.Strings[i] := TComponent(FSelectedObjects[0]).Name + ': ' + + TComponent(FSelectedObjects[0]).ClassName; + ObjectsCB.ItemIndex := ObjectsCB.Items.IndexOfObject(FSelectedObjects[0]); + end; + + if Assigned(FOnModify) then + FOnModify(Self); +end; + +procedure TfrxObjectInspector.SetItemIndex(Value: Integer); +var + p: TfrxPropertyItem; + s: String; +begin + PropL.Caption := ''; + DescrL.Caption := ''; + if Value > Count - 1 then + Value := Count - 1; + if Value < 0 then + Value := -1; + + Edit1.Visible := Count > 0; + if Count = 0 then Exit; + + if FItemIndex <> -1 then + if Edit1.Modified then + begin + Edit1.Modified := False; + SetValue(FItemIndex, Edit1.Text); + end; + FItemIndex := Value; + + if FItemIndex <> -1 then + begin + FLastPosition := GetName(FItemIndex); + p := GetItem(FItemIndex); + s := GetName(FItemIndex); + PropL.Caption := s; + if TfrxPropertyList(p.Collection).Component <> nil then + begin + s := 'prop' + s + '.' + TfrxPropertyList(p.Collection).Component.ClassName; + if frxResources.Get(s) = s then + s := frxResources.Get('prop' + GetName(FItemIndex)) else + s := frxResources.Get(s); + DescrL.Caption := s; + end; + end; + + AdjustControls; +end; + +procedure TfrxObjectInspector.SetValue(Index: Integer; Value: String); +begin + try + GetItem(Index).Editor.Value := Value; + DoModify; + PBPaint(nil); + except + on E: Exception do + begin + frxErrorMsg(E.Message); + Edit1.Text := GetItem(Index).Editor.Value; + end; + end; +end; + +procedure TfrxObjectInspector.AdjustControls; +var + PropType: TfrxPropertyAttributes; + y, ww: Integer; +begin + if (csDocking in ControlState) or FDisableUpdate then Exit; + if FItemIndex = -1 then + begin + EditPanel.Visible := False; + ComboPanel.Visible := False; + Edit1.Visible := False; + FUpdatingPB := False; + PBPaint(nil); + Exit; + end; + + FUpdatingPB := True; + PropType := GetType(FItemIndex); + + EditPanel.Visible := paDialog in PropType; + ComboPanel.Visible := paValueList in PropType; + Edit1.ReadOnly := paReadOnly in PropType; + + ww := PB.Width - FSplitterPos - 2; + y := FItemIndex * FRowHeight + 1; + if EditPanel.Visible then + begin + EditPanel.SetBounds(PB.Width - 15, y - 1, 15, FRowHeight - 1); + EditBtn.SetBounds(0, 0, EditPanel.Width, EditPanel.Height); + Dec(ww, 15); + end; + if ComboPanel.Visible then + begin + ComboPanel.SetBounds(PB.Width - 15, y - 1, 15, FRowHeight - 1); + ComboBtn.SetBounds(0, 0, ComboPanel.Width, ComboPanel.Height); + Dec(ww, 15); + end; + + Edit1.Text := GetValue(FItemIndex); + Edit1.Modified := False; + Edit1.SetBounds(FSplitterPos + 2, y, ww, FRowHeight - 2); + Edit1.SelectAll; + + if y + FRowHeight > Box.VertScrollBar.Position + Box.ClientHeight then + Box.VertScrollBar.Position := y - Box.ClientHeight + FRowHeight; + if y < Box.VertScrollBar.Position then + Box.VertScrollBar.Position := y - 1; + + FUpdatingPB := False; + PBPaint(nil); +end; + +procedure TfrxObjectInspector.DrawOneLine(i: Integer; Selected: Boolean); +var + R: TRect; + s: String; + p: TfrxPropertyItem; + offs, add: Integer; + + procedure Line(x, y, dx, dy: Integer); + begin + FTempBMP.Canvas.MoveTo(x, y); + FTempBMP.Canvas.LineTo(x + dx, y + dy); + end; + + procedure DrawProperty; + var + x, y: Integer; + begin + x := offs + GetOffset(i) * (12 + add); + y := 1 + i * FRowHeight; + + with FTempBMP.Canvas do + begin + Pen.Color := clGray; + Brush.Color := clWhite; + + if offs < 12 then + begin + Rectangle(x + 1, y + 2 + add, x + 10, y + 11 + add); + Line(x + 3, y + 6 + add, 5, 0); + if s[1] = '+' then + Line(x + 5, y + 4 + add, 0, 5); + + s := Copy(s, 2, 255); + Inc(x, 12 + add); + end; + + Brush.Style := bsClear; + if ((s = 'Name') or (s = 'Width') or (s = 'Height') or (s = 'Left') or (s = 'Top')) + and (GetOffset(i) = 0) then + Font.Style := [fsBold]; + TextRect(R, x, y, s); + end; + end; + +begin + if Count > 0 then + with FTempBMP.Canvas do + begin + Pen.Color := clBtnShadow; + Font.Assign(Self.Font); + R := Rect(0, i * FRowHeight, FSplitterPos, i * FRowHeight + FRowHeight - 1); + + if Screen.PixelsPerInch > 96 then + add := 2 + else + add := 0; + p := GetItem(i); + s := GetName(i); + if p.SubProperty <> nil then + begin + offs := 1 + add; + if p.Expanded then + s := '-' + s else + s := '+' + s; + end + else + offs := 13 + add; + + p.Editor.ItemHeight := FRowHeight; + + if Selected then + begin + Pen.Color := clBtnFace; + Line(0, FRowHeight + -1 + i * FRowHeight, PB.Width, 0); + Brush.Color := clBtnFace; + FillRect(R); + DrawProperty; + end + else + begin + Pen.Color := clBtnFace; + Line(0, FRowHeight + -1 + i * FRowHeight, PB.Width, 0); + Pen.Color := clBtnFace; + Line(FSplitterPos - 1, 0 + i * FRowHeight, 0, FRowHeight); + DrawProperty; + Font.Color := clNavy; + if paOwnerDraw in p.Editor.GetAttributes then + p.Editor.OnDrawItem(FTempBMP.Canvas, + Rect(FSplitterPos + 2, 1 + i * FRowHeight, Width, 1 + (i + 1) * FRowHeight)) + else + TextOut(FSplitterPos + 2, 1 + i * FRowHeight, GetValue(i)); + end; + end; +end; + + +{ Form events } + +procedure TfrxObjectInspector.FormShow(Sender: TObject); +begin + AdjustControls; +end; + +procedure TfrxObjectInspector.FormResize(Sender: TObject); +var + h: Integer; +begin + if Screen.PixelsPerInch > 96 then + h := 26 + else + h := 22; + FTabs.SetBounds(0, ObjectsCB.Top + ObjectsCB.Height + 4, ClientWidth, h); +{$IFDEF UseTabset} + BackPanel.Top := FTabs.Top + FTabs.Height - 1; +{$ELSE} + BackPanel.Top := FTabs.Top + FTabs.Height - 2; +{$ENDIF} + BackPanel.Width := ClientWidth; + BackPanel.Height := ClientHeight - BackPanel.Top; + ObjectsCB.Width := ClientWidth; + + FPanel.Height := Count * FRowHeight; + FPanel.Width := Box.ClientWidth; + AdjustControls; +end; + +procedure TfrxObjectInspector.FormEndDock(Sender, Target: TObject; X, Y: Integer); +begin + FormResize(nil); +end; + +procedure TfrxObjectInspector.TabChange(Sender: TObject); +begin + if FDesigner.IsPreviewDesigner then + begin + FTabs.TabIndex := 0; + Exit; + end; + if FTabs.TabIndex = 0 then + FList := FPropertyList else +{$IFNDEF FR_VER_BASIC} + FList := FEventList; +{$ELSE} + FTabs.TabIndex := 0; +{$ENDIF} + FItemIndex := -1; + FormResize(nil); +end; + +procedure TfrxObjectInspector.N11Click(Sender: TObject); +begin + if Edit1.Visible then + Edit1.CutToClipboard; +end; + +procedure TfrxObjectInspector.N21Click(Sender: TObject); +begin + if Edit1.Visible then + Edit1.PasteFromClipboard; +end; + +procedure TfrxObjectInspector.N31Click(Sender: TObject); +begin + if Edit1.Visible then + Edit1.CopyToClipboard; +end; + +procedure TfrxObjectInspector.FormDeactivate(Sender: TObject); +begin + if FDisableUpdate then Exit; + SetItemIndex(FItemIndex); +end; + + +{ PB events } + +procedure TfrxObjectInspector.PBPaint(Sender: TObject); +var + i: Integer; + r: TRect; +begin + if FUpdatingPB then Exit; + + r := PB.BoundsRect; + FTempBMP.Width := PB.Width; + FTempBMP.Height := PB.Height; + with FTempBMP.Canvas do + begin + Brush.Color := Box.Color; + FillRect(r); + end; + + if not FDisableUpdate then + begin + for i := 0 to Count - 1 do + if i <> ItemIndex then + DrawOneLine(i, False); + if FItemIndex <> -1 then + DrawOneLine(ItemIndex, True); + end; + + PB.Canvas.Draw(0, 0, FTempBMP); +end; + +procedure TfrxObjectInspector.PBMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + p: TfrxPropertyItem; + n, x1: Integer; +begin + FDisableDblClick := False; + if Count = 0 then Exit; + if PB.Cursor = crHSplit then + FDown := True + else + begin + n := Y div FRowHeight; + + if (X > FSplitterPos) and (X < FSplitterPos + 15) and + (n >= 0) and (n < Count) then + begin + p := GetItem(n); + if p.Editor.ClassName = 'TfrxBooleanProperty' then + begin + p.Editor.Edit; + DoModify; + PBPaint(nil); + Exit; + end; + end; + + ItemIndex := n; + Edit1.SetFocus; + FTickCount := GetTickCount; + + p := GetItem(ItemIndex); + x1 := GetOffset(ItemIndex) * 12; + if (X > x1) and (X < x1 + 13) and (p.SubProperty <> nil) then + begin + p.Expanded := not p.Expanded; + FormResize(nil); + FDisableDblClick := True; + end; + end; +end; + +procedure TfrxObjectInspector.PBMouseUp(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + FDown := False; +end; + +procedure TfrxObjectInspector.PBMouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +var + n, OffsetX, MaxWidth: Integer; + s: String; + HideHint: Boolean; + + procedure ShowHint(const s: String; x, y: Integer); + var + HintRect: TRect; + p: TPoint; + begin + p := PB.ClientToScreen(Point(x - 2, y - 2)); + HintRect := FHintWindow.CalcHintRect(1000, s, nil); + OffsetRect(HintRect, p.X, p.Y); + FHintWindow.ActivateHint(HintRect, s); + HideHint := False; + end; + +begin + HideHint := True; + + if not FDown then + begin + if (X > FSplitterPos - 4) and (X < FSplitterPos + 2) then + PB.Cursor := crHSplit + else + begin + PB.Cursor := crDefault; + + { hint window } + n := Y div FRowHeight; + if (X > 12) and (n >= 0) and (n < Count) then + begin + if X <= FSplitterPos - 4 then + begin + OffsetX := (GetOffset(n) + 1) * 12; + s := GetName(n); + MaxWidth := FSplitterPos - OffsetX; + end + else + begin + OffsetX := FSplitterPos + 1; + s := GetValue(n); + MaxWidth := PB.ClientWidth - FSplitterPos; + if n = ItemIndex then + MaxWidth := 1000; + end; + + if PB.Canvas.TextWidth(s) > MaxWidth then + ShowHint(s, OffsetX, n * FRowHeight); + end; + end; + end + else + begin + if (x > 30) and (x < PB.ClientWidth - 30) then + FSplitterPos := X; + AdjustControls; + end; + + if HideHint then + FHintWindow.ReleaseHandle; +end; + +procedure TfrxObjectInspector.PBDblClick(Sender: TObject); +var + p: TfrxPropertyItem; +begin + if (Count = 0) or FDisableDblClick then Exit; + + p := GetItem(ItemIndex); + if (p <> nil) and (p.SubProperty <> nil) then + begin + p.Expanded := not p.Expanded; + FormResize(nil); + end; +end; + + +{ Edit1 events } + +procedure TfrxObjectInspector.Edit1MouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + if GetTickCount - FTickCount < GetDoubleClickTime then + EditBtnClick(nil); +end; + +procedure TfrxObjectInspector.Edit1KeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +var + i: Integer; +begin + if Count = 0 then Exit; + if Key = vk_Escape then + begin + Edit1.Perform(EM_UNDO, 0, 0); + Edit1.Modified := False; + end; + if Key = vk_Up then + begin + if ItemIndex > 0 then + ItemIndex := ItemIndex - 1; + Key := 0; + end + else if Key = vk_Down then + begin + if ItemIndex < Count - 1 then + ItemIndex := ItemIndex + 1; + Key := 0; + end + else if Key = vk_Prior then + begin + i := Box.Height div FRowHeight; + i := ItemIndex - i; + if i < 0 then + i := 0; + ItemIndex := i; + Key := 0; + end + else if Key = vk_Next then + begin + i := Box.Height div FRowHeight; + i := ItemIndex + i; + ItemIndex := i; + Key := 0; + end; +end; + +procedure TfrxObjectInspector.Edit1KeyPress(Sender: TObject; var Key: Char); +begin + if Key = #13 then + begin + if paDialog in GetType(ItemIndex) then + EditBtnClick(nil) + else + if Edit1.Modified then + begin + Edit1.Modified := False; + SetValue(ItemIndex, Edit1.Text); + end; + Edit1.SelectAll; + Key := #0; + end; +end; + + +{ EditBtn and ComboBtn events } + +procedure TfrxObjectInspector.EditBtnClick(Sender: TObject); +begin + if GetItem(ItemIndex).Editor.Edit then + begin + ItemIndex := FItemIndex; + DoModify; + end; +end; + +procedure TfrxObjectInspector.ComboBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + FPopupLBVisible := GetTickCount - frxPopupFormCloseTime < 100; +end; + +procedure TfrxObjectInspector.ComboBtnClick(Sender: TObject); +var + i, wItems, nItems: Integer; + p: TPoint; +begin + if FPopupLBVisible then + Edit1.SetFocus + else + begin + FPopupForm := TfrxPopupForm.Create(Self); + FPopupLB := TListBox.Create(FPopupForm); + with FPopupLB do + begin + Parent := FPopupForm; + Ctl3D := False; + Align := alClient; + if paOwnerDraw in GetItem(FItemIndex).Editor.GetAttributes then + Style := lbOwnerDrawFixed; + ItemHeight := FRowHeight; + OnClick := LBClick; + OnDrawItem := GetItem(FItemIndex).Editor.OnDrawLBItem; + GetItem(FItemIndex).Editor.GetValues; + Items.Assign(GetItem(FItemIndex).Editor.Values); + + if Items.Count > 0 then + begin + ItemIndex := Items.IndexOf(GetValue(FItemIndex)); + wItems := 0; + for i := 0 to Items.Count - 1 do + begin + if Canvas.TextWidth(Items[i]) > wItems then + wItems := Canvas.TextWidth(Items[i]); + end; + + Inc(wItems, 8); + if paOwnerDraw in GetItem(FItemIndex).Editor.GetAttributes then + Inc(wItems, GetItem(FItemIndex).Editor.GetExtraLBSize); + nItems := Items.Count; + if nItems > 8 then + begin + nItems := 8; + Inc(wItems, GetSystemMetrics(SM_CXVSCROLL)); + end; + + p := Edit1.ClientToScreen(Point(0, Edit1.Height)); + + if wItems < PB.Width - FSplitterPos then + FPopupForm.SetBounds(p.X - 3, p.Y, + PB.Width - FSplitterPos + 1, nItems * ItemHeight + 2) + else + FPopupForm.SetBounds(p.X + (PB.Width - FSplitterPos - wItems) - 2, p.Y, + wItems, nItems * ItemHeight + 2); + if FPopupForm.Left < 0 then + FPopupForm.Left := 0; + if FPopupForm.Top + FPopupForm.Height > Screen.Height then + FPopupForm.Top := Screen.Height - FPopupForm.Height; + FDisableUpdate := True; + FPopupForm.Show; + FDisableUpdate := False; + end; + end; + end; +end; + +procedure TfrxObjectInspector.LBClick(Sender: TObject); +begin + Edit1.Text := FPopupLB.Items[FPopupLB.ItemIndex]; + FPopupForm.Hide; + Edit1.SetFocus; + Edit1.SelectAll; + SetValue(ItemIndex, Edit1.Text); +end; + + +{ ObjectsCB events } + +procedure TfrxObjectInspector.ObjectsCBClick(Sender: TObject); +begin + if FUpdatingObjectsCB then Exit; + + FSelectedObjects.Clear; + if ObjectsCB.ItemIndex <> -1 then + FSelectedObjects.Add(ObjectsCB.Items.Objects[ObjectsCB.ItemIndex]); + SetSelectedObjects(FSelectedObjects); + Edit1.SetFocus; + if Assigned(FOnSelectionChanged) then + FOnSelectionChanged(Self); +end; + +procedure TfrxObjectInspector.ObjectsCBDrawItem(Control: TWinControl; + Index: Integer; Rect: TRect; State: TOwnerDrawState); +begin + if FDisableUpdate then exit; + with ObjectsCB.Canvas do + begin + FillRect(Rect); + if Index <> -1 then + TextOut(Rect.Left + 2, Rect.Top + 1, ObjectsCB.Items[Index]); + end; +end; + + +{ Mouse wheel } + +procedure TfrxObjectInspector.FormMouseWheelDown(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + with Box.VertScrollBar do + Position := Position + FRowHeight; +end; + +procedure TfrxObjectInspector.FormMouseWheelUp(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + with Box.VertScrollBar do + Position := Position - FRowHeight; +end; + +procedure TfrxObjectInspector.CMMouseLeave(var Msg: TMessage); +begin + FHintWindow.ReleaseHandle; + inherited; +end; + +procedure TfrxObjectInspector.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Assigned(FDesigner.OnKeyDown) then + FDesigner.OnKeyDown(Sender, Key, Shift); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxMD5.pas b/official/4.8.11/Source/frxMD5.pas new file mode 100644 index 0000000..1c16284 --- /dev/null +++ b/official/4.8.11/Source/frxMD5.pas @@ -0,0 +1,553 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ MD5 checksum generation } +{ } +{******************************************} +// Original RSA Data Security, Inc. Copyright notice +///////////////////////////////////////////////////////////////////////// +// +// Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All +// rights reserved. +// +// License to copy and use this software is granted provided that it +// is identified as the "RSA Data Security, Inc. MD5 Message-Digest +// Algorithm" in all material mentioning or referencing this software +// or this function. +// License is also granted to make and use derivative works provided +// that such works are identified as "derived from the RSA Data +// Security, Inc. MD5 Message-Digest Algorithm" in all material +// mentioning or referencing the derived work. +// RSA Data Security, Inc. makes no representations concerning either +// the merchantability of this software or the suitability of this +// software for any particular purpose. It is provided "as is" +// without express or implied warranty of any kind. +// These notices must be retained in any copies of any part of this +// documentation and/or software. + +unit frxmd5; + +{$I frx.inc} + +interface + +uses Classes; + +const +//Magic initialization constants + MD5_INIT_STATE_0 = $67452301; + MD5_INIT_STATE_1 = $efcdab89; + MD5_INIT_STATE_2 = $98badcfe; + MD5_INIT_STATE_3 = $10325476; +//Constants for Transform routine. + MD5_S11 = 7; + MD5_S12 = 12; + MD5_S13 = 17; + MD5_S14 = 22; + MD5_S21 = 5; + MD5_S22 = 9; + MD5_S23 = 14; + MD5_S24 = 20; + MD5_S31 = 4; + MD5_S32 = 11; + MD5_S33 = 16; + MD5_S34 = 23; + MD5_S41 = 6; + MD5_S42 = 10; + MD5_S43 = 15; + MD5_S44 = 21; +//Transformation Constants - Round 1 + MD5_T01 = $d76aa478; + MD5_T02 = $e8c7b756; + MD5_T03 = $242070db; + MD5_T04 = $c1bdceee; + MD5_T05 = $f57c0faf; + MD5_T06 = $4787c62a; + MD5_T07 = $a8304613; + MD5_T08 = $fd469501; + MD5_T09 = $698098d8; + MD5_T10 = $8b44f7af; + MD5_T11 = $ffff5bb1; + MD5_T12 = $895cd7be; + MD5_T13 = $6b901122; + MD5_T14 = $fd987193; + MD5_T15 = $a679438e; + MD5_T16 = $49b40821; +//Transformation Constants - Round 2 + MD5_T17 = $f61e2562; + MD5_T18 = $c040b340; + MD5_T19 = $265e5a51; + MD5_T20 = $e9b6c7aa; + MD5_T21 = $d62f105d; + MD5_T22 = $02441453; + MD5_T23 = $d8a1e681; + MD5_T24 = $e7d3fbc8; + MD5_T25 = $21e1cde6; + MD5_T26 = $c33707d6; + MD5_T27 = $f4d50d87; + MD5_T28 = $455a14ed; + MD5_T29 = $a9e3e905; + MD5_T30 = $fcefa3f8; + MD5_T31 = $676f02d9; + MD5_T32 = $8d2a4c8a; +//Transformation Constants - Round 3 + MD5_T33 = $fffa3942; + MD5_T34 = $8771f681; + MD5_T35 = $6d9d6122; + MD5_T36 = $fde5380c; + MD5_T37 = $a4beea44; + MD5_T38 = $4bdecfa9; + MD5_T39 = $f6bb4b60; + MD5_T40 = $bebfbc70; + MD5_T41 = $289b7ec6; + MD5_T42 = $eaa127fa; + MD5_T43 = $d4ef3085; + MD5_T44 = $04881d05; + MD5_T45 = $d9d4d039; + MD5_T46 = $e6db99e5; + MD5_T47 = $1fa27cf8; + MD5_T48 = $c4ac5665; +//Transformation Constants - Round 4 + MD5_T49 = $f4292244; + MD5_T50 = $432aff97; + MD5_T51 = $ab9423a7; + MD5_T52 = $fc93a039; + MD5_T53 = $655b59c3; + MD5_T54 = $8f0ccc92; + MD5_T55 = $ffeff47d; + MD5_T56 = $85845dd1; + MD5_T57 = $6fa87e4f; + MD5_T58 = $fe2ce6e0; + MD5_T59 = $a3014314; + MD5_T60 = $4e0811a1; + MD5_T61 = $f7537e82; + MD5_T62 = $bd3af235; + MD5_T63 = $2ad7d2bb; + MD5_T64 = $eb86d391; +//Null data (except for first BYTE) used to finalise the checksum calculation + PADDING: array [0..63] of byte = +( $80, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0); + + +type + uint4 = longword; + uchar = byte; + Puint4 = ^uint4; + Puchar = ^uchar; + + TfrxMD5 = class (TObject) + private + m_State: array [0..3] of uint4; + m_Count: array [0..1] of uint4; + m_Buffer: array [0..63] of uchar; + m_Digest: array [0..15] of uchar; + procedure Transform(block: Puchar); + procedure Encode(dest: Puchar; src: Puint4; nLength: uint4); + procedure Decode(dest: Puint4; src: Puchar; nLength: uint4); + function RotateLeft(x: uint4; n: uint4): uint4; + procedure FF(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); + procedure GG(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); + procedure HH(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); + procedure II(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); + public + constructor Create; + procedure Init; + procedure Update(chInput: Puchar; nInputLen: uint4); + procedure Finalize; + function Digest: Puchar; + end; + +function MD5String(szString: AnsiString): AnsiString; +function MD5File(szFilename: String): AnsiString; +function MD5Stream(Stream: TStream): AnsiString; +procedure MD5Buf(Buf: Pointer; const Len: Integer; Digest: Pointer); +function PrintMD5(md5Digest: Puchar): AnsiString; + +implementation + +uses SysUtils{$IFDEF Delphi12}, AnsiStrings{$ENDIF}; + +{$IFOPT Q+} + {$DEFINE OVERDEF} + {$Q-} +{$ENDIF} + + +function Byte2Hex(const b: byte): AnsiString; +var + H, L: Byte; + function HexChar(N : Byte) : AnsiChar; + begin + if (N < 10) then Result := AnsiChar(Chr(Ord('0') + N)) + else Result := AnsiChar(Chr(Ord('A') + (N - 10))); + end; +begin + SetLength(Result, 2); + H := (b shr 4) and $f; + L := b and $f; + Result[1] := HexChar(H); + Result[2]:= HexChar(L); +end; + +// PrintMD5: Converts a completed md5 digest into a char* string. +function PrintMD5(md5Digest: Puchar): AnsiString; +var + nCount: Integer; + tmp: Puchar; +begin + Result := ''; + tmp := md5Digest; + for nCount := 0 to 15 do + begin + Result := Result + LowerCase(Byte2Hex(Byte(tmp^))); + Inc(tmp); + end; +end; + +// MD5String: Performs the MD5 algorithm on a char* string, returning +// the results as a char*. +function MD5String(szString: AnsiString): AnsiString; +var + nLen: Integer; + alg: TfrxMD5; +begin + Result := ''; + alg := TfrxMD5.Create; + try + nLen := Length(szString); + alg.Update(Puchar(szString), nLen); + alg.Finalize; + Result := PrintMD5(alg.Digest); + finally + alg.Free; + end; +end; + +function MD5Stream(Stream: TStream): AnsiString; +var + nLen: Integer; + buf: array [0..255] of AnsiChar; + alg: TfrxMD5; + oldpos: Longint; +begin + Result := ''; + alg := TfrxMD5.Create; + oldpos := Stream.Position; + try + Stream.Position := 0; + nLen := 256; + while nLen = 256 do + begin + nLen := Stream.Read(buf, nLen); + alg.Update(@buf, nLen); + end; + alg.Finalize; + Result := PrintMD5(alg.Digest); + finally + Stream.Position := oldpos; + alg.Free; + end; +end; + +function MD5File(szFilename: String): AnsiString; +var + f: TFileStream; +begin + Result := ''; + f := TFileStream.Create(szFilename, fmOpenRead + fmShareDenyWrite); + try + Result := MD5Stream(f); + finally + f.Free + end; +end; + +procedure MD5Buf(Buf: Pointer; const Len: Integer; Digest: Pointer); +var + md5: TfrxMD5; + d: Puchar; +begin + md5 := TfrxMD5.Create; + try + md5.Update(Buf, Len); + md5.Finalize; + d := md5.Digest; + Move(d^, digest^, 16); + finally + md5.Free; + end; +end; + +{ TfrxMD5 } +constructor TfrxMD5.Create; +begin + Init; +end; + +// md5::Init +// Initializes a new context. +procedure TfrxMD5.Init; +begin + FillChar(m_Count, 2 * SizeOf(uint4), 0); + m_State[0] := MD5_INIT_STATE_0; + m_State[1] := MD5_INIT_STATE_1; + m_State[2] := MD5_INIT_STATE_2; + m_State[3] := MD5_INIT_STATE_3; +end; + +// MD5 block update operation. Continues an MD5 message-digest +// operation, processing another message block, and updating the +// context. +procedure TfrxMD5.Update(chInput: Puchar; nInputLen: uint4); +var + i, index, partLen: uint4; + tmp: Puchar; +begin + // Compute number of bytes mod 64 + index := (m_Count[0] shr 3) and $3F; + // Update number of bits + m_Count[0] := m_Count[0] + (nInputLen shl 3); + if m_Count[0] < (nInputLen shl 3) then + m_Count[1] := m_Count[1] + 1; + m_Count[1] := m_Count[1] + (nInputLen shr 29); + partLen := 64 - index; + // Transform as many times as possible. + if nInputLen >= partLen then + begin + Move(chInput^, m_Buffer[index], partLen); + Transform(Puchar(@m_Buffer)); + i := partLen; + while (i + 63) < nInputLen do + begin + tmp := chInput; + Inc(tmp, i); + Transform(tmp); + i := i + 64; + end; + index := 0; + end else + i := 0; + // Buffer remaining input + tmp := chInput; + Inc(tmp, i); + Move(tmp^, m_Buffer[index], nInputLen - i); +end; + +// MD5 finalization. Ends an MD5 message-digest operation, writing +// the message digest and zeroizing the context. +procedure TfrxMD5.Finalize; +var + bits: array [0..7] of uchar; + index, padLen: uint4; +begin + // Save number of bits + Encode(Puchar(@bits), Puint4(@m_Count), 8); + // Pad out to 56 mod 64 + index := (m_Count[0] shr 3) and $3f; + if index < 56 then + padLen := 56 - index + else + padLen := 120 - index; + Update(Puchar(@PADDING), padLen); + // Append length (before padding) + Update(Puchar(@bits), 8); + // Store state in digest + Encode(Puchar(@m_Digest), Puint4(@m_State), 16); + FillChar(m_Count, 2 * sizeof(uint4), 0); + FillChar(m_State, 4 * sizeof(uint4), 0); + FillChar(m_Buffer, 64 * sizeof(uchar), 0); +end; + +function TfrxMD5.Digest: Puchar; +begin + Result := Puchar(@m_Digest); +end; + +// MD5 basic transformation. Transforms state based on block. +procedure TfrxMD5.Transform(block: Puchar); +var + a, b, c, d: uint4; + X: array [0..15] of uint4; +begin + a := m_State[0]; + b := m_State[1]; + c := m_State[2]; + d := m_State[3]; + Decode(Puint4(@X), block, 64); + //Perform Round 1 of the transformation + FF (a, b, c, d, X[ 0], MD5_S11, MD5_T01); + FF (d, a, b, c, X[ 1], MD5_S12, MD5_T02); + FF (c, d, a, b, X[ 2], MD5_S13, MD5_T03); + FF (b, c, d, a, X[ 3], MD5_S14, MD5_T04); + FF (a, b, c, d, X[ 4], MD5_S11, MD5_T05); + FF (d, a, b, c, X[ 5], MD5_S12, MD5_T06); + FF (c, d, a, b, X[ 6], MD5_S13, MD5_T07); + FF (b, c, d, a, X[ 7], MD5_S14, MD5_T08); + FF (a, b, c, d, X[ 8], MD5_S11, MD5_T09); + FF (d, a, b, c, X[ 9], MD5_S12, MD5_T10); + FF (c, d, a, b, X[10], MD5_S13, MD5_T11); + FF (b, c, d, a, X[11], MD5_S14, MD5_T12); + FF (a, b, c, d, X[12], MD5_S11, MD5_T13); + FF (d, a, b, c, X[13], MD5_S12, MD5_T14); + FF (c, d, a, b, X[14], MD5_S13, MD5_T15); + FF (b, c, d, a, X[15], MD5_S14, MD5_T16); + //Perform Round 2 of the transformation + GG (a, b, c, d, X[ 1], MD5_S21, MD5_T17); + GG (d, a, b, c, X[ 6], MD5_S22, MD5_T18); + GG (c, d, a, b, X[11], MD5_S23, MD5_T19); + GG (b, c, d, a, X[ 0], MD5_S24, MD5_T20); + GG (a, b, c, d, X[ 5], MD5_S21, MD5_T21); + GG (d, a, b, c, X[10], MD5_S22, MD5_T22); + GG (c, d, a, b, X[15], MD5_S23, MD5_T23); + GG (b, c, d, a, X[ 4], MD5_S24, MD5_T24); + GG (a, b, c, d, X[ 9], MD5_S21, MD5_T25); + GG (d, a, b, c, X[14], MD5_S22, MD5_T26); + GG (c, d, a, b, X[ 3], MD5_S23, MD5_T27); + GG (b, c, d, a, X[ 8], MD5_S24, MD5_T28); + GG (a, b, c, d, X[13], MD5_S21, MD5_T29); + GG (d, a, b, c, X[ 2], MD5_S22, MD5_T30); + GG (c, d, a, b, X[ 7], MD5_S23, MD5_T31); + GG (b, c, d, a, X[12], MD5_S24, MD5_T32); + //Perform Round 3 of the transformation + HH (a, b, c, d, X[ 5], MD5_S31, MD5_T33); + HH (d, a, b, c, X[ 8], MD5_S32, MD5_T34); + HH (c, d, a, b, X[11], MD5_S33, MD5_T35); + HH (b, c, d, a, X[14], MD5_S34, MD5_T36); + HH (a, b, c, d, X[ 1], MD5_S31, MD5_T37); + HH (d, a, b, c, X[ 4], MD5_S32, MD5_T38); + HH (c, d, a, b, X[ 7], MD5_S33, MD5_T39); + HH (b, c, d, a, X[10], MD5_S34, MD5_T40); + HH (a, b, c, d, X[13], MD5_S31, MD5_T41); + HH (d, a, b, c, X[ 0], MD5_S32, MD5_T42); + HH (c, d, a, b, X[ 3], MD5_S33, MD5_T43); + HH (b, c, d, a, X[ 6], MD5_S34, MD5_T44); + HH (a, b, c, d, X[ 9], MD5_S31, MD5_T45); + HH (d, a, b, c, X[12], MD5_S32, MD5_T46); + HH (c, d, a, b, X[15], MD5_S33, MD5_T47); + HH (b, c, d, a, X[ 2], MD5_S34, MD5_T48); + //Perform Round 4 of the transformation + II (a, b, c, d, X[ 0], MD5_S41, MD5_T49); + II (d, a, b, c, X[ 7], MD5_S42, MD5_T50); + II (c, d, a, b, X[14], MD5_S43, MD5_T51); + II (b, c, d, a, X[ 5], MD5_S44, MD5_T52); + II (a, b, c, d, X[12], MD5_S41, MD5_T53); + II (d, a, b, c, X[ 3], MD5_S42, MD5_T54); + II (c, d, a, b, X[10], MD5_S43, MD5_T55); + II (b, c, d, a, X[ 1], MD5_S44, MD5_T56); + II (a, b, c, d, X[ 8], MD5_S41, MD5_T57); + II (d, a, b, c, X[15], MD5_S42, MD5_T58); + II (c, d, a, b, X[ 6], MD5_S43, MD5_T59); + II (b, c, d, a, X[13], MD5_S44, MD5_T60); + II (a, b, c, d, X[ 4], MD5_S41, MD5_T61); + II (d, a, b, c, X[11], MD5_S42, MD5_T62); + II (c, d, a, b, X[ 2], MD5_S43, MD5_T63); + II (b, c, d, a, X[ 9], MD5_S44, MD5_T64); + m_State[0] := m_State[0] + a; + m_State[1] := m_State[1] + b; + m_State[2] := m_State[2] + c; + m_State[3] := m_State[3] + d; + FillChar(X, sizeof(X), 0); +end; + +// Encodes input (uint4) into output (uchar). Assumes nLength is +// a multiple of 4. +procedure TfrxMD5.Encode(dest: Puchar; src: Puint4; nLength: uint4); +var + j: uint4; + tmp: Puchar; + tmp2: Puint4; +begin + j := 0; + tmp := dest; + tmp2 := src; + while j < nLength do + begin + tmp^ := uchar(tmp2^ and $ff); + Inc(tmp); + tmp^ := uchar((tmp2^ shr 8) and $ff); + Inc(tmp); + tmp^ := uchar((tmp2^ shr 16) and $ff); + Inc(tmp); + tmp^ := uchar((tmp2^ shr 24) and $ff); + Inc(tmp); + Inc(tmp2); + j := j + 4; + end; +end; + +// Decodes input (uchar) into output (uint4). Assumes nLength is +// a multiple of 4. +procedure TfrxMD5.Decode(dest: Puint4; src: Puchar; nLength: uint4); +var + j: uint4; + tmp2: Puchar; + tmp: Puint4; +begin + j := 0; + tmp := dest; + tmp2 := src; + while j < nLength do + begin + tmp^ := uint4(tmp2^); + Inc(tmp2); + tmp^ := tmp^ or uint4(tmp2^ shl 8); + Inc(tmp2); + tmp^ := tmp^ or uint4(tmp2^ shl 16); + Inc(tmp2); + tmp^ := tmp^ or uint4(tmp2^ shl 24); + Inc(tmp2); + Inc(tmp); + j := j + 4; + end; +end; + +function TfrxMD5.RotateLeft(x: uint4; n: uint4): uint4; +begin + Result := (x shl n) or (x shr (32 - n)); +end; + +procedure TfrxMD5.FF(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); +begin + a := a + ((b and c) or (not b and d)) + x + ac; + a := RotateLeft(a, s); + a := a + b; +end; + +procedure TfrxMD5.GG(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); +begin + a := a + ((b and d) or (c and (not d))) + x + ac; + a := RotateLeft(a, s); + a := a + b; +end; + +procedure TfrxMD5.HH(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); +begin + a := a + (b xor c xor d) + x + ac; + a := RotateLeft(a, s); + a := a + b; +end; + +procedure TfrxMD5.II(var a: uint4; b: uint4; c: uint4; d: uint4; x: uint4; s: uint4; ac: uint4); +begin + a := a + (c xor (b or (not d))) + x + ac; + a := RotateLeft(a, s); + a := a + b; +end; + +{$IFDEF OVERDEF} + {$UNDEF OVERDEF} + {$Q+} +{$ENDIF} + +end. + + +// diff --git a/official/4.8.11/Source/frxNewItem.dfm b/official/4.8.11/Source/frxNewItem.dfm new file mode 100644 index 0000000..8fdb63e Binary files /dev/null and b/official/4.8.11/Source/frxNewItem.dfm differ diff --git a/official/4.8.11/Source/frxNewItem.pas b/official/4.8.11/Source/frxNewItem.pas new file mode 100644 index 0000000..3278d3d --- /dev/null +++ b/official/4.8.11/Source/frxNewItem.pas @@ -0,0 +1,173 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ New item dialog } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxNewItem; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ComCtrls, StdCtrls, ImgList; + +type + TfrxNewItemForm = class(TForm) + Pages: TPageControl; + ItemsTab: TTabSheet; + OkB: TButton; + CancelB: TButton; + TemplateTab: TTabSheet; + InheritCB: TCheckBox; + TemplateLV: TListView; + ItemsLV: TListView; + procedure FormCreate(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure ItemsLVDblClick(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + FTemplates: TStringList; + public + { Public declarations } + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + + +implementation + +{$R *.DFM} + +uses frxClass, frxDesgn, frxDsgnIntf, frxUtils, frxRes; + + +constructor TfrxNewItemForm.Create(AOwner: TComponent); +begin + inherited; + FTemplates := TStringList.Create; + FTemplates.Sorted := True; +end; + +destructor TfrxNewItemForm.Destroy; +begin + FTemplates.Free; + inherited; +end; + +procedure TfrxNewItemForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(5300); + ItemsTab.Caption := frxGet(5301); + TemplateTab.Caption := frxGet(5302); + InheritCB.Caption := frxGet(5303); + OkB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + ItemsLV.LargeImages := frxResources.WizardImages; + TemplateLV.LargeImages := frxResources.WizardImages; + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxNewItemForm.FormShow(Sender: TObject); +var + i: Integer; + Item: TfrxWizardItem; + lvItem: TListItem; +begin + for i := 0 to frxWizards.Count - 1 do + begin + Item := frxWizards[i]; + if (Item.ButtonBmp <> nil) and (Item.ButtonImageIndex = -1) then + begin + frxResources.SetWizardImages(Item.ButtonBmp); + Item.ButtonImageIndex := frxResources.WizardImages.Count - 1; + end; + + lvItem := ItemsLV.Items.Add; + lvItem.Caption := Item.ClassRef.GetDescription; + lvItem.Data := Item; + lvItem.ImageIndex := Item.ButtonImageIndex; + end; + + TfrxDesignerForm(Owner).GetTemplateList(FTemplates); + for i := 0 to FTemplates.Count - 1 do + begin + lvItem := TemplateLV.Items.Add; + lvItem.Caption := ExtractFileName(FTemplates[i]); + lvItem.Data := Pointer(i); + lvItem.ImageIndex := 5; + end; +end; + +procedure TfrxNewItemForm.ItemsLVDblClick(Sender: TObject); +begin + ModalResult := mrOk; +end; + +procedure TfrxNewItemForm.FormDestroy(Sender: TObject); +var + w: TfrxCustomWizard; + Designer: TfrxDesignerForm; + Report: TfrxReport; + templ: String; +begin + if ModalResult = mrOk then + begin + if (Pages.ActivePage = ItemsTab) and (ItemsLV.Selected <> nil) then + begin + w := TfrxCustomWizard(TfrxWizardItem(ItemsLV.Selected.Data).ClassRef.NewInstance); + w.Create(Owner); + if w.Execute then + w.Designer.Modified := True; + w.Free; + end + else if (Pages.ActivePage = TemplateTab) and (TemplateLV.Selected <> nil) then + begin + Designer := TfrxDesignerForm(Owner); + Report := Designer.Report; + templ := FTemplates[Integer(TemplateLV.Selected.Data)]; + Designer.Lock; + try + Report.Clear; + if InheritCB.Checked then + Report.ParentReport := ExtractRelativePath( + Report.GetApplicationFolder, templ) + else + begin + if Assigned(Report.OnLoadTemplate) then + Report.OnLoadTemplate(Report, templ) + else + Report.LoadFromFile(templ); + end; + finally + Report.FileName := ''; + Designer.ReloadReport; + end; + end; + end; +end; + +procedure TfrxNewItemForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxOLE.pas b/official/4.8.11/Source/frxOLE.pas new file mode 100644 index 0000000..b480ca1 --- /dev/null +++ b/official/4.8.11/Source/frxOLE.pas @@ -0,0 +1,290 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ OLE object } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxOLE; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + OleCtnrs, StdCtrls, ExtCtrls, frxClass, ActiveX +{$IFDEF Delphi6} +, Variants +{$ENDIF} +{$IFDEF FR_COM} +, FastReport_TLB +{$ENDIF}; + + +type + TfrxSizeMode = (fsmClip, fsmScale); + + TfrxOLEObject = class(TComponent) // fake component + end; + +{$IFDEF FR_COM} + TfrxOLEView = class(TfrxView, IfrxOLEView) +{$ELSE} + TfrxOLEView = class(TfrxView) +{$ENDIF} + private + FOleContainer: TOleContainer; + FSizeMode: TfrxSizeMode; + FStretched: Boolean; + procedure ReadData(Stream: TStream); + procedure SetStretched(const Value: Boolean); + procedure WriteData(Stream: TStream); + protected + procedure DefineProperties(Filer: TFiler); override; +{$IFDEF FR_COM} + function Get_OleContainer(out Value: IUnknown): HResult; stdcall; + function Get_SizeMode(out Value: Integer): HResult; stdcall; + function Set_SizeMode(Value: Integer): HResult; stdcall; + function Get_Stretched(out Value: WordBool): HResult; stdcall; + function Set_Stretched(Value: WordBool): HResult; stdcall; +{$ENDIF} + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override; + procedure GetData; override; + class function GetDescription: String; override; + property OleContainer: TOleContainer read FOleContainer; + published + property BrushStyle; + property Color; + property Cursor; + property DataField; + property DataSet; + property DataSetName; + property Frame; + property SizeMode: TfrxSizeMode read FSizeMode write FSizeMode default fsmClip; + property Stretched: Boolean read FStretched write SetStretched default False; + property TagStr; + property URL; + end; + +procedure frxAssignOle(ContFrom, ContTo: TOleContainer); + + +implementation + +uses + frxOLERTTI, +{$IFNDEF NO_EDITORS} + frxOLEEditor, +{$ENDIF} + frxDsgnIntf, frxRes; + + +procedure frxAssignOle(ContFrom, ContTo: TOleContainer); +var + st: TMemoryStream; +begin + if (ContFrom = nil) or (ContFrom.OleObjectInterface = nil) then + begin + ContTo.DestroyObject; + Exit; + end; + st := TMemoryStream.Create; + ContFrom.SaveToStream(st); + st.Position := 0; + ContTo.LoadFromStream(st); + st.Free; +end; + +function HimetricToPixels(const P: TPoint): TPoint; +begin + Result.X := MulDiv(P.X, Screen.PixelsPerInch, 2540); + Result.Y := MulDiv(P.Y, Screen.PixelsPerInch, 2540); +end; + + +{ TfrxOLEView } + +constructor TfrxOLEView.Create(AOwner: TComponent); +begin + inherited; + Font.Name := 'Tahoma'; + Font.Size := 8; + + FOleContainer := TOleContainer.Create(nil); + with FOleContainer do + begin + Parent := frxParentForm; + SendMessage(frxParentForm.Handle, WM_CREATEHANDLE, Integer(FOleContainer), 0); + AllowInPlace := False; + AutoVerbMenu := False; + BorderStyle := bsNone; + SizeMode := smClip; + end; +end; + +destructor TfrxOLEView.Destroy; +begin + SendMessage(frxParentForm.Handle, WM_DESTROYHANDLE, Integer(FOleContainer), 0); + FOleContainer.Free; + inherited; +end; + +class function TfrxOLEView.GetDescription: String; +begin + Result := frxResources.Get('obOLE'); +end; + +procedure TfrxOLEView.DefineProperties(Filer: TFiler); +begin + inherited; + Filer.DefineBinaryProperty('OLE', ReadData, WriteData, + OleContainer.OleObjectInterface <> nil); +end; + +procedure TfrxOLEView.ReadData(Stream: TStream); +begin + FOleContainer.LoadFromStream(Stream); +end; + +procedure TfrxOLEView.WriteData(Stream: TStream); +begin + FOleContainer.SaveToStream(Stream); +end; + +procedure TfrxOLEView.SetStretched(const Value: Boolean); +var + VS: TPoint; +begin + FStretched := Value; + if not Stretched then + with FOleContainer do + if OleObjectInterface <> nil then + begin + Run; + VS.X := MulDiv(Width, 2540, Screen.PixelsPerInch); + VS.Y := MulDiv(Height, 2540, Screen.PixelsPerInch); + OleObjectInterface.SetExtent(DVASPECT_CONTENT, VS); + end; +end; + +procedure TfrxOLEView.Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); +var + DRect, R: TRect; + W, H: Integer; + ViewObject2: IViewObject2; + S, ViewSize: TPoint; +begin + BeginDraw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY); + DRect := Rect(FX, FY, FX1, FY1); + OleContainer.Width := FDX; + OleContainer.Height := FDY; + DrawBackground; + + if (FDX > 0) and (FDY > 0) then + with OleContainer do + if OleObjectInterface <> nil then + if Self.SizeMode = fsmClip then + OleDraw(OleObjectInterface, DVASPECT_CONTENT, Canvas.Handle, DRect) + else + begin + if Succeeded(OleObjectInterface.QueryInterface(IViewObject2, + ViewObject2)) then + begin + ViewObject2.GetExtent(DVASPECT_CONTENT, -1, nil, ViewSize); + W := DRect.Right - DRect.Left; + H := DRect.Bottom - DRect.Top; + S := HimetricToPixels(ViewSize); + if W * S.Y > H * S.X then + begin + S.X := S.X * H div S.Y; + S.Y := H; + end + else + begin + S.Y := S.Y * W div S.X; + S.X := W; + end; + + R.Left := DRect.Left + (W - S.X) div 2; + R.Top := DRect.Top + (H - S.Y) div 2; + R.Right := R.Left + S.X; + R.Bottom := R.Top + S.Y; + OleDraw(OleObjectInterface, DVASPECT_CONTENT, Canvas.Handle, R); + end + end + else + frxResources.ObjectImages.Draw(Canvas, FX + 1, FY + 2, 22); + + DrawFrame; +end; + +procedure TfrxOLEView.GetData; +var + s: TMemoryStream; +begin + inherited; + if IsDataField then + begin + s := TMemoryStream.Create; + try + DataSet.AssignBlobTo(DataField, s); + FOleContainer.LoadFromStream(s); + finally + s.Free; + end; + end; +end; + +{$IFDEF FR_COM} +function TfrxOLEView.Get_OleContainer(out Value: IUnknown): HResult; stdcall; +begin + Value := OleContainer; + Result := S_OK; +end; + +function TfrxOLEView.Get_SizeMode(out Value: Integer): HResult; stdcall; +begin + Value := Integer(SizeMode); + Result := S_OK; +end; + +function TfrxOLEView.Set_SizeMode(Value: Integer): HResult; stdcall; +begin + SizeMode := TfrxSizeMode(Value); + Result := S_OK; +end; + +function TfrxOLEView.Get_Stretched(out Value: WordBool): HResult; stdcall; +begin + Value := Stretched; + Result := S_OK; +end; + +function TfrxOLEView.Set_Stretched(Value: WordBool): HResult; stdcall; +begin + Stretched := Value; + Result := S_OK; +end; +{$ENDIF} + + +initialization + frxObjects.RegisterObject1(TfrxOLEView, nil, '', '', 0, 22); + +finalization + frxObjects.UnRegister(TfrxOLEView); + +end. + + + +// diff --git a/official/4.8.11/Source/frxOLEEditor.dfm b/official/4.8.11/Source/frxOLEEditor.dfm new file mode 100644 index 0000000..1ee2da4 Binary files /dev/null and b/official/4.8.11/Source/frxOLEEditor.dfm differ diff --git a/official/4.8.11/Source/frxOLEEditor.pas b/official/4.8.11/Source/frxOLEEditor.pas new file mode 100644 index 0000000..73ce9a2 --- /dev/null +++ b/official/4.8.11/Source/frxOLEEditor.pas @@ -0,0 +1,148 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ OLE design editor } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxOLEEditor; + +interface + +{$I frx.inc} + +uses + Windows, Classes, SysUtils, Graphics, Controls, StdCtrls, Forms, Menus, + Dialogs, frxClass, frxCustomEditors, frxDsgnIntf, frxOLE, OleCtnrs +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxOLEEditor = class(TfrxViewEditor) + public + function Edit: Boolean; override; + function HasEditor: Boolean; override; + procedure GetMenuItems; override; + function Execute(Tag: Integer; Checked: Boolean): Boolean; override; + end; + + TfrxOleEditorForm = class(TForm) + InsertB: TButton; + EditB: TButton; + CloseB: TButton; + OleContainer: TOleContainer; + procedure InsertBClick(Sender: TObject); + procedure EditBClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + public + { Public declarations } + end; + + +implementation + +{$R *.DFM} + +uses frxRes; + + +{ TfrxOLEEditor } + +function TfrxOLEEditor.HasEditor: Boolean; +begin + Result := True; +end; + +function TfrxOLEEditor.Edit: Boolean; +begin + with TfrxOleEditorForm.Create(Designer) do + begin + frxAssignOLE(TfrxOLEView(Component).OleContainer, OleContainer); + Result := ShowModal = mrOk; + if Result then + frxAssignOLE(OleContainer, TfrxOLEView(Component).OleContainer); + Free; + end; +end; + +function TfrxOLEEditor.Execute(Tag: Integer; Checked: Boolean): Boolean; +var + i: Integer; + c: TfrxComponent; + v: TfrxOLEView; +begin + Result := inherited Execute(Tag, Checked); + for i := 0 to Designer.SelectedObjects.Count - 1 do + begin + c := Designer.SelectedObjects[i]; + if (c is TfrxOLEView) and not (rfDontModify in c.Restrictions) then + begin + v := TfrxOLEView(c); + if Tag = 1 then + v.Stretched := Checked; + Result := True; + end; + end; +end; + +procedure TfrxOLEEditor.GetMenuItems; +var + v: TfrxOLEView; +begin + v := TfrxOLEView(Component); + AddItem(frxResources.Get('olStretched'), 1, v.Stretched); + inherited; +end; + + +{ TfrxOLEEditorForm } + +procedure TfrxOleEditorForm.InsertBClick(Sender: TObject); +begin + OleContainer.InsertObjectDialog; +end; + +procedure TfrxOleEditorForm.EditBClick(Sender: TObject); +begin + if OleContainer.OleObjectInterface <> nil then + OleContainer.DoVerb(ovPrimary); +end; + +procedure TfrxOleEditorForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(3400); + InsertB.Caption := frxGet(3401); + EditB.Caption := frxGet(3402); + CloseB.Caption := frxGet(3403); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + + +procedure TfrxOleEditorForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +initialization + frxComponentEditors.Register(TfrxOLEView, TfrxOLEEditor); + + +end. + + +// diff --git a/official/4.8.11/Source/frxOLERTTI.pas b/official/4.8.11/Source/frxOLERTTI.pas new file mode 100644 index 0000000..5753787 --- /dev/null +++ b/official/4.8.11/Source/frxOLERTTI.pas @@ -0,0 +1,74 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ OLE RTTI } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxOLERTTI; + +interface + +{$I frx.inc} + +implementation + +uses + Windows, Classes, SysUtils, Forms, fs_iinterpreter, frxOLE, frxClassRTTI +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TFunctions = class(TfsRTTIModule) + private + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnum('TfrxSizeMode', 'fsmClip, fsmScale'); + with AddClass(TfrxOLEView, 'TfrxView') do + AddProperty('OleContainer', 'TOleContainer', GetProp, nil); + end; +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TfrxOLEView then + begin + if PropName = 'OLECONTAINER' then + Result := Integer(TfrxOLEView(Instance).OleContainer) + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. + + +// diff --git a/official/4.8.11/Source/frxPBarcode.pas b/official/4.8.11/Source/frxPBarcode.pas new file mode 100644 index 0000000..b96fdef --- /dev/null +++ b/official/4.8.11/Source/frxPBarcode.pas @@ -0,0 +1,214 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ PSOFT Barcode Add-in object } +{ http://www.psoft.sk } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPBarcode; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Menus, EanKod, EanSpecs, frxClass, ExtCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxPBarCodeObject = class(TComponent); // fake component + + TfrxPBarCodeView = class(TfrxView) + private + FBarCode: TEan; + FExpression: String; + FText: String; + FLinesColor: TColor; + FBarType: TTypBarCode; + FRotation: Integer; + FFontAutoSize: Boolean; + FCalcCheckSum: Boolean; + FShowText: Boolean; + function GetPDF417: TpsPDF417; + function GetSecurity: Boolean; + function GetHorzLines: TBarcodeHorzLines; + function GetStartStopLine: Boolean; + function GetTrasparent: Boolean; + procedure SetPDF417(const Value: TpsPDF417); + procedure SetSecurity(const Value: Boolean); + procedure SetHorzLines(const Value: TBarcodeHorzLines); + procedure SetStartStopLines(const Value: Boolean); + procedure SetTrasparent(const Value: Boolean); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override; + procedure GetData; override; + class function GetDescription: String; override; + property BarCode: TEan read FBarCode; + published + property HorzLines: TBarcodeHorzLines read GetHorzLines write SetHorzLines; + property Security: Boolean read GetSecurity write SetSecurity; + property PDF417: TpsPDF417 read GetPDF417 write SetPDF417; + property StartStopLines: Boolean read GetStartStopLine write SetStartStopLines; + property Trasparent: Boolean read GetTrasparent write SetTrasparent; + property LinesColor: TColor read FLinesColor write FLinesColor default clBlack; + property BarType: TTypBarCode read FBarType write FBarType; + property Rotation: Integer read FRotation write FRotation; + property Font; + property FontAutoSize: Boolean read FFontAutoSize write FFontAutoSize default True; + property CalcCheckSum: Boolean read FCalcCheckSum write FCalcCheckSum default False; + property ShowText: Boolean read FShowText write FShowText default True; + property Color; + property DataField; + property DataSet; + property DataSetName; + property Expression: String read FExpression write FExpression; + property Frame; + property Text: String read FText write FText; + end; + + +implementation + +uses +{$IFNDEF NO_EDITORS} + frxPBarcodeEditor, +{$ENDIF} + frxPBarcodeRTTI, frxDsgnIntf, frxRes; + + + +{ TfrxPBarCodeView } + +constructor TfrxPBarCodeView.Create(AOwner: TComponent); +begin + inherited; + FBarCode := TEan.Create(nil); + FLinesColor := clBlack; + FFontAutoSize := True; + FShowText := True; +end; + +destructor TfrxPBarCodeView.Destroy; +begin + FBarCode.Free; + inherited Destroy; +end; + +class function TfrxPBarCodeView.GetDescription: String; +begin + Result := 'PSOFT Barcode object'; +end; + +procedure TfrxPBarCodeView.Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, + OffsetY: Extended); +begin + FBarCode.LinesColor := FLinesColor; + FBarCode.BackgroundColor := Color; + FBarCode.Transparent := Color = clNone; + + FBarCode.Angle := FRotation; + FBarCode.Font.Assign(Font); + FBarCode.FontAutoSize := FFontAutoSize; + + FBarCode.AutoCheckDigit := FCalcCheckSum; + FBarCode.TypBarCode := FBarType; + if FText <> '' then + FBarCode.BarCode := FText; + FBarcode.ShowLabels := FShowText; + + BeginDraw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY); + try + if FBarCode.CheckBarCode(FText) then FBarCode.BarCode:=FText; + PaintBarCode(Canvas, Rect(FX, FY, FX1, FY1), FBarCode); + except + on e: Exception do + Canvas.TextOut(FX,FY,FBarCode.LastPaintErrorText); + end; + DrawFrame; +end; + +procedure TfrxPBarCodeView.GetData; +begin + inherited; + if IsDataField then + FText := DataSet.Value[DataField] + else if FExpression <> '' then + FText := Report.Calc(FExpression); +end; + + +function TfrxPBarCodeView.GetPDF417: TpsPDF417; +begin + Result := FBarCode.PDF417; +end; + +procedure TfrxPBarCodeView.SetPDF417(const Value: TpsPDF417); +begin + FBarCode.PDF417 := Value; +end; + +function TfrxPBarCodeView.GetSecurity: Boolean; +begin + Result := FBarCode.Security; +end; + +procedure TfrxPBarCodeView.SetSecurity(const Value: Boolean); +begin + FBarCode.Security := Value; +end; + +function TfrxPBarCodeView.GetHorzLines: TBarcodeHorzLines; +begin + Result := FBarCode.HorzLines; +end; + +procedure TfrxPBarCodeView.SetHorzLines(const Value: TBarcodeHorzLines); +begin + FBarCode.HorzLines := Value; +end; + +function TfrxPBarCodeView.GetStartStopLine: Boolean; +begin + Result := FBarCode.StartStopLines; +end; + +procedure TfrxPBarCodeView.SetStartStopLines(const Value: Boolean); +begin + FBarCode.StartStopLines := Value; +end; + +function TfrxPBarCodeView.GetTrasparent: Boolean; +begin + Result := FBarCode.Transparent; +end; + +procedure TfrxPBarCodeView.SetTrasparent(const Value: Boolean); +begin + FBarCode.Transparent := Value; +end; + +initialization + frxObjects.RegisterObject1(TfrxPBarCodeView, nil, '', 'Other', 0, 23); + +finalization + frxObjects.UnRegister(TfrxPBarCodeView); + + +end. + + +//a925ad72a1da9d8873ffb721772811b5 + +// diff --git a/official/4.8.11/Source/frxPBarcodeEditor.dfm b/official/4.8.11/Source/frxPBarcodeEditor.dfm new file mode 100644 index 0000000..d0ccdc8 Binary files /dev/null and b/official/4.8.11/Source/frxPBarcodeEditor.dfm differ diff --git a/official/4.8.11/Source/frxPBarcodeEditor.pas b/official/4.8.11/Source/frxPBarcodeEditor.pas new file mode 100644 index 0000000..473a249 --- /dev/null +++ b/official/4.8.11/Source/frxPBarcodeEditor.pas @@ -0,0 +1,241 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ PSOFT Barcode design editor } +{ http://www.psoft.sk } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPBarcodeEditor; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Menus, ExtCtrls, Buttons, frxClass, frxPBarcode, frxCustomEditors, + EanKod, EanSpecs, frxCtrls, ComCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxPBarcodeEditor = class(TfrxViewEditor) + public + function Edit: Boolean; override; + function HasEditor: Boolean; override; + procedure GetMenuItems; override; + function Execute(Tag: Integer; Checked: Boolean): Boolean; override; + end; + + TfrxPBarcodeEditorForm = class(TForm) + CancelB: TButton; + OkB: TButton; + CodeE: TfrxComboEdit; + CodeLbl: TLabel; + TypeCB: TComboBox; + TypeLbl: TLabel; + ExampleBvl: TBevel; + ExamplePB: TPaintBox; + OptionsLbl: TGroupBox; + CalcCheckSumCB: TCheckBox; + ViewTextCB: TCheckBox; + RotationLbl: TGroupBox; + Rotation0RB: TRadioButton; + Rotation90RB: TRadioButton; + Rotation180RB: TRadioButton; + Rotation270RB: TRadioButton; + procedure ExprBtnClick(Sender: TObject); + procedure ExamplePBPaint(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + FBarcode: TfrxPBarcodeView; + public + { Public declarations } + property Barcode: TfrxPBarcodeView read FBarcode write FBarcode; + end; + + +implementation + +uses frxDsgnIntf, frxRes, frxUtils; + +{$R *.DFM} + + +{ TfrxPBarcodeEditor } + +function TfrxPBarcodeEditor.HasEditor: Boolean; +begin + Result := True; +end; + +function TfrxPBarcodeEditor.Edit: Boolean; +begin + with TfrxPBarcodeEditorForm.Create(Designer) do + begin + Barcode := TfrxPBarcodeView(Component); + Result := ShowModal = mrOk; + Free; + end; +end; + +function TfrxPBarcodeEditor.Execute(Tag: Integer; Checked: Boolean): Boolean; +var + i: Integer; + c: TfrxComponent; + v: TfrxPBarcodeView; +begin + Result := inherited Execute(Tag, Checked); + for i := 0 to Designer.SelectedObjects.Count - 1 do + begin + c := Designer.SelectedObjects[i]; + if (c is TfrxPBarcodeView) and not (rfDontModify in c.Restrictions) then + begin + v := TfrxPBarcodeView(c); + if Tag = 1 then + v.CalcCheckSum := Checked + else if Tag = 2 then + v.ShowText := Checked; + Result := True; + end; + end; +end; + +procedure TfrxPBarcodeEditor.GetMenuItems; +var + v: TfrxPBarcodeView; +begin + v := TfrxPBarcodeView(Component); + AddItem(frxResources.Get('bcCalcChecksum'), 1, v.CalcCheckSum); + AddItem(frxResources.Get('bcShowText'), 2, v.ShowText); + inherited; +end; + + +{ TfrxPBarcodeEditorForm } + +procedure TfrxPBarcodeEditorForm.FormShow(Sender: TObject); +begin + FBarcode.BarCode.AddTypesToList(TypeCB.Items, btText); + + CodeE.Text := FBarcode.Text; + TypeCB.ItemIndex := Integer(FBarcode.BarType); + CalcCheckSumCB.Checked := FBarcode.CalcCheckSum; + ViewTextCB.Checked := FBarcode.ShowText; + + case FBarcode.Rotation of + 90: Rotation90RB.Checked := True; + 180: Rotation180RB.Checked := True; + 270: Rotation270RB.Checked := True; + else Rotation0RB.Checked := True; + end; + + ExamplePBPaint(nil); +end; + +procedure TfrxPBarcodeEditorForm.FormHide(Sender: TObject); +begin + if ModalResult = mrOk then + begin + FBarcode.Text := CodeE.Text; + FBarcode.BarType := TTypBarcode(TypeCB.ItemIndex); + FBarcode.CalcCheckSum := CalcCheckSumCB.Checked; + FBarcode.ShowText := ViewTextCB.Checked; + + if Rotation90RB.Checked then + FBarcode.Rotation := 90 + else if Rotation180RB.Checked then + FBarcode.Rotation := 180 + else if Rotation270RB.Checked then + FBarcode.Rotation := 270 + else + FBarcode.Rotation := 0; + end; +end; + +procedure TfrxPBarcodeEditorForm.ExprBtnClick(Sender: TObject); +var + s: String; +begin + s := TfrxCustomDesigner(Owner).InsertExpression(CodeE.Text); + if s <> '' then + CodeE.Text := s; +end; + +procedure TfrxPBarcodeEditorForm.ExamplePBPaint(Sender: TObject); +var + Barcode: TfrxPBarcodeView; +begin + Barcode := TfrxPBarcodeView.Create(nil); + Barcode.BarType := TTypBarcode(TypeCB.ItemIndex); + if Rotation0RB.Checked then + Barcode.Rotation := 0 + else if Rotation90RB.Checked then + Barcode.Rotation := 90 + else if Rotation180RB.Checked then + Barcode.Rotation := 180 + else + Barcode.Rotation := 270; + Barcode.CalcCheckSum := CalcCheckSumCB.Checked; + Barcode.ShowText := ViewTextCB.Checked; + Barcode.SetBounds(20, 20, ExamplePB.Width - 40, 200); + + with ExamplePB.Canvas do + begin + Brush.Color := clWhite; + FillRect(Rect(0, 0, ExamplePB.Width, ExamplePB.Height)); + end; + + Barcode.Draw(ExamplePB.Canvas, 1, 1, 0, 0); + Barcode.Free; +end; + +procedure TfrxPBarcodeEditorForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(3500); + CodeLbl.Caption := frxGet(3501); + TypeLbl.Caption := frxGet(3502); + OptionsLbl.Caption := frxGet(3504); + RotationLbl.Caption := frxGet(3505); + CancelB.Caption := frxGet(2); + OkB.Caption := frxGet(1); + CalcCheckSumCB.Caption := frxGet(3506); + ViewTextCB.Caption := frxGet(3507); + Rotation0RB.Caption := frxGet(3508); + Rotation90RB.Caption := frxGet(3509); + Rotation180RB.Caption := frxGet(3510); + Rotation270RB.Caption := frxGet(3511); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + + +procedure TfrxPBarcodeEditorForm.FormKeyDown(Sender: TObject; + var Key: Word; Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +initialization + frxComponentEditors.Register(TfrxPBarcodeView, TfrxPBarcodeEditor); + + +end. + + +// diff --git a/official/4.8.11/Source/frxPBarcodeRTTI.pas b/official/4.8.11/Source/frxPBarcodeRTTI.pas new file mode 100644 index 0000000..52f68ea --- /dev/null +++ b/official/4.8.11/Source/frxPBarcodeRTTI.pas @@ -0,0 +1,65 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ PSOFT Barcode RTTI } +{ http://www.psoft.sk } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPBarcodeRTTI; + +interface + +{$I frx.inc} + +implementation + +uses + Windows, Classes, SysUtils, Forms, fs_iinterpreter, frxPBarcode, frxClassRTTI +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + + +type + TFunctions = class(TfsRTTIModule) + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddEnum('TTypBarCode', + 'bcEan8, bcEan13, bcCodabar, bcCode39Standard, bcCode39Full, bcCode93Standard, ' + + 'bcCode93Full, bcCode128, bcABCCodabar, bc25Datalogic, bc25Interleaved, ' + + 'bc25Matrix, bc25Industrial, bc25IATA, bc25Invert, bc25Coop, bcITF, bcISBN, ' + + 'bcISSN, bcISMN, bcUPCA, bcUPCE0, bcUPCE1, bcUPCShipping, bcJAN8, bcJAN13, ' + + 'bcMSIPlessey, bcPostNet, bcOPC, bcEan128, bcCode11, bcPZN, bcPDF417'); + AddClass(TfrxPBarcodeView, 'TfrxView'); + end; +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. + + +// diff --git a/official/4.8.11/Source/frxPassw.dfm b/official/4.8.11/Source/frxPassw.dfm new file mode 100644 index 0000000..c91be69 Binary files /dev/null and b/official/4.8.11/Source/frxPassw.dfm differ diff --git a/official/4.8.11/Source/frxPassw.pas b/official/4.8.11/Source/frxPassw.pas new file mode 100644 index 0000000..0307c9d --- /dev/null +++ b/official/4.8.11/Source/frxPassw.pas @@ -0,0 +1,61 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Password form } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPassw; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxPasswordForm = class(TForm) + OkB: TButton; + CancelB: TButton; + PasswordE: TEdit; + PasswordL: TLabel; + Image1: TImage; + procedure FormCreate(Sender: TObject); + private + public + end; + + +implementation + +{$R *.dfm} + +uses frxRes; + + +procedure TfrxPasswordForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(5000); + PasswordL.Caption := frxGet(5001); + OkB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPictureCache.pas b/official/4.8.11/Source/frxPictureCache.pas new file mode 100644 index 0000000..0b6a8d7 --- /dev/null +++ b/official/4.8.11/Source/frxPictureCache.pas @@ -0,0 +1,394 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Picture Cache } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPictureCache; + +interface + +{$I frx.inc} + +uses + Windows, SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, frxXML +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxCacheItem = packed record + Segment: Longint; + Offset: Longint; + end; + + PfrxCacheItem = ^TfrxCacheItem; + + TfrxCacheList = class(TObject) + private + function Get(Index: Integer): PfrxCacheItem; + protected + FItems: TList; + protected + procedure Clear; + public + constructor Create; + destructor Destroy; override; + function Add: PfrxCacheItem; + function Count: Integer; + property Items[Index: Integer]: PfrxCacheItem read Get; default; + end; + + TfrxFileStream = class(TFileStream) + private + FSz: LongWord; + public + function Seek(Offset: Longint; Origin: Word): Longint; override; +{$IFDEF Delphi6} + function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; +{$ENDIF} + end; + + TfrxMemoryStream = class(TMemoryStream) + private + FSz: LongWord; + public + function Seek(Offset: Longint; Origin: Word): Longint; override; +{$IFDEF Delphi6} + function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; +{$ENDIF} + end; + + + TfrxPictureCache = class(TObject) + private + FItems: TfrxCacheList; + FCacheStreamList: TList; + FTempFile: TStringList; + FTempDir: String; + FUseFileCache: Boolean; + procedure Add; + procedure SetTempDir(const Value: String); + procedure SetUseFileCache(const Value: Boolean); + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure AddPicture(Picture: TfrxPictureView); + procedure GetPicture(Picture: TfrxPictureView); + procedure SaveToXML(Item: TfrxXMLItem); + procedure LoadFromXML(Item: TfrxXMLItem); + procedure AddSegment; + property UseFileCache: Boolean read FUseFileCache write SetUseFileCache; + property TempDir: String read FTempDir write SetTempDir; + end; + + +implementation + + +function frxStreamToString(Stream: TStream; Size: Integer): String; +var + p: PChar; +begin + SetLength(Result, Size * 2); + GetMem(p, Size); + Stream.Read(p^, Size); + BinToHex(p, PChar(@Result[1]), Size); + FreeMem(p, Size); +end; + +procedure frxStringToStream(const s: String; Stream: TStream); +var + Size: Integer; + p: PChar; +begin + Size := Length(s) div 2; + GetMem(p, Size); + HexToBin(PChar(@s[1]), p, Size * 2); + Stream.Write(p^, Size); + FreeMem(p, Size); +end; + + +{ TfrxPictureCache } + +constructor TfrxPictureCache.Create; +begin + FItems := TfrxCacheList.Create; + FCacheStreamList := TList.Create; + FTempFile := TStringList.Create; + FUseFileCache := False; +end; + +destructor TfrxPictureCache.Destroy; +begin + Clear; + FItems.Free; + FCacheStreamList.Free; + FTempFile.Free; + inherited; +end; + +procedure TfrxPictureCache.Clear; +begin + while FCacheStreamList.Count > 0 do + begin + TObject(FCacheStreamList[0]).Free; + FCacheStreamList.Delete(0); + if FUseFileCache then + begin + DeleteFile(FTempFile[0]); + FTempFile.Delete(0); + end; + end; + FItems.Clear; +end; + +procedure TfrxPictureCache.Add; +begin + if (FCacheStreamList.Count = 0) or (TStream(FCacheStreamList[FCacheStreamList.Count - 1]).Size >= Round(MaxInt - MaxInt/6)) then + AddSegment; + + with FItems.Add^ do + begin + Segment := FCacheStreamList.Count - 1; + Offset := TStream(FCacheStreamList[FCacheStreamList.Count - 1]).Size; + TStream(FCacheStreamList[FCacheStreamList.Count - 1]).Position := Offset; + end; +end; + +procedure TfrxPictureCache.AddPicture(Picture: TfrxPictureView); +begin + if Picture.Picture.Graphic = nil then + Picture.ImageIndex := 0 + else + begin + Picture.ImageIndex := FItems.Count + 1; + Add; + Picture.Picture.Graphic.SaveToStream(TStream(FCacheStreamList[FItems[Picture.ImageIndex - 1]^.Segment])); + end; +end; + +procedure TfrxPictureCache.GetPicture(Picture: TfrxPictureView); +var + Size, Offset, Segment: Longint; + ImageIndex: Integer; + Stream: TStream; +begin + if (Picture.ImageIndex <= 0) or (Picture.ImageIndex > FItems.Count) then + Picture.Picture.Assign(nil) + else + begin + if FCacheStreamList.Count = 0 then + Exit; + ImageIndex := Picture.ImageIndex ; + Segment := Fitems[ImageIndex - 1]^.Segment; + Offset := FItems[ImageIndex - 1]^.Offset; + Stream := TStream(FCacheStreamList[Segment]); + + if (Picture.ImageIndex < FItems.Count) and (Fitems[ImageIndex]^.Segment = Segment) then + Size := FItems[ImageIndex]^.Offset - Offset + else + Size := Stream.Size - Offset; + + Stream.Position := Offset; + + if FUseFileCache then + TfrxFileStream(Stream).FSz := Offset + Size + else + TfrxMemoryStream(Stream).FSz := Offset + Size; + + Picture.LoadPictureFromStream(Stream, False); + + if FUseFileCache then + TfrxFileStream(Stream).FSz := 0 + else + TfrxMemoryStream(Stream).FSz := 0 + end; +end; + +procedure TfrxPictureCache.LoadFromXML(Item: TfrxXMLItem); +var + i: Integer; + xi: TfrxXMLItem; +begin + Clear; + for i := 0 to Item.Count - 1 do + begin + xi := Item[i]; + Add; + frxStringToStream(xi.Prop['stream'], TStream(FCacheStreamList[FCacheStreamList.Count - 1])); + end; +end; + +procedure TfrxPictureCache.SaveToXML(Item: TfrxXMLItem); +var + i, Size: Integer; + xi: TfrxXMLItem; +begin + Item.Clear; + for i := 0 to FCacheStreamList.Count - 1 do + TStream(FCacheStreamList[i]).Position := 0; + for i := 0 to FItems.Count - 1 do + begin + if (i + 1 < FItems.Count) and (Fitems[i]^.Segment = Fitems[i + 1]^.Segment) then + Size := Integer(FItems[i + 1]^.Offset) - Integer(FItems[i]^.Offset) + else + Size := TStream(FCacheStreamList[FItems[i]^.Segment]).Size - Integer(FItems[i]^.Offset); + xi := Item.Add; + xi.Name := 'item'; + xi.Text := 'stream="' + frxStreamToString(TStream(FCacheStreamList[FItems[i]^.Segment]), Size) + '"'; + end; +end; + +procedure TfrxPictureCache.SetTempDir(const Value: String); +begin + if FCacheStreamList.Count = 0 then + FTempDir := Value; +end; + +procedure TfrxPictureCache.SetUseFileCache(const Value: Boolean); +begin + if FCacheStreamList.Count = 0 then + FUseFileCache := Value; +end; + +procedure TfrxPictureCache.AddSegment; +var + Stream: TStream; +{$IFDEF Delphi12} + Path: WideString; + FileName: WideString; +{$ELSE} + Path: String[64]; + FileName: String[255]; +{$ENDIF} +begin + if FUseFileCache then + begin +{$IFDEF Delphi12} + SetLength(FileName, 255); +{$ENDIF} + Path := FTempDir; + if Path = '' then +{$IFDEF Delphi12} + begin + SetLength(Path, 255); + SetLength(Path, GetTempPath(255, @Path[1])); + end + else +{$ELSE} + Path[0] := Chr(GetTempPath(64, @Path[1])) else +{$ENDIF} + Path := Path + #0; + if (Path <> '') and (Path[Length(Path)] <> '\') then + Path := Path + '\'; + GetTempFileName(@Path[1], PChar('frPic'), 0, @FileName[1]); +{$IFDEF Delphi12} + Path := StrPas(PWideChar(@FileName[1])); +{$ELSE} + Path := StrPas(@FileName[1]); +{$ENDIF} + FTempFile.Add(String(Path)); + Stream := TfrxFileStream.Create(String(Path), fmOpenReadWrite); + TfrxFileStream(Stream).FSz := 0; + end + else + begin + Stream := TfrxMemoryStream.Create; + TfrxMemoryStream(Stream).FSz := 0; + end; + FCacheStreamList.Add(Stream); +end; + + +function TfrxMemoryStream.Seek(Offset: Integer; Origin: Word): Longint; +begin + if (FSz <> 0) and (Offset = 0) and (Origin = soFromEnd) then + Result := FSz + else + Result := inherited Seek(Offset, Origin); +end; + +{$IFDEF Delphi6} +function TfrxMemoryStream.Seek(const Offset: Int64; + Origin: TSeekOrigin): Int64; +begin + if (FSz <> 0) and (Offset = 0) and (Origin = soEnd) then + Result := FSz + else + Result := inherited Seek(Offset, Origin); +end; +{$ENDIF} + +function TfrxFileStream.Seek(Offset: Integer; Origin: Word): Longint; +begin + if (FSz <> 0) and (Offset = 0) and (Origin = soFromEnd) then + Result := FSz + else + Result := inherited Seek(Offset, Origin); +end; + +{$IFDEF Delphi6} +function TfrxFileStream.Seek(const Offset: Int64; + Origin: TSeekOrigin): Int64; +begin + if (FSz <> 0) and (Offset = 0) and (Origin = soEnd) then + Result := FSz + else + Result := inherited Seek(Offset, Origin); +end; +{$ENDIF} + +{ TfrxCacheList } + +function TfrxCacheList.Add: PfrxCacheItem; +begin + GetMem(Result, sizeof(TfrxCacheItem)); + FItems.Add(Result); +end; + +procedure TfrxCacheList.Clear; +var + idx: Integer; +begin + for idx := 0 to FItems.Count - 1 do + FreeMem(FItems[idx], sizeof(TfrxCacheItem)); + FItems.Clear; +end; + +function TfrxCacheList.Count: Integer; +begin + Result := FItems.Count; +end; + +constructor TfrxCacheList.Create; +begin + FItems := TList.Create; +end; + +destructor TfrxCacheList.Destroy; +begin + Clear; + FItems.Free; + inherited; +end; + +function TfrxCacheList.Get(Index: Integer): PfrxCacheItem; +begin + Result := PfrxCacheItem(FItems[Index]); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPopupForm.dfm b/official/4.8.11/Source/frxPopupForm.dfm new file mode 100644 index 0000000..9e8f0ac Binary files /dev/null and b/official/4.8.11/Source/frxPopupForm.dfm differ diff --git a/official/4.8.11/Source/frxPopupForm.pas b/official/4.8.11/Source/frxPopupForm.pas new file mode 100644 index 0000000..fbf4e0b --- /dev/null +++ b/official/4.8.11/Source/frxPopupForm.pas @@ -0,0 +1,61 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Parent form for pop-up controls } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPopupForm; + +interface + +{$I frx.inc} + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxPopupForm = class(TForm) + procedure FormDeactivate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + { Private declarations } + public + { Public declarations } + end; + +var + frxPopupFormCloseTime: UInt = 0; + + +implementation + +{$R *.DFM} + + +procedure TfrxPopupForm.FormDeactivate(Sender: TObject); +begin + frxPopupFormCloseTime := GetTickCount; + Close; +end; + +procedure TfrxPopupForm.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + Action := caFree; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPreview.dfm b/official/4.8.11/Source/frxPreview.dfm new file mode 100644 index 0000000..71e3ff2 Binary files /dev/null and b/official/4.8.11/Source/frxPreview.dfm differ diff --git a/official/4.8.11/Source/frxPreview.pas b/official/4.8.11/Source/frxPreview.pas new file mode 100644 index 0000000..4c49a53 --- /dev/null +++ b/official/4.8.11/Source/frxPreview.pas @@ -0,0 +1,3007 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Report preview } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPreview; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, Buttons, StdCtrls, Menus, ComCtrls, ImgList, frxCtrls, frxDock, +{$IFDEF FR_COM} + FastReport_TLB, +{$ENDIF} + ToolWin, frxPreviewPages, frxClass +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +const + WM_UPDATEZOOM = WM_USER + 1; + +type + TfrxPreview = class; + TfrxPreviewWorkspace = class; + TfrxPageList = class; + + TfrxPreviewTool = (ptHand, ptZoom); // not implemented, backw compatibility only + TfrxPageChangedEvent = procedure(Sender: TfrxPreview; PageNo: Integer) of object; + +{$IFDEF FR_COM} + TfrxPreview = class(TfrxCustomPreview, IfrxPreview) +{$ELSE} + TfrxPreview = class(TfrxCustomPreview) +{$ENDIF} + private + FAllowF3: Boolean; + FBorderStyle: TBorderStyle; + FCancelButton: TButton; + FLocked: Boolean; + FMessageLabel: TLabel; + FMessagePanel: TPanel; + FOnPageChanged: TfrxPageChangedEvent; + FOutline: TTreeView; + FOutlineColor: TColor; + FOutlinePopup: TPopupMenu; + FPageNo: Integer; + FRefreshing: Boolean; + FRunning: Boolean; + FScrollBars: TScrollStyle; + FSplitter: TSplitter; + FThumbnail: TfrxPreviewWorkspace; + FTick: Cardinal; + FTool: TfrxPreviewTool; + FWorkspace: TfrxPreviewWorkspace; + FZoom: Extended; + FZoomMode: TfrxZoomMode; + function GetActiveFrameColor: TColor; + function GetBackColor: TColor; + function GetFrameColor: TColor; + function GetOutlineVisible: Boolean; + function GetOutlineWidth: Integer; + function GetPageCount: Integer; + function GetThumbnailVisible: Boolean; + procedure EditTemplate; + procedure OnCancel(Sender: TObject); + procedure OnCollapseClick(Sender: TObject); + procedure OnExpandClick(Sender: TObject); + procedure OnMoveSplitter(Sender: TObject); + procedure OnOutlineClick(Sender: TObject); + procedure SetActiveFrameColor(const Value: TColor); + procedure SetBackColor(const Value: TColor); + procedure SetBorderStyle(Value: TBorderStyle); + procedure SetFrameColor(const Value: TColor); + procedure SetOutlineColor(const Value: TColor); + procedure SetOutlineWidth(const Value: Integer); + procedure SetOutlineVisible(const Value: Boolean); + procedure SetPageNo(Value: Integer); + procedure SetThumbnailVisible(const Value: Boolean); + procedure SetZoom(const Value: Extended); + procedure SetZoomMode(const Value: TfrxZoomMode); + procedure UpdateOutline; + procedure UpdatePages; + procedure UpdatePageNumbers; + procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND; + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure Resize; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Init; override; + procedure Lock; override; + procedure Unlock; override; + procedure RefreshReport; override; + procedure InternalOnProgressStart(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); override; + procedure InternalOnProgress(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); override; + procedure InternalOnProgressStop(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); override; + +{$IFDEF FR_COM} + function AddPage: HResult; stdcall; + function DeletePage: HResult; stdcall; + function Print: HResult; stdcall; + function Edit: HResult; stdcall; + function First: HResult; stdcall; + function Next: HResult; stdcall; + function Prior: HResult; stdcall; + function Last: HResult; stdcall; + function PageSetupDlg: HResult; stdcall; + function Find: HResult; stdcall; + function FindNext: HResult; stdcall; + function Cancel: HResult; stdcall; + function Clear: HResult; stdcall; + function SetPosition(PageN, Top: Integer): HResult; stdcall; + function ShowMessage(const s: WideString): HResult; stdcall; + function HideMessage: HResult; stdcall; + function MouseWheelScroll(Delta: Integer; Horz: WordBool; Zoom: WordBool): HResult; stdcall; + function Get_PageCount(out Value: Integer): HResult; stdcall; + function Get_PageNo(out Value: Integer): HResult; stdcall; + function Set_PageNo(Value: Integer): HResult; stdcall; + function Get_Tool(out Value: frxPreviewTool): HResult; stdcall; + function Set_Tool(Value: frxPreviewTool): HResult; stdcall; + function Get_Zoom(out Value: Double): HResult; stdcall; + function Set_Zoom(Value: Double): HResult; stdcall; + function Get_ZoomMode(out Value: frxZoomMode): HResult; stdcall; + function Set_ZoomMode(Value: frxZoomMode): HResult; stdcall; + function Get_OutlineVisible(out Value: WordBool): HResult; stdcall; + function Set_OutlineVisible(Value: WordBool): HResult; stdcall; + function Get_OutlineWidth(out Value: Integer): HResult; stdcall; + function Set_OutlineWidth(Value: Integer): HResult; stdcall; + function Get_Enabled(out Value: WordBool): HResult; stdcall; + function Set_Enabled(Value: WordBool): HResult; stdcall; + function LoadPreparedReportFromFile(const FileName: WideString): HResult; stdcall; + function SavePreparedReportToFile(const FileName: WideString): HResult; stdcall; + function Get_FullScreen(out Value: WordBool): HResult; stdcall; + function Set_FullScreen(Value: WordBool): HResult; stdcall; + function Get_ToolBarVisible(out Value: WordBool): HResult; stdcall; + function Set_ToolBarVisible(Value: WordBool): HResult; stdcall; + function Get_StatusBarVisible(out Value: WordBool): HResult; stdcall; + function Set_StatusBarVisible(Value: WordBool): HResult; stdcall; +{$ELSE} + procedure AddPage; + procedure DeletePage; + procedure Print; + procedure Edit; + procedure First; + procedure Next; + procedure Prior; + procedure Last; + procedure PageSetupDlg; + procedure Find; + procedure FindNext; + procedure Cancel; + procedure Clear; + procedure SetPosition(PageN, Top: Integer); + procedure ShowMessage(const s: String); + procedure HideMessage; + procedure MouseWheelScroll(Delta: Integer; Horz: Boolean = False; + Zoom: Boolean = False); +{$ENDIF} + function GetTopPosition: Integer; + procedure LoadFromFile; overload; + procedure LoadFromFile(FileName: String); overload; + procedure SaveToFile; overload; + procedure SaveToFile(FileName: String); overload; + procedure Export(Filter: TfrxCustomExportFilter); + function FindText(SearchString: String; FromTop, IsCaseSensitive: Boolean): Boolean; + function FindTextFound: Boolean; + procedure FindTextClear; + + property PageCount: Integer read GetPageCount; + property PageNo: Integer read FPageNo write SetPageNo; + // not implemented, backw compatibility only + property Tool: TfrxPreviewTool read FTool write FTool; + property Zoom: Extended read FZoom write SetZoom; + property ZoomMode: TfrxZoomMode read FZoomMode write SetZoomMode; + property Locked: Boolean read FLocked; + property OutlineTree: TTreeView read FOutline; + property Splitter: TSplitter read FSplitter; + property Thumbnail: TfrxPreviewWorkspace read FThumbnail; + property Workspace: TfrxPreviewWorkspace read FWorkspace; + published + property Align; + property ActiveFrameColor: TColor read GetActiveFrameColor write SetActiveFrameColor default $804020; + property BackColor: TColor read GetBackColor write SetBackColor default clGray; + property BevelEdges; + property BevelInner; + property BevelKind; + property BevelOuter; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; + property BorderWidth; + property FrameColor: TColor read GetFrameColor write SetFrameColor default clBlack; + property OutlineColor: TColor read FOutlineColor write SetOutlineColor default clWindow; + property OutlineVisible: Boolean read GetOutlineVisible write SetOutlineVisible; + property OutlineWidth: Integer read GetOutlineWidth write SetOutlineWidth; + property PopupMenu; + property ThumbnailVisible: Boolean read GetThumbnailVisible write SetThumbnailVisible; + property OnClick; + property OnDblClick; + property OnPageChanged: TfrxPageChangedEvent read FOnPageChanged write FOnPageChanged; + property Anchors; + property UseReportHints; + end; + + TfrxPreviewForm = class(TForm) + ToolBar: TToolBar; + OpenB: TToolButton; + SaveB: TToolButton; + PrintB: TToolButton; + ExportB: TToolButton; + FindB: TToolButton; + PageSettingsB: TToolButton; + Sep3: TfrxTBPanel; + ZoomCB: TfrxComboBox; + Sep1: TToolButton; + Sep2: TToolButton; + FirstB: TToolButton; + PriorB: TToolButton; + Sep4: TfrxTBPanel; + PageE: TEdit; + NextB: TToolButton; + LastB: TToolButton; + StatusBar: TStatusBar; + ZoomMinusB: TToolButton; + Sep5: TToolButton; + ZoomPlusB: TToolButton; + DesignerB: TToolButton; + frTBPanel1: TfrxTBPanel; + CancelB: TSpeedButton; + ExportPopup: TPopupMenu; + HiddenMenu: TPopupMenu; + Showtemplate1: TMenuItem; + RightMenu: TPopupMenu; + FullScreenBtn: TToolButton; + EmailB: TToolButton; + PdfB: TToolButton; + OutlineB: TToolButton; + ThumbB: TToolButton; + N1: TMenuItem; + ExpandMI: TMenuItem; + CollapseMI: TMenuItem; + procedure FormCreate(Sender: TObject); + procedure ZoomMinusBClick(Sender: TObject); + procedure ZoomCBClick(Sender: TObject); + procedure FormKeyPress(Sender: TObject; var Key: Char); + procedure FirstBClick(Sender: TObject); + procedure PriorBClick(Sender: TObject); + procedure NextBClick(Sender: TObject); + procedure LastBClick(Sender: TObject); + procedure PageEClick(Sender: TObject); + procedure PrintBClick(Sender: TObject); + procedure OpenBClick(Sender: TObject); + procedure SaveBClick(Sender: TObject); + procedure FindBClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure DesignerBClick(Sender: TObject); + procedure NewPageBClick(Sender: TObject); + procedure DelPageBClick(Sender: TObject); + procedure CancelBClick(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure PageSettingsBClick(Sender: TObject); + procedure FormMouseWheel(Sender: TObject; Shift: TShiftState; + WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); + procedure DesignerBMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Showtemplate1Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure FullScreenBtnClick(Sender: TObject); + procedure PdfBClick(Sender: TObject); + procedure EmailBClick(Sender: TObject); + procedure ZoomPlusBClick(Sender: TObject); + procedure OutlineBClick(Sender: TObject); + procedure ThumbBClick(Sender: TObject); + procedure CollapseAllClick(Sender: TObject); + procedure ExpandAllClick(Sender: TObject); + procedure FormResize(Sender: TObject); + private + FFreeOnClose: Boolean; + FPreview: TfrxPreview; + FOldBS: TFormBorderStyle; + FOldState: TWindowState; + FFullScreen: Boolean; + FPDFExport: TfrxCustomExportFilter; + FEmailExport: TfrxCustomExportFilter; + FStatusBarOldWindowProc: TWndMethod; + procedure ExportMIClick(Sender: TObject); + procedure OnPageChanged(Sender: TfrxPreview; PageNo: Integer); + procedure OnPreviewDblClick(Sender: TObject); + procedure UpdateControls; + procedure UpdateZoom; + procedure WMUpdateZoom(var Message: TMessage); message WM_UPDATEZOOM; + procedure WMActivateApp(var Msg: TWMActivateApp); message WM_ACTIVATEAPP; + procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; + procedure StatusBarWndProc(var Message: TMessage); + function GetReport: TfrxReport; + public + procedure Init; + procedure SetMessageText(const Value: String; IsHint: Boolean = False); + procedure SwitchToFullScreen; + property FreeOnClose: Boolean read FFreeOnClose write FFreeOnClose; + property Preview: TfrxPreview read FPreview; + property Report: TfrxReport read GetReport; + end; + + TfrxPreviewWorkspace = class(TfrxScrollWin) + private + FActiveFrameColor: TColor; + FBackColor: TColor; + FDefaultCursor: TCursor; + FDisableUpdate: Boolean; + FDown: Boolean; + FEMFImage: TMetafile; + FEMFImagePage: Integer; + FFrameColor: TColor; + FIsThumbnail: Boolean; + FLastFoundPage: Integer; + FLastPoint: TPoint; + FLocked: Boolean; + FOffset: TPoint; + FTimeOffset: Cardinal; + FPageList: TfrxPageList; + FPageNo: Integer; + FPreview: TfrxPreview; + FPreviewPages: TfrxCustomPreviewPages; + FZoom: Extended; + FRTLLanguage: Boolean; + procedure DrawPages(BorderOnly: Boolean); + procedure FindText; + procedure SetToPageNo(PageNo: Integer); + procedure UpdateScrollBars; + protected + procedure PrevDblClick(Sender: TObject); + procedure MouseDown(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure OnHScrollChange(Sender: TObject); override; + procedure Resize; override; + procedure OnVScrollChange(Sender: TObject); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Paint; override; + procedure SetPosition(PageN, Top: Integer); + function GetTopPosition: Integer; + { page list } + procedure AddPage(AWidth, AHeight: Integer); + procedure ClearPageList; + procedure CalcPageBounds(ClientWidth: Integer); + + property ActiveFrameColor: TColor read FActiveFrameColor write FActiveFrameColor default $804020; + property BackColor: TColor read FBackColor write FBackColor default clGray; + property FrameColor: TColor read FFrameColor write FFrameColor default clBlack; + property IsThumbnail: Boolean read FIsThumbnail write FIsThumbnail; + property Locked: Boolean read FLocked write FLocked; + property PageNo: Integer read FPageNo write FPageNo; + property Preview: TfrxPreview read FPreview write FPreview; + property PreviewPages: TfrxCustomPreviewPages read FPreviewPages + write FPreviewPages; + property Zoom: Extended read FZoom write FZoom; + property RTLLanguage: Boolean read FRTLLanguage write FRTLLanguage; + property OnDblClick; + end; + + TfrxPageItem = class(TCollectionItem) + public + Height: Integer; + Width: Integer; + OffsetX: Integer; + OffsetY: Integer; + end; + + TfrxPageList = class(TCollection) + private + FMaxWidth: Integer; + function GetItems(Index: Integer): TfrxPageItem; + public + constructor Create; + property Items[Index: Integer]: TfrxPageItem read GetItems; default; + procedure AddPage(AWidth, AHeight: Integer; Zoom: Extended); + procedure CalcBounds(ClientWidth: Integer); + function FindPage(OffsetY: Integer; OffsetX: Integer = 0): Integer; + function GetPageBounds(Index, ClientWidth: Integer; Scale: Extended; RTL: Boolean): TRect; + function GetMaxBounds: TPoint; + end; + + +implementation + +{$R *.DFM} +{$R *.RES} + +uses + Printers, frxPrinter, frxSearchDialog, frxUtils, frxRes, frxDsgnIntf, + frxPreviewPageSettings, frxDMPClass; + + +type + THackControl = class(TWinControl); + +{ search given string in a metafile } + +var + TextToFind: String; + TextFound: Boolean; + TextBounds: TRect; + RecordNo: Integer; + LastFoundRecord: Integer; + CaseSensitive: Boolean; + +function EnumEMFRecordsProc(DC: HDC; HandleTable: PHandleTable; + EMFRecord: PEnhMetaRecord; nObj: Integer; OptData: Pointer): Bool; stdcall; +var + Typ: Byte; + s: String; + t: TEMRExtTextOut; + Found: Boolean; +begin + Result := True; + Typ := EMFRecord^.iType; + if Typ in [83, 84] then + begin + t := PEMRExtTextOut(EMFRecord)^; + s := WideCharLenToString(PWideChar(PAnsiChar(EMFRecord) + t.EMRText.offString), + t.EMRText.nChars); + if CaseSensitive then + Found := Pos(TextToFind, s) <> 0 else + Found := Pos(AnsiUpperCase(TextToFind), AnsiUpperCase(s)) <> 0; + if Found and (RecordNo > LastFoundRecord) then + begin + TextFound := True; + TextBounds := t.rclBounds; + LastFoundRecord := RecordNo; + Result := False; + end; + end; + Inc(RecordNo); +end; + + +{ TfrxPageList } + +constructor TfrxPageList.Create; +begin + inherited Create(TfrxPageItem); +end; + +function TfrxPageList.GetItems(Index: Integer): TfrxPageItem; +begin + Result := TfrxPageItem(inherited Items[Index]); +end; + +procedure TfrxPageList.AddPage(AWidth, AHeight: Integer; Zoom: Extended); +begin + with TfrxPageItem(Add) do + begin + Width := Round(AWidth * Zoom); + Height := Round(AHeight * Zoom); + end; +end; + +procedure TfrxPageList.CalcBounds(ClientWidth: Integer); +var + i, j, CurX, CurY, MaxY, offs: Integer; + Item: TfrxPageItem; +begin + FMaxWidth := 0; + CurY := 10; + i := 0; + while i < Count do + begin + j := i; + CurX := 0; + MaxY := 0; + { find series of pages that will fit in the clientwidth } + { also calculate max height of series } + while j < Count do + begin + Item := Items[j]; + { check the width, allow at least one iteration } + if (CurX > 0) and (CurX + Item.Width > ClientWidth) then break; + Item.OffsetX := CurX; + Item.OffsetY := CurY; + Inc(CurX, Item.Width + 10); + if Item.Height > MaxY then + MaxY := Item.Height; + Inc(j); + end; + + if CurX > FMaxWidth then + FMaxWidth := CurX; + + { center series horizontally } + offs := (ClientWidth - CurX + 10) div 2; + if offs < 0 then + offs := 0; + Inc(offs, 10); + while (i < j) do + begin + Inc(Items[i].OffsetX, offs); + Inc(i); + end; + + Inc(CurY, MaxY + 10); + end; +end; + +function TfrxPageList.FindPage(OffsetY: Integer; OffsetX: Integer = 0): Integer; +var + i, i0, i1, c, add: Integer; + Item: TfrxPageItem; +begin + i0 := 0; + i1 := Count - 1; + + while i0 <= i1 do + begin + i := (i0 + i1) div 2; + if OffsetX <> 0 then + add := 0 else + add := Round(Items[i].Height / 5); + if Items[i].OffsetY <= OffsetY + add then + c := -1 else + c := 1; + + if c < 0 then + i0 := i + 1 else + i1 := i - 1; + end; + + { find exact page } + if OffsetX <> 0 then + begin + for i := i1 - 20 to i1 + 20 do + begin + if (i < 0) or (i >= Count) then continue; + Item := Items[i]; + if PtInRect(Rect(Item.OffsetX, Item.OffsetY, + Item.OffsetX + Item.Width, Item.OffsetY + Item.Height), + Point(OffsetX, OffsetY)) then + begin + i1 := i; + break; + end; + end; + end; + + Result := i1; +end; + +function TfrxPageList.GetPageBounds(Index, ClientWidth: Integer; + Scale: Extended; RTL: Boolean): TRect; +var + ColumnOffs: Integer; + Item: TfrxPageItem; +begin + if (Index >= Count) or (Index < 0) then + begin + if 794 * Scale > ClientWidth then + ColumnOffs := 10 else + ColumnOffs := Round((ClientWidth - 794 * Scale) / 2); + Result.Left := ColumnOffs; + Result.Top := Round(10 * Scale); + Result.Right := Result.Left + Round(794 * Scale); + Result.Bottom := Result.Top + Round(1123 * Scale); + end + else + begin + Item := Items[Index]; + if RTL then + Result.Left := ClientWidth - Item.Width - Item.OffsetX + else + Result.Left := Item.OffsetX; + Result.Top := Item.OffsetY; + Result.Right := Result.Left + Item.Width; + Result.Bottom := Result.Top + Item.Height; + end; +end; + +function TfrxPageList.GetMaxBounds: TPoint; +begin + if Count = 0 then + Result := Point(0, 0) + else + begin + Result.X := FMaxWidth; + Result.Y := Items[Count - 1].OffsetY + Items[Count - 1].Height; + end; +end; + + +{ TfrxPreviewWorkspace } + +constructor TfrxPreviewWorkspace.Create(AOwner: TComponent); +begin + inherited; + FPageList := TfrxPageList.Create; + OnDblClick := PrevDblClick; + + FBackColor := clGray; + FFrameColor := clBlack; + FActiveFrameColor := $804020; + FZoom := 1; + FDefaultCursor := crHand; + + LargeChange := 300; + SmallChange := 8; +end; + +destructor TfrxPreviewWorkspace.Destroy; +begin + if FEMFImage <> nil then + FEMFImage.Free; + FPageList.Free; + inherited; +end; + +procedure TfrxPreviewWorkspace.OnHScrollChange(Sender: TObject); +var + pp: Integer; + r: TRect; +begin + pp := FOffset.X - HorzPosition; + FOffset.X := HorzPosition; + r := Rect(0, 0, ClientWidth, ClientHeight); + ScrollWindowEx(Handle, pp, 0, @r, @r, 0, nil, SW_ERASE + SW_INVALIDATE); +end; + +procedure TfrxPreviewWorkspace.OnVScrollChange(Sender: TObject); +var + i, pp: Integer; + r: TRect; +begin + pp := FOffset.Y - VertPosition; + FOffset.Y := VertPosition; + r := Rect(0, 0, ClientWidth, ClientHeight); + ScrollWindowEx(Handle, 0, pp, @r, @r, 0, nil, SW_ERASE + SW_INVALIDATE); + + if not FIsThumbnail then + begin + i := FPageList.FindPage(FOffset.Y); + FDisableUpdate := True; + Preview.PageNo := i + 1; + FDisableUpdate := False; + end; +end; + +procedure TfrxPreviewWorkspace.DrawPages(BorderOnly: Boolean); +var + i, n: Integer; + PageBounds: TRect; + h: HRGN; + + function PageVisible: Boolean; + begin + if (PageBounds.Top > ClientHeight) or (PageBounds.Bottom < 0) then + Result := False + else + Result := RectVisible(Canvas.Handle, PageBounds); + end; + + procedure DrawPage(Index: Integer); + var + i: Integer; + TxtBounds: TRect; + begin + with Canvas, PageBounds do + begin + Pen.Color := FrameColor; + Pen.Width := 1; + Pen.Mode := pmCopy; + Pen.Style := psSolid; + Brush.Color := clWhite; + Brush.Style := bsSolid; + Dec(Bottom); + Rectangle(Left, Top, Right, Bottom); + end; + + PreviewPages.DrawPage(Index, Canvas, Zoom, Zoom, PageBounds.Left, PageBounds.Top); + + if FIsThumbnail then + with Canvas do + begin + Font.Name := 'Arial'; + Font.Size := 8; + Font.Style := []; + Font.Color := clWhite; + Brush.Style := bsSolid; + Brush.Color := BackColor; + TextOut(PageBounds.Left + 1, PageBounds.Top + 1, ' ' + IntToStr(Index + 1) + ' '); + end; + + { highlight text found } + TxtBounds := Rect(Round(TextBounds.Left * Zoom), + Round(TextBounds.Top * Zoom), + Round(TextBounds.Right * Zoom), + Round(TextBounds.Bottom * Zoom)); + if TextFound and (Index = FLastFoundPage) then + with Canvas, TxtBounds do + begin + Pen.Width := 1; + Pen.Style := psSolid; + Pen.Mode := pmXor; + Pen.Color := clWhite; + for i := 0 to Bottom - Top do + begin + MoveTo(PageBounds.Left + Left - 1, PageBounds.Top + Top + i); + LineTo(PageBounds.Left + Right + 1, PageBounds.Top + Top + i); + end; + Pen.Mode := pmCopy; + end; + end; + +begin + if not Visible then Exit; + + if Locked or (FPageList.Count = 0) then + begin + Canvas.Brush.Color := BackColor; + Canvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight)); + Exit; + end; + + if PreviewPages = nil then Exit; + + h := CreateRectRgn(0, 0, ClientWidth, ClientHeight); + GetClipRgn(Canvas.Handle, h); + + { index of first visible page } + n := FPageList.FindPage(FOffset.Y); + + { exclude page areas to prevent flickering } + for i := n - 40 to n + 40 do + begin + if i < 0 then continue; + if i >= FPageList.Count then break; + + PageBounds := FPageList.GetPageBounds(i, ClientWidth, Zoom, FRTLLanguage); + OffsetRect(PageBounds, -FOffset.X, -FOffset.Y); + if PageVisible then + with PageBounds do + ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom); + end; + + { now draw background on the non-clipped area} + with Canvas do + begin + Brush.Color := BackColor; + Brush.Style := bsSolid; + FillRect(Rect(0, 0, ClientWidth, ClientHeight)); + end; + + { restore clipregion } + SelectClipRgn(Canvas.Handle, h); + + { draw border around the active page } + PageBounds := FPageList.GetPageBounds(PageNo - 1, ClientWidth, Zoom, FRTLLanguage); + OffsetRect(PageBounds, -FOffset.X, -FOffset.Y); + with Canvas, PageBounds do + begin + Pen.Color := ActiveFrameColor; + Pen.Width := 2; + Pen.Mode := pmCopy; + Pen.Style := psSolid; + Polyline([Point(Left - 1, Top - 1), + Point(Right + 1, Top - 1), + Point(Right + 1, Bottom + 1), + Point(Left - 1, Bottom + 1), + Point(Left - 1, Top - 2)]); + end; + if not BorderOnly then + begin + { draw visible pages } + for i := n - 40 to n + 40 do + begin + if i < 0 then continue; + if i >= FPageList.Count then break; + + PageBounds := FPageList.GetPageBounds(i, ClientWidth, Zoom, FRTLLanguage); + OffsetRect(PageBounds, -FOffset.X, -FOffset.Y); + Inc(PageBounds.Bottom); + if PageVisible then + DrawPage(i); + end; + end; + + DeleteObject(h); +end; + +procedure TfrxPreviewWorkspace.Paint; +begin + DrawPages(False); +end; + +procedure TfrxPreviewWorkspace.MouseDown(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + if (FPageList.Count = 0) or Locked then Exit; + + if Button = mbLeft then + begin + FDown := True; + FLastPoint.X := X; + FLastPoint.Y := Y; + end; +end; + +procedure TfrxPreviewWorkspace.MouseMove(Shift: TShiftState; X, Y: Integer); +var + PageNo: Integer; + PageBounds: TRect; + Cur: TCursor; +begin + if (FPageList.Count = 0) or Locked or FIsThumbnail then Exit; + + if FDown then + begin + HorzPosition := HorzPosition - (X - FLastPoint.X); + VertPosition := VertPosition - (Y - FLastPoint.Y); + FLastPoint.X := X; + FLastPoint.Y := Y; + end + else + begin + PageNo := FPageList.FindPage(FOffset.Y + Y, FOffset.X + X); + PageBounds := FPageList.GetPageBounds(PageNo, ClientWidth, Zoom, FRTLLanguage); + Cur := FDefaultCursor; + PreviewPages.ObjectOver(PageNo, X, Y, mbLeft, [], Zoom, + PageBounds.Left - FOffset.X, PageBounds.Top - FOffset.Y, False, Cur); + Cursor := Cur; + end; +end; + +procedure TfrxPreviewWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + PageNo: Integer; + PageBounds: TRect; + Cur: TCursor; + XOffSet: Integer; +begin + if not FIsThumbnail and Assigned(Preview.OnClick) then + Preview.OnClick(Preview); + if (FPageList.Count = 0) or Locked then Exit; + + FDown := False; + if FRTLLanguage then + XOffSet := ClientWidth - (FOffset.X + X) + else + XOffSet := FOffset.X + X; + + PageNo := FPageList.FindPage(FOffset.Y + Y, XOffSet); + FDisableUpdate := True; + Preview.PageNo := PageNo + 1; + FDisableUpdate := False; + + if not FIsThumbnail and (Button <> mbRight) then + begin + PageBounds := FPageList.GetPageBounds(PageNo, ClientWidth, Zoom, FRTLLanguage); + if (GetTickCount - FTimeOffset <= GetDoubleClickTime) then + begin + FTimeOffset := 0; + PreviewPages.ObjectOver(PageNo, X, Y, Button, Shift, Zoom, + PageBounds.Left - FOffset.X, PageBounds.Top - FOffset.Y, True, Cur, True); + end + else + begin + FTimeOffset := GetTickCount; + PreviewPages.ObjectOver(PageNo, X, Y, Button, Shift, Zoom, + PageBounds.Left - FOffset.X, PageBounds.Top - FOffset.Y, True, Cur); + end; + end; +end; + +procedure TfrxPreviewWorkspace.FindText; +var + EMFCanvas: TMetafileCanvas; + PageBounds, TxtBounds: TRect; +begin + TextFound := False; + + while FLastFoundPage < FPageList.Count do + begin + if (FEMFImage = nil) or (FEMFImagePage <> FLastFoundPage) then + begin + if FEMFImage <> nil then + FEMFImage.Free; + FEMFImage := TMetafile.Create; + EMFCanvas := TMetafileCanvas.Create(FEMFImage, 0); + PreviewPages.DrawPage(FLastFoundPage, EMFCanvas, 1, 1, 0, 0); + EMFCanvas.Free; + end; + + FEMFImagePage := FLastFoundPage; + RecordNo := 0; + EnumEnhMetafile(0, FEMFImage.Handle, @EnumEMFRecordsProc, nil, Rect(0, 0, 0, 0)); + + if TextFound then + begin + PageBounds := FPageList.GetPageBounds(FLastFoundPage, ClientWidth, Zoom, FRTLLanguage); + TxtBounds := Rect(Round(TextBounds.Left * Zoom), + Round(TextBounds.Top * Zoom), + Round(TextBounds.Right * Zoom), + Round(TextBounds.Bottom * Zoom)); + + if (PageBounds.Top + TxtBounds.Top < FOffset.Y) or + (PageBounds.Top + TxtBounds.Bottom > FOffset.Y + ClientHeight) then + VertPosition := PageBounds.Top + TxtBounds.Bottom - ClientHeight + 20; + if (PageBounds.Left + TxtBounds.Left < FOffset.X) or + (PageBounds.Left + TxtBounds.Right > FOffset.X + ClientWidth) then + HorzPosition := PageBounds.Left + TxtBounds.Right - ClientWidth + 20; + Repaint; + break; + end; + + LastFoundRecord := -1; + Inc(FLastFoundPage); + end; + if not TextFound then ShowMessage(frxResources.Get('clStrNotFound')); +end; + +procedure TfrxPreviewWorkspace.Resize; +begin + inherited; + HorzPage := ClientWidth; + VertPage := ClientHeight; +end; + +procedure TfrxPreviewWorkspace.SetToPageNo(PageNo: Integer); +begin + if FDisableUpdate then Exit; + VertPosition := + FPageList.GetPageBounds(PageNo - 1, ClientWidth, Zoom, FRTLLanguage).Top - 10; +end; + +procedure TfrxPreviewWorkspace.UpdateScrollBars; +var + MaxSize: TPoint; +begin + MaxSize := FPageList.GetMaxBounds; + HorzRange := MaxSize.X + 10; + VertRange := MaxSize.Y + 10; +end; + +procedure TfrxPreviewWorkspace.SetPosition(PageN, Top: Integer); +var + Pos: Integer; + Page: TfrxReportPage; +begin + Page := PreviewPages.Page[PageN - 1]; + if Page = nil then + exit; + if Top = 0 then + Pos := 0 + else + Pos := Round((Top + Page.TopMargin * fr01cm) * Zoom); + + VertPosition := FPageList.GetPageBounds(PageN - 1, ClientWidth, Zoom, FRTLLanguage).Top - 10 + Pos; +end; + +function TfrxPreviewWorkspace.GetTopPosition: Integer; +var + Page: TfrxReportPage; +begin + Result := 0; + Page := PreviewPages.Page[Preview.PageNo - 1]; + if Page <> nil then + Result := Round((VertPosition - FPageList.GetPageBounds(Preview.PageNo - 1,ClientWidth, Zoom, FRTLLanguage).Top + 10)/ Zoom - Page.TopMargin * fr01cm); +end; + +procedure TfrxPreviewWorkspace.AddPage(AWidth, AHeight: Integer); +begin + FPageList.AddPage(AWidth, AHeight, Zoom); +end; + +procedure TfrxPreviewWorkspace.CalcPageBounds(ClientWidth: Integer); +begin + FPageList.CalcBounds(ClientWidth); +end; + +procedure TfrxPreviewWorkspace.ClearPageList; +begin + FPageList.Clear; +end; + + +procedure TfrxPreviewWorkspace.PrevDblClick(Sender: TObject); +begin + if not IsThumbnail and Assigned(FPreview.OnDblClick) then + FPreview.OnDblClick(Sender); +end; + +{ TfrxPreview } + +constructor TfrxPreview.Create(AOwner: TComponent); +var + m: TMenuItem; +begin + inherited; + + FOutlinePopup := TPopupMenu.Create(Self); + FOutlinePopup.Images := frxResources.PreviewButtonImages; + m := TMenuItem.Create(FOutlinePopup); + FOutlinePopup.Items.Add(m); + m.Caption := frxGet(601); + m.ImageIndex := 13; + m.OnClick := OnCollapseClick; + m := TMenuItem.Create(FOutlinePopup); + FOutlinePopup.Items.Add(m); + m.Caption := frxGet(600); + m.ImageIndex := 14; + m.OnClick := OnExpandClick; + + FOutline := TTreeView.Create(Self); + with FOutline do + begin + Parent := Self; + Align := alLeft; + HideSelection := False; +{$IFDEF UseTabset} + BorderStyle := bsNone; + BevelKind := bkFlat; +{$ELSE} + BorderStyle := bsSingle; +{$ENDIF} + OnClick := OnOutlineClick; + PopupMenu := FOutlinePopup; + end; + + FThumbnail := TfrxPreviewWorkspace.Create(Self); + FThumbnail.Parent := Self; + FThumbnail.Align := alLeft; + FThumbnail.Visible := False; + FThumbnail.Zoom := 0.1; + FThumbnail.IsThumbnail := True; + FThumbnail.Preview := Self; + + FSplitter := TSplitter.Create(Self); + FSplitter.Parent := Self; + FSplitter.Align := alLeft; + FSplitter.Width := 4; + FSplitter.Left := FOutline.Width + 1; + FSplitter.OnMoved := OnMoveSplitter; + + FWorkspace := TfrxPreviewWorkspace.Create(Self); + FWorkspace.Parent := Self; + FWorkspace.Align := alClient; + FWorkspace.Preview := Self; + + FMessagePanel := TPanel.Create(Self); + FMessagePanel.Parent := Self; + FMessagePanel.Visible := False; + FMessagePanel.SetBounds(0, 0, 0, 0); + + FMessageLabel := TLabel.Create(FMessagePanel); + FMessageLabel.Parent := FMessagePanel; + FMessageLabel.AutoSize := False; + FMessageLabel.Alignment := taCenter; + FMessageLabel.SetBounds(4, 20, 255, 20); + + FCancelButton := TButton.Create(FMessagePanel); + FCancelButton.Parent := FMessagePanel; + FCancelButton.SetBounds(92, 44, 75, 25); + FCancelButton.Caption := frxResources.Get('clCancel'); + FCancelButton.Visible := False; + FCancelButton.OnClick := OnCancel; + + FBorderStyle := bsSingle; + FPageNo := 1; + FScrollBars := ssBoth; + FZoom := 1; + FZoomMode := zmDefault; + FOutlineColor := clWindow; + UseReportHints := True; + + Width := 100; + Height := 100; +end; + +destructor TfrxPreview.Destroy; +begin + if Report <> nil then + Report.Preview := nil; + inherited; +end; + +procedure TfrxPreview.CreateParams(var Params: TCreateParams); +const + BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER); +begin + inherited CreateParams(Params); + with Params do + begin + Style := Style or BorderStyles[FBorderStyle]; + if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then + begin + Style := Style and not WS_BORDER; + ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; + end; +end; + +procedure TfrxPreview.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then + if AComponent = Report then + begin + Clear; + Report := nil; + PreviewPages := nil; + end; +end; + +procedure TfrxPreview.Init; +begin + FWorkspace.PreviewPages := PreviewPages; + FThumbnail.PreviewPages := PreviewPages; + TextFound := False; + FWorkspace.FLastFoundPage := 0; + LastFoundRecord := -1; + FAllowF3 := False; + + FWorkspace.DoubleBuffered := True; + OutlineWidth := Report.PreviewOptions.OutlineWidth; + OutlineVisible := Report.PreviewOptions.OutlineVisible; + ThumbnailVisible := Report.PreviewOptions.ThumbnailVisible; + FZoomMode := Report.PreviewOptions.ZoomMode; + Fzoom := Report.PreviewOptions.Zoom; + if not(Owner is TfrxPreviewForm) and UseRightToLeftAlignment then + FlipChildren(True); + UpdatePages; + UpdateOutline; + First; +end; + +procedure TfrxPreview.WMEraseBackground(var Message: TMessage); +begin +end; + +procedure TfrxPreview.WMGetDlgCode(var Message: TWMGetDlgCode); +begin + Message.Result := DLGC_WANTARROWS; +end; + +procedure TfrxPreview.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + if Key = vk_Up then + FWorkspace.VertPosition := FWorkspace.VertPosition - 8 + else if Key = vk_Down then + FWorkspace.VertPosition := FWorkspace.VertPosition + 8 + else if Key = vk_Left then + FWorkspace.HorzPosition := FWorkspace.HorzPosition - 8 + else if Key = vk_Right then + FWorkspace.HorzPosition := FWorkspace.HorzPosition + 8 + else if Key = vk_Prior then + if ssCtrl in Shift then + PageNo := PageNo - 1 + else + FWorkspace.VertPosition := FWorkspace.VertPosition - 300 + else if Key = vk_Next then + if ssCtrl in Shift then + PageNo := PageNo + 1 + else + FWorkspace.VertPosition := FWorkspace.VertPosition + 300 + else if Key = vk_Home then + PageNo := 1 + else if Key = vk_End then + PageNo := PageCount + else if (Key = vk_F3) and (pbFind in Report.PreviewOptions.Buttons) then + FindNext + else if ssCtrl in Shift then + begin + if (Key = Ord('P')) and (pbPrint in Report.PreviewOptions.Buttons) then + Print + else if (Key = Ord('S')) and (pbSave in Report.PreviewOptions.Buttons) then + SaveToFile + else if (Key = Ord('F')) and (pbFind in Report.PreviewOptions.Buttons) then + Find + else if (Key = Ord('O')) and (pbLoad in Report.PreviewOptions.Buttons) then + LoadFromFile + end; +end; + +procedure TfrxPreview.Resize; +begin + inherited; + if PreviewPages <> nil then + UpdatePages; +end; + +procedure TfrxPreview.OnMoveSplitter(Sender: TObject); +begin + UpdatePages; +end; + +procedure TfrxPreview.OnCollapseClick(Sender: TObject); +begin + FOutline.FullCollapse; + FWorkspace.SetFocus; +end; + +procedure TfrxPreview.OnExpandClick(Sender: TObject); +begin + FOutline.FullExpand; + if FOutline.Items.Count > 0 then + FOutline.TopItem := FOutline.Items[0]; + FWorkspace.SetFocus; +end; + +procedure TfrxPreview.SetZoom(const Value: Extended); +begin + FZoom := Value; + if FZoom < 0.25 then + FZoom := 0.25; + + FZoomMode := zmDefault; + UpdatePages; +end; + +procedure TfrxPreview.SetZoomMode(const Value: TfrxZoomMode); +begin + FZoomMode := Value; + UpdatePages; +end; + +function TfrxPreview.GetOutlineVisible: Boolean; +begin + Result := FOutline.Visible; +end; + +procedure TfrxPreview.SetOutlineVisible(const Value: Boolean); +var + NeedChange: Boolean; +begin + NeedChange := Value <> FOutline.Visible; + + FSplitter.Visible := Value or ThumbnailVisible; + FOutline.Visible := Value; + + if UseRightToLeftAlignment then + FOutline.Left := Width; + + if Value then + FThumbnail.Visible := False; + + if Owner is TfrxPreviewForm then + TfrxPreviewForm(Owner).OutlineB.Down := Value; + if NeedChange then + UpdatePages; +end; + +function TfrxPreview.GetThumbnailVisible: Boolean; +begin + Result := FThumbnail.Visible; +end; + +procedure TfrxPreview.SetThumbnailVisible(const Value: Boolean); +var + NeedChange: Boolean; +begin + NeedChange := Value <> FThumbnail.Visible; + + FSplitter.Visible := Value or OutlineVisible; + FThumbnail.Visible := Value; + + if UseRightToLeftAlignment then + FThumbnail.Left := Width; + + if Value then + FOutline.Visible := False; + + if Value then + begin + FThumbnail.HorzPosition := FThumbnail.HorzPosition; + FThumbnail.VertPosition := FThumbnail.VertPosition; + end; + if Owner is TfrxPreviewForm then + TfrxPreviewForm(Owner).ThumbB.Down := Value; + if NeedChange then + UpdatePages; +end; + +function TfrxPreview.GetOutlineWidth: Integer; +begin + Result := FOutline.Width; +end; + +procedure TfrxPreview.SetOutlineWidth(const Value: Integer); +begin + FOutline.Width := Value; + if not (csDesigning in ComponentState) then + FThumbnail.Width := Value; +end; + +procedure TfrxPreview.SetOutlineColor(const Value: TColor); +begin + FOutlineColor := Value; + FOutline.Color := Value; +end; + +procedure TfrxPreview.SetPageNo(Value: Integer); +var + ActivePageChanged: Boolean; +begin + if Value < 1 then + Value := 1; + if Value > PageCount then + Value := PageCount; + ActivePageChanged := FPageNo <> Value; + FPageNo := Value; + FWorkspace.PageNo := Value; + FThumbnail.PageNo := Value; + + if ActivePageChanged then + begin + FWorkspace.DrawPages(True); + FThumbnail.DrawPages(True); + end; + FWorkspace.SetToPageNo(FPageNo); + FThumbnail.SetToPageNo(FPageNo); + UpdatePageNumbers; +end; + +function TfrxPreview.GetActiveFrameColor: TColor; +begin + Result := FWorkspace.ActiveFrameColor; +end; + +function TfrxPreview.GetBackColor: TColor; +begin + Result := FWorkspace.BackColor; +end; + +function TfrxPreview.GetFrameColor: TColor; +begin + Result := FWorkspace.FrameColor; +end; + +procedure TfrxPreview.SetActiveFrameColor(const Value: TColor); +begin + FWorkspace.ActiveFrameColor := Value; +end; + +procedure TfrxPreview.SetBackColor(const Value: TColor); +begin + FWorkspace.BackColor := Value; +end; + +procedure TfrxPreview.SetFrameColor(const Value: TColor); +begin + FWorkspace.FrameColor := Value; +end; + +procedure TfrxPreview.SetBorderStyle(Value: TBorderStyle); +begin + if BorderStyle <> Value then + begin + FBorderStyle := Value; + RecreateWnd; + end; +end; + +procedure TfrxPreview.UpdatePageNumbers; +begin + if Assigned(FOnPageChanged) then + FOnPageChanged(Self, FPageNo); +end; + +function TfrxPreview.GetPageCount: Integer; +begin + if PreviewPages <> nil then + Result := PreviewPages.Count + else + Result := 0; +end; + +{$IFDEF FR_COM} +function TfrxPreview.ShowMessage(const s: WideString): HResult; +{$ELSE} +procedure TfrxPreview.ShowMessage(const s: String); +{$ENDIF} +begin + FMessagePanel.SetBounds((Width - 260) div 2, (Height - 75) div 3, 260, 75); + FMessageLabel.Caption := s; + FMessagePanel.Show; + FMessagePanel.Update; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.HideMessage: HResult; +{$ELSE} +procedure TfrxPreview.HideMessage; +{$ENDIF} +begin + FMessagePanel.Hide; + FCancelButton.Hide; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.First: HResult; +{$ELSE} +procedure TfrxPreview.First; +{$ENDIF} +begin + PageNo := 1; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Next: HResult; +{$ELSE} +procedure TfrxPreview.Next; +{$ENDIF} +begin + PageNo := PageNo + 1; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Prior: HResult; +{$ELSE} +procedure TfrxPreview.Prior; +{$ENDIF} +begin + PageNo := PageNo - 1; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Last: HResult; +{$ELSE} +procedure TfrxPreview.Last; +{$ENDIF} +begin + PageNo := PageCount; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Print: HResult; +begin + if not FRunning then + begin + try + PreviewPages.CurPreviewPage := PageNo; + PreviewPages.Print; + Result := S_OK; + except + Result := E_FAIL; + end; + Unlock; + end else + Result := RPC_E_SERVERCALL_RETRYLATER; +end; +{$ELSE} +procedure TfrxPreview.Print; +begin + if FRunning then Exit; + try + PreviewPages.CurPreviewPage := PageNo; + PreviewPages.Print; + finally + Unlock; + end; +end; +{$ENDIF} + +procedure TfrxPreview.SaveToFile; +var + SaveDlg: TSaveDialog; +begin + if FRunning then Exit; + SaveDlg := TSaveDialog.Create(Application); + try + SaveDlg.Options := SaveDlg.Options + [ofNoChangeDir]; + SaveDlg.Filter := frxResources.Get('clFP3files') + ' (*.fp3)|*.fp3'; + if SaveDlg.Execute then + begin + FWorkspace.Repaint; + SaveToFile(ChangeFileExt(SaveDlg.FileName, '.fp3')); + end; + finally + SaveDlg.Free; + end; +end; + +procedure TfrxPreview.SaveToFile(FileName: String); +begin + if FRunning then Exit; + try + Lock; + ShowMessage(frxResources.Get('clSaving')); + PreviewPages.SaveToFile(FileName); + finally + Unlock; + end; +end; + +procedure TfrxPreview.LoadFromFile; +var + OpenDlg: TOpenDialog; +begin + if FRunning then Exit; + OpenDlg := TOpenDialog.Create(nil); + try + OpenDlg.Options := [ofHideReadOnly, ofNoChangeDir]; + OpenDlg.Filter := frxResources.Get('clFP3files') + ' (*.fp3)|*.fp3'; + if OpenDlg.Execute then + begin + FWorkspace.Repaint; + LoadFromFile(OpenDlg.FileName); + end; + finally + OpenDlg.Free; + end; +end; + +procedure TfrxPreview.LoadFromFile(FileName: String); +begin + if FRunning then Exit; + try + Lock; + ShowMessage(frxResources.Get('clLoading')); + PreviewPages.LoadFromFile(FileName); + finally + PageNo := 1; + UpdateOutline; + Unlock; + end; +end; + +procedure TfrxPreview.Export(Filter: TfrxCustomExportFilter); +begin + if FRunning then Exit; + try + PreviewPages.CurPreviewPage := PageNo; + if Report.DotMatrixReport and (frxDotMatrixExport <> nil) and + (Filter.ClassName = 'TfrxTextExport') then + Filter := frxDotMatrixExport; + PreviewPages.Export(Filter); + finally + Unlock; + end; +end; + +function TfrxPreview.FindText(SearchString: String; FromTop, IsCaseSensitive: Boolean): Boolean; +begin + TextToFind := SearchString; + CaseSensitive := IsCaseSensitive; + if FromTop then + FWorkspace.FLastFoundPage := 0 + else + FWorkspace.FLastFoundPage := PageNo - 1; + LastFoundRecord := -1; + + FWorkspace.FindText; + + FAllowF3 := True; + Result := TextFound; +end; + +function TfrxPreview.FindTextFound: Boolean; +begin + Result := TextFound; +end; + +procedure TfrxPreview.FindTextClear; +begin + LastFoundRecord := -1; + FWorkspace.FLastFoundPage := 0; + TextFound := False; + Invalidate; +end; + +{$IFDEF FR_COM} +function TfrxPreview.PageSetupDlg: HResult; +{$ELSE} +procedure TfrxPreview.PageSetupDlg; +{$ENDIF} +var + APage: TfrxReportPage; + + procedure UpdateReport; + var + i: Integer; + begin + for i := 0 to Report.PagesCount - 1 do + if Report.Pages[i] is TfrxReportPage then + with TfrxReportPage(Report.Pages[i]) do + begin + Orientation := APage.Orientation; + PaperWidth := APage.PaperWidth; + PaperHeight := APage.PaperHeight; + PaperSize := APage.PaperSize; + + LeftMargin := APage.LeftMargin; + RightMargin := APage.RightMargin; + TopMargin := APage.TopMargin; + BottomMargin := APage.BottomMargin; + end; + end; + +begin +{$IFDEF FR_COM} + if FRunning then Result := RPC_E_SERVERCALL_RETRYLATER else + begin +{$ELSE} + if FRunning then Exit; +{$ENDIF} + APage := PreviewPages.Page[PageNo - 1]; + + if Assigned(APage) then with TfrxPageSettingsForm.Create(Application) do + begin + Page := APage; + Report := Self.Report; + if ShowModal = mrOk then + begin + if NeedRebuild then + begin + UpdateReport; + Self.Report.PrepareReport; + end + else + begin + try + Lock; + PreviewPages.ModifyPage(PageNo - 1, Page); + finally + Unlock; + end; + end; + end; + Free; + end; +{$IFDEF FR_COM} + Result := S_OK; + end; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Find: HResult; +{$ELSE} +procedure TfrxPreview.Find; +{$ENDIF} +begin + with TfrxSearchDialog.Create(Application) do + begin + if ShowModal = mrOk then + begin + TextToFind := TextE.Text; + CaseSensitive := CaseCB.Checked; + if TopCB.Checked then + FWorkspace.FLastFoundPage := 0 + else + FWorkspace.FLastFoundPage := PageNo - 1; + LastFoundRecord := -1; + FWorkspace.FindText; + end; + Free; + end; + + FAllowF3 := True; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.FindNext: HResult; +{$ELSE} +procedure TfrxPreview.FindNext; +{$ENDIF} +begin + if FAllowF3 then + FWorkspace.FindText; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.Edit: HResult; +{$ELSE} +procedure TfrxPreview.Edit; +{$ENDIF} +var + r: TfrxReport; + p: TfrxReportPage; + SourcePage: TfrxPage; + + procedure RemoveBands; + var + i: Integer; + l: TList; + c: TfrxComponent; + begin + l := p.AllObjects; + + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if c is TfrxView then + begin + TfrxView(c).DataField := ''; + TfrxView(c).DataSet := nil; + TfrxView(c).Restrictions := []; + end; + + if c.Parent <> p then + begin + c.Left := c.AbsLeft; + c.Top := c.AbsTop; + c.ParentFont := False; + c.Parent := p; + if (c is TfrxView) and (TfrxView(c).Align in [baBottom, baClient]) then + TfrxView(c).Align := baNone; + end; + end; + + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if c is TfrxBand then + c.Free; + end; + end; + +begin + SourcePage := PreviewPages.Page[PageNo - 1]; + r := nil; + if Assigned(SourcePage) then + try + + if SourcePage is TfrxDMPPage then + p := TfrxDMPPage.Create(nil) else + p := TfrxReportPage.Create(nil); + r := TfrxReport.Create(nil); + p.AssignAll(SourcePage); + p.Parent := r; + RemoveBands; + if r.DesignPreviewPage then + try + Lock; + PreviewPages.ModifyPage(PageNo - 1, TfrxReportPage(r.Pages[0])); + finally + Unlock; + end; + except + end; + if r <> nil then + r.Free; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +procedure TfrxPreview.EditTemplate; +var + r: TfrxReport; + i: Integer; +begin + r := TfrxReport.Create(nil); + try + for i := 0 to TfrxPreviewPages(PreviewPages).SourcePages.Count - 1 do + r.Objects.Add(TfrxPreviewPages(PreviewPages).SourcePages[i]); + r.DesignReport; + finally + r.Objects.Clear; + r.Free; + end; +end; + +{$IFDEF FR_COM} +function TfrxPreview.Clear: HResult; +begin + if FRunning then Result := RPC_E_SERVERCALL_RETRYLATER else + begin +{$ELSE} +procedure TfrxPreview.Clear; +begin + if FRunning then Exit; +{$ENDIF} + Lock; + try + PreviewPages.Clear; + finally + Unlock; + end; + + FWorkspace.ClearPageList; + FThumbnail.ClearPageList; + UpdateOutline; + PageNo := 1; + with FWorkspace do + begin + HorzRange := 0; + VertRange := 0; + end; + if ThumbnailVisible then + with FThumbnail do + begin + HorzRange := 0; + VertRange := 0; + end; +{$IFDEF FR_COM} + Result := S_OK; + end; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.AddPage: HResult; +begin + if FRunning then Result := RPC_E_SERVERCALL_RETRYLATER else + begin +{$ELSE} +procedure TfrxPreview.AddPage; +begin + if FRunning then Exit; +{$ENDIF} + PreviewPages.AddEmptyPage(PageNo - 1); + UpdatePages; + PageNo := PageNo; +{$IFDEF FR_COM} + Result := S_OK; + end; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.DeletePage: HResult; +begin + if FRunning then Result := RPC_E_SERVERCALL_RETRYLATER else + begin +{$ELSE} +procedure TfrxPreview.DeletePage; +begin + if FRunning then Exit; +{$ENDIF} + PreviewPages.DeletePage(PageNo - 1); + if PageNo >= PageCount then + PageNo := PageNo - 1; + UpdatePages; + UpdatePageNumbers; +{$IFDEF FR_COM} + Result := S_OK; + end; +{$ENDIF} +end; + +procedure TfrxPreview.Lock; +begin + FLocked := True; + FWorkspace.Locked := True; + FThumbnail.Locked := True; +end; + +procedure TfrxPreview.Unlock; +begin + HideMessage; + FLocked := False; + FWorkspace.Locked := False; + FThumbnail.Locked := False; + UpdatePages; + FWorkspace.Repaint; + FThumbnail.Repaint; +end; + +{$IFDEF FR_COM} +function TfrxPreview.SetPosition(PageN, Top: Integer): HResult; +{$ELSE} +procedure TfrxPreview.SetPosition(PageN, Top: Integer); +{$ENDIF} +begin + if PageN > PageCount then + PageN := PageCount; + if PageN <= 0 then + PageN := 1; + FWorkspace.SetPosition(PageN, Top); +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +function TfrxPreview.GetTopPosition: Integer; +begin + Result := FWorkspace.GetTopPosition; +end; + +procedure TfrxPreview.RefreshReport; +var + hpos, vpos, pno: Integer; +begin + if not Assigned(Report) then exit; + + hpos := FWorkspace.FOffset.X; + vpos := FWorkspace.FOffset.Y; + pno := FPageNo; + + Lock; + FRefreshing := True; + try + Report.PrepareReport; + FLocked := False; + FThumbnail.Locked := False; + if pno <= PageCount then + FPageNo := pno + else + FPageNo := 1; + UpdatePages; + UpdateOutline; + finally + FRefreshing := False; + end; + + FWorkspace.FOffset.X := hpos; + FWorkspace.FOffset.Y := vpos; + FWorkspace.Locked := False; + FWorkspace.Repaint; + FThumbnail.Repaint; + if pno > PageCount then + PageNo := 1; +end; + +procedure TfrxPreview.UpdatePages; +var + PageSize: TPoint; + i: Integer; +begin + if FLocked or (PageCount = 0) then Exit; + + { clear find settings } + FAllowF3 := False; + FWorkspace.FEMFImagePage := -1; + + { calc zoom if not zmDefault} + PageSize := PreviewPages.PageSize[PageNo - 1]; + if PageSize.Y = 0 then Exit; + case FZoomMode of + zmWholePage: + begin + if PageSize.Y/ClientHeight < PageSize.X/ClientWidth then + FZoom := (FWorkspace.Width - GetSystemMetrics(SM_CXVSCROLL) - 26) / PageSize.X + else + FZoom := (FWorkspace.Height - 26) / PageSize.Y; + SetPosition(PageNo, 0); + end; + zmPageWidth: + FZoom := (FWorkspace.Width - GetSystemMetrics(SM_CXVSCROLL) - 26) / PageSize.X + end; + + FThumbnail.DoubleBuffered := True; + { fill page list and calc bounds } + FWorkspace.Zoom := FZoom; + FThumbnail.Zoom := 0.1; + FWorkspace.ClearPageList; + FThumbnail.ClearPageList; + for i := 0 to PageCount - 1 do + begin + PageSize := PreviewPages.PageSize[i]; + FWorkspace.AddPage(PageSize.X, PageSize.Y); + if not FRunning then + FThumbnail.AddPage(PageSize.X, PageSize.Y); + end; + + FWorkspace.CalcPageBounds(FWorkspace.Width - GetSystemMetrics(SM_CXVSCROLL) - 26); + if not FRunning then + FThumbnail.CalcPageBounds(FThumbnail.Width - GetSystemMetrics(SM_CXVSCROLL) - 26); + + FWorkspace.UpdateScrollBars; + FThumbnail.UpdateScrollBars; + { avoid positioning errors when resizing } + FWorkspace.HorzPosition := FWorkspace.HorzPosition; + FWorkspace.VertPosition := FWorkspace.VertPosition; + + if not FRefreshing then + begin + FWorkspace.Repaint; + FThumbnail.Repaint; + end; + + if Owner is TfrxPreviewForm then + TfrxPreviewForm(Owner).UpdateZoom; + FThumbnail.DoubleBuffered := False; +end; + +procedure TfrxPreview.UpdateOutline; +var + Outline: TfrxCustomOutline; + + procedure DoUpdate(RootNode: TTreeNode); + var + i, n: Integer; + Node: TTreeNode; + Page, Top: Integer; + Text: String; + begin + n := Outline.Count; + for i := 0 to n - 1 do + begin + Outline.GetItem(i, Text, Page, Top); + Node := FOutline.Items.AddChild(RootNode, Text); + Node.ImageIndex := Page + 1; + Node.StateIndex := Top; + + Outline.LevelDown(i); + DoUpdate(Node); + Outline.LevelUp; + end; + end; + +begin + FOutline.Items.BeginUpdate; + FOutline.Items.Clear; + Outline := Report.PreviewPages.Outline; + Outline.LevelRoot; + DoUpdate(nil); + if Report.PreviewOptions.OutlineExpand then + FOutline.FullExpand; + if FOutline.Items.Count > 0 then + FOutline.TopItem := FOutline.Items[0]; + FOutline.Items.EndUpdate; +end; + +procedure TfrxPreview.OnOutlineClick(Sender: TObject); +var + Node: TTreeNode; + PageN, Top: Integer; +begin + Node := FOutline.Selected; + if Node = nil then Exit; + + PageN := Node.ImageIndex; + Top := Node.StateIndex; + + SetPosition(PageN, Top); + SetFocus; +end; + +procedure TfrxPreview.InternalOnProgressStart(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); +begin + if FRefreshing then Exit; + + Clear; + Report.DrillState.Clear; + FRunning := True; + if Owner is TfrxPreviewForm then + TfrxPreviewForm(Owner).UpdateControls; +end; + +procedure TfrxPreview.InternalOnProgress(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); +var + PageSize: TPoint; +begin + if FRefreshing then + begin + UpdatePageNumbers; + Exit; + end; + + if Report.Engine.FinalPass then + begin + PageSize := Report.PreviewPages.PageSize[Progress]; + if Progress < 50 then + begin + FWorkspace.AddPage(PageSize.X, PageSize.Y); + FWorkspace.CalcPageBounds(FWorkspace.Width - GetSystemMetrics(SM_CXVSCROLL) - 26); + end; + end; + + if Progress = 0 then + begin + PageNo := 1; + if Report.Engine.FinalPass then + UpdatePages; + if Owner is TfrxPreviewForm then + TfrxPreviewForm(Owner).CancelB.Caption := frxResources.Get('clCancel'); + FTick := GetTickCount; + end + else if Progress = 1 then + begin + FTick := GetTickCount - FTick; + if FTick < 5 then + FTick := 50 + else if FTick < 10 then + FTick := 20 + else + FTick := 5; + PageNo := 1; + if Report.Engine.FinalPass then + UpdatePages; + end + else if Progress mod Integer(FTick) = 0 then + begin + UpdatePageNumbers; + if Report.Engine.FinalPass then + FWorkspace.UpdateScrollBars; + end; + + Application.ProcessMessages; +end; + +procedure TfrxPreview.InternalOnProgressStop(Sender: TfrxReport; + ProgressType: TfrxProgressType; Progress: Integer); +begin + if FRefreshing then Exit; + + FRunning := False; + UpdatePageNumbers; + FWorkspace.UpdateScrollBars; + FThumbnail.UpdateScrollBars; + UpdatePages; + UpdateOutline; + if Owner is TfrxPreviewForm then + begin + TfrxPreviewForm(Owner).CancelB.Caption := frxResources.Get('clClose'); + TfrxPreviewForm(Owner).StatusBar.Panels[1].Text := ''; + TfrxPreviewForm(Owner).UpdateControls; + end; +end; + +procedure TfrxPreview.OnCancel(Sender: TObject); +begin + Report.Terminated := True; +end; + +{$IFDEF FR_COM} +function TfrxPreview.Cancel: HResult; +{$ELSE} +procedure TfrxPreview.Cancel; +{$ENDIF} +begin + if FRunning then + OnCancel(Self); +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.MouseWheelScroll(Delta: Integer; Horz: WordBool; Zoom: WordBool): HResult; stdcall; +{$ELSE} +procedure TfrxPreview.MouseWheelScroll(Delta: Integer; Horz: Boolean = False; + Zoom: Boolean = False); +{$ENDIF} +begin + if Delta <> 0 then + if Zoom then + begin + FZoom := FZoom + Round(Delta / Abs(Delta)) / 10; + if FZoom < 0.3 then + FZoom := 0.3; + SetZoom(FZoom); + end + else + begin + with FWorkspace do + begin + if Horz then + HorzPosition := HorzPosition + Round(-Delta / Abs(Delta)) * 20 + else + VertPosition := VertPosition + Round(-Delta / Abs(Delta)) * 20; + end; + end; +{$IFDEF FR_COM} + Result := S_OK; +{$ENDIF} +end; + +{$IFDEF FR_COM} +function TfrxPreview.LoadPreparedReportFromFile(const FileName: WideString): HResult; stdcall; +begin + Result := S_OK; + try + LoadFromFile(FileName); + except + Result := E_INVALIDARG; + end; +end; + +function TfrxPreview.SavePreparedReportToFile(const FileName: WideString): HResult; stdcall; +begin + Result := S_OK; + try + SaveToFile(FileName); + except + Result := E_INVALIDARG; + end; +end; + +function TfrxPreview.Get_FullScreen(out Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + Value := TfrxPreviewForm(Owner).FFullScreen; + Result := S_OK; + end else Result := E_FAIL; +end; + +function TfrxPreview.Set_FullScreen(Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + if TfrxPreviewForm(Owner).FFullScreen <> Value then + TfrxPreviewForm(Owner).SwitchToFullScreen; + Result := S_OK; + end + else + Result := E_FAIL; +end; + +function TfrxPreview.Get_ToolBarVisible(out Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + Value := TfrxPreviewForm(Owner).ToolBar.Visible; + Result := S_OK; + end + else + Result := E_FAIL; +end; + +function TfrxPreview.Set_ToolBarVisible(Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + TfrxPreviewForm(Owner).ToolBar.Visible := Value; + Result := S_OK; + end + else + Result := E_FAIL; +end; + +function TfrxPreview.Get_StatusBarVisible(out Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + Value := TfrxPreviewForm(Owner).StatusBar.Visible; + Result := S_OK; + end + else + Result := E_FAIL; +end; + +function TfrxPreview.Set_StatusBarVisible(Value: WordBool): HResult; stdcall; +begin + if Owner is TfrxPreviewForm then + begin + TfrxPreviewForm(Owner).StatusBar.Visible := Value; + Result := S_OK; + end + else + Result := E_FAIL; +end; + + +function TfrxPreview.Get_PageCount(out Value: Integer): HResult; stdcall; +begin + Value := PageCount; + Result := S_OK; +end; + +function TfrxPreview.Get_PageNo(out Value: Integer): HResult; stdcall; +begin + Value := PageNo; + Result := S_OK; +end; + +function TfrxPreview.Set_PageNo(Value: Integer): HResult; stdcall; +begin + PageNo := Value; + Result := S_OK; +end; + +function TfrxPreview.Get_Tool(out Value: frxPreviewTool): HResult; stdcall; +begin + Value := frxPreviewTool(Tool); + Result := S_OK; +end; + +function TfrxPreview.Set_Tool(Value: frxPreviewTool): HResult; stdcall; +begin + Tool := TfrxPreviewTool(Value); + Result := S_OK; +end; + +function TfrxPreview.Get_Zoom(out Value: Double): HResult; stdcall; +begin + Value := Zoom; + Result := S_OK; +end; + +function TfrxPreview.Set_Zoom(Value: Double): HResult; stdcall; +begin + Zoom := Value; + Result := S_OK; +end; + +function TfrxPreview.Get_ZoomMode(out Value: frxZoomMode): HResult; stdcall; +begin + Value := frxZoomMode(ZoomMode); + Result := S_OK; +end; + +function TfrxPreview.Set_ZoomMode(Value: frxZoomMode): HResult; stdcall; +begin + ZoomMode := TfrxZoomMode(Value); + Result := S_OK; +end; + +function TfrxPreview.Get_OutlineVisible(out Value: WordBool): HResult; stdcall; +begin + Value := OutlineVisible; + Result := S_OK; +end; + +function TfrxPreview.Set_OutlineVisible(Value: WordBool): HResult; stdcall; +begin + OutlineVisible := Value; + Result := S_OK; +end; + +function TfrxPreview.Get_OutlineWidth(out Value: Integer): HResult; stdcall; +begin + Value := OutlineWidth; + Result := S_OK; +end; + +function TfrxPreview.Set_OutlineWidth(Value: Integer): HResult; stdcall; +begin + OutlineWidth := Value; + Result := S_OK; +end; + +function TfrxPreview.Get_Enabled(out Value: WordBool): HResult; stdcall; +begin + Value := Enabled; + Result := S_OK; +end; + +function TfrxPreview.Set_Enabled(Value: WordBool): HResult; stdcall; +begin + Enabled := Value; + Result := S_OK; +end; +{$ENDIF} + + +{ TfrxPreviewForm } + +procedure TfrxPreviewForm.FormCreate(Sender: TObject); +begin +{$IFDEF FR_COM} + Icon.Handle := LoadIcon(hInstance, 'SDESGNICON'); +{$ENDIF} + FStatusBarOldWindowProc := StatusBar.WindowProc; + StatusBar.WindowProc := StatusBarWndProc; + Caption := frxGet(100); + PrintB.Caption := frxGet(101); + PrintB.Hint := frxGet(102); + OpenB.Caption := frxGet(103); + OpenB.Hint := frxGet(104); + SaveB.Caption := frxGet(105); + SaveB.Hint := frxGet(106); + ExportB.Caption := frxGet(107); + ExportB.Hint := frxGet(108); + FindB.Caption := frxGet(109); + FindB.Hint := frxGet(110); + ZoomCB.Hint := frxGet(119); + PageSettingsB.Caption := frxGet(120); + PageSettingsB.Hint := frxGet(121); + DesignerB.Caption := frxGet(132); + DesignerB.Hint := frxGet(133); + {$IFDEF FR_LITE} + DesignerB.Hint := DesignerB.Hint + #13#10 + 'This feature is not available in FreeReport'; + {$ENDIF} + FirstB.Caption := frxGet(134); + FirstB.Hint := frxGet(135); + PriorB.Caption := frxGet(136); + PriorB.Hint := frxGet(137); + NextB.Caption := frxGet(138); + NextB.Hint := frxGet(139); + LastB.Caption := frxGet(140); + LastB.Hint := frxGet(141); + CancelB.Caption := frxResources.Get('clClose'); + PageE.Hint := frxGet(142); + FullScreenBtn.Hint := frxGet(150); + PdfB.Hint := frxGet(151); + EmailB.Hint := frxGet(152); + ZoomPlusB.Caption := frxGet(124); + ZoomPlusB.Hint := frxGet(125); + ZoomMinusB.Caption := frxGet(126); + ZoomMinusB.Hint := frxGet(127); + OutlineB.Caption := frxGet(128); + OutlineB.Hint := frxGet(129); + ThumbB.Caption := frxGet(130); + ThumbB.Hint := frxGet(131); + ZoomCB.Items.Clear; + ZoomCB.Items.Add('25%'); + ZoomCB.Items.Add('50%'); + ZoomCB.Items.Add('75%'); + ZoomCB.Items.Add('100%'); + ZoomCB.Items.Add('150%'); + ZoomCB.Items.Add('200%'); + ZoomCB.Items.Add(frxResources.Get('zmPageWidth')); + ZoomCB.Items.Add(frxResources.Get('zmWholePage')); + Toolbar.Images := frxResources.PreviewButtonImages; + ExpandMI.Caption := frxGet(600); + CollapseMI.Caption := frxGet(601); + + FPreview := TfrxPreview.Create(Self); + FPreview.Parent := Self; + FPreview.Align := alClient; + FPreview.BorderStyle := bsNone; + FPreview.BevelKind := bkNone; + FPreview.OnPageChanged := OnPageChanged; + FPreview.OnDblClick := OnPreviewDblClick; + ActiveControl := FPreview; + SetWindowLong(PageE.Handle, GWL_STYLE, GetWindowLong(PageE.Handle, GWL_STYLE) or ES_NUMBER); +{$IFDEF Delphi10} + frTBPanel1.ParentBackground := False; + Sep3.ParentBackground := False; + Sep4.ParentBackground := False; +{$ENDIF} + + if Screen.PixelsPerInch > 96 then + StatusBar.Height := 24; + + FFullScreen := False; + FPDFExport := nil; + FEmailExport := nil; +end; + +procedure TfrxPreviewForm.Init; +var + i, j, k: Integer; + m, e: TMenuItem; +begin + FPreview.Init; + with Report.PreviewOptions do + begin + if Maximized then + WindowState := wsMaximized; + if MDIChild then + FormStyle := fsMDIChild; + FPreview.Zoom := Zoom; + FPreview.ZoomMode := ZoomMode; + + {$IFDEF FR_LITE} + DesignerB.Enabled := False; + {$ELSE} + DesignerB.Enabled := AllowEdit; + {$ENDIF} + Preview.Workspace.RTLLanguage := RTLPreview; + PrintB.Visible := pbPrint in Buttons; + OpenB.Visible := pbLoad in Buttons; + SaveB.Visible := pbSave in Buttons; + ExportB.Visible := pbExport in Buttons; + FindB.Visible := pbFind in Buttons; + PdfB.Visible := False; + EmailB.Visible := False; + + ZoomPlusB.Visible := pbZoom in Buttons; + ZoomMinusB.Visible := pbZoom in Buttons; + Sep3.Visible := pbZoom in Buttons; + FullScreenBtn.Visible := (pbZoom in Buttons) and not (pbNoFullScreen in Buttons); + if not (pbZoom in Buttons) then + Sep1.Visible := False; + + OutlineB.Visible := pbOutline in Buttons; + ThumbB.Visible := pbOutline in Buttons; + PageSettingsB.Visible := pbPageSetup in Buttons; + DesignerB.Visible := pbEdit in Buttons; + if not (PageSettingsB.Visible or DesignerB.Visible) then + Sep2.Visible := False; + + FirstB.Visible := pbNavigator in Buttons; + PriorB.Visible := pbNavigator in Buttons; + NextB.Visible := pbNavigator in Buttons; + LastB.Visible := pbNavigator in Buttons; + Sep4.Visible := pbNavigator in Buttons; + if not (pbNavigator in Buttons) then + Sep5.Visible := False; + + CancelB.Visible := not (pbNoClose in Buttons); + + Toolbar.ShowCaptions := ShowCaptions; + end; + + if (frxExportFilters.Count = 0) or + ((frxExportFilters.Count = 1) and (frxExportFilters[0].Filter = frxDotMatrixExport)) then + ExportB.Visible := False; + + for i := 0 to frxExportFilters.Count - 1 do + begin + if frxExportFilters[i].Filter = frxDotMatrixExport then + continue; + m := TMenuItem.Create(ExportPopup); + ExportPopup.Items.Add(m); + m.Caption := TfrxCustomExportFilter(frxExportFilters[i].Filter).GetDescription + '...'; + m.Tag := i; + m.OnClick := ExportMIClick; + if TfrxCustomExportFilter(frxExportFilters[i].Filter).ClassName = 'TfrxPDFExport' then + begin + FPDFExport := TfrxCustomExportFilter(frxExportFilters[i].Filter); + PdfB.Visible := pbExportQuick in Report.PreviewOptions.Buttons; + end; + if not (pbNoEmail in Report.PreviewOptions.Buttons) then + begin + if TfrxCustomExportFilter(frxExportFilters[i].Filter).ClassName = 'TfrxMailExport' then + begin + FEmailExport := TfrxCustomExportFilter(frxExportFilters[i].Filter); + EmailB.Visible := pbExportQuick in Report.PreviewOptions.Buttons; + end; + end + else EmailB.Visible := False; + end; + + if Report.ReportOptions.Name <> '' then + Caption := Report.ReportOptions.Name; + + k := 0; + + RightMenu.Images := ToolBar.Images; + for i := 0 to ToolBar.ButtonCount - 1 do + begin + if (ToolBar.Buttons[i].Style <> tbsCheck) and + (ToolBar.Buttons[i].Visible) and + (ToolBar.Buttons[i].Hint <> '') then + begin + m := TMenuItem.Create(RightMenu); + RightMenu.Items.Add(m); + ToolBar.Buttons[i].Tag := Integer(m); + m.Caption := ToolBar.Buttons[i].Hint; + m.OnClick := ToolBar.Buttons[i].OnClick; + m.ImageIndex := ToolBar.Buttons[i].ImageIndex; + if Assigned(ToolBar.Buttons[i].DropdownMenu) then + for j := 0 to ToolBar.Buttons[i].DropdownMenu.Items.Count - 1 do + begin + e := TMenuItem.Create(m); + e.Caption := ToolBar.Buttons[i].DropdownMenu.Items[j].Caption; + e.Tag := ToolBar.Buttons[i].DropdownMenu.Items[j].Tag; + e.OnClick := ToolBar.Buttons[i].DropdownMenu.Items[j].OnClick; + m.Add(e); + end; + end; + if ToolBar.Buttons[i].Style = tbsSeparator then + begin + if k = 1 then + break; + m := TMenuItem.Create(RightMenu); + RightMenu.Items.Add(m); + m.Caption := '-'; + Inc(k); + end; + end; + + if UseRightToLeftAlignment then + FlipChildren(True); + + UpdateControls; + PopupMenu := RightMenu; +end; + +procedure TfrxPreviewForm.UpdateControls; + + function HasDrillDown: Boolean; + var + l: TList; + i: Integer; + c: TfrxComponent; + begin + Result := False; + l := Report.AllObjects; + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if (c is TfrxGroupHeader) and TfrxGroupHeader(c).DrillDown then + begin + Result := True; + break; + end; + end; + end; + + procedure EnableControls(cAr: array of TObject; Enabled: Boolean); + var + i: Integer; + begin + for i := 0 to High(cAr) do + begin + if cAr[i] is TMenuItem then + TMenuItem(cAr[i]).Visible := Enabled + else if cAr[i] is TToolButton then + begin + TToolButton(cAr[i]).Enabled := Enabled; + TToolButton(cAr[i]).Down := False; + if TToolButton(cAr[i]).Tag <> 0 then + TMenuItem(TToolButton(cAr[i]).Tag).Enabled := Enabled; + end; + end; + end; + +begin + EnableControls([PrintB, OpenB, SaveB, ExportB, PdfB, EmailB, FindB, PageSettingsB], + (not FPreview.FRunning) and (FPreview.PageCount > 0)); + EnableControls([DesignerB], + not FPreview.FRunning and Report.PreviewOptions.AllowEdit); + EnableControls([ExpandMI, CollapseMI, N1], + not FPreview.FRunning and HasDrillDown); +end; + +procedure TfrxPreviewForm.PrintBClick(Sender: TObject); +begin + FPreview.Print; + Enabled := True; +end; + +procedure TfrxPreviewForm.OpenBClick(Sender: TObject); +begin + FPreview.LoadFromFile; + if Report.ReportOptions.Name <> '' then + Caption := Report.ReportOptions.Name + else + Caption := frxGet(100); +end; + +procedure TfrxPreviewForm.SaveBClick(Sender: TObject); +begin + FPreview.SaveToFile; +end; + +procedure TfrxPreviewForm.FindBClick(Sender: TObject); +begin + FPreview.Find; +end; + +procedure TfrxPreviewForm.ZoomPlusBClick(Sender: TObject); +begin + FPreview.Zoom := FPreview.Zoom + 0.25; +end; + +procedure TfrxPreviewForm.ZoomMinusBClick(Sender: TObject); +begin + FPreview.Zoom := FPreview.Zoom - 0.25; +end; + +function TfrxPreviewForm.GetReport: TfrxReport; +begin + Result := Preview.Report; +end; + +procedure TfrxPreviewForm.UpdateZoom; +begin + ZoomCB.Text := IntToStr(Round(FPreview.Zoom * 100)) + '%'; +end; + +procedure TfrxPreviewForm.ZoomCBClick(Sender: TObject); +var + s: String; +begin + FPreview.SetFocus; + + if ZoomCB.ItemIndex = 6 then + FPreview.ZoomMode := zmPageWidth + else if ZoomCB.ItemIndex = 7 then + FPreview.ZoomMode := zmWholePage + else + begin + s := ZoomCB.Text; + + if Pos('%', s) <> 0 then + s[Pos('%', s)] := ' '; + while Pos(' ', s) <> 0 do + Delete(s, Pos(' ', s), 1); + + if s <> '' then + FPreview.Zoom := frxStrToFloat(s) / 100; + end; + + PostMessage(Handle, WM_UPDATEZOOM, 0, 0); +end; + +procedure TfrxPreviewForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_ESCAPE then + CancelBClick(Self); + if Key = VK_F11 then + SwitchToFullScreen; + if Key = VK_F1 then + frxResources.Help(Self); +end; + +procedure TfrxPreviewForm.FormKeyPress(Sender: TObject; var Key: Char); +begin + if Key = #13 then + begin + if ActiveControl = ZoomCB then + ZoomCBClick(nil); + if ActiveControl = PageE then + PageEClick(nil); + end; +end; + +procedure TfrxPreviewForm.WMUpdateZoom(var Message: TMessage); +begin + UpdateZoom; +end; + +procedure TfrxPreviewForm.PageSettingsBClick(Sender: TObject); +begin + FPreview.PageSetupDlg; +end; + +procedure TfrxPreviewForm.OnPageChanged(Sender: TfrxPreview; PageNo: Integer); +var + FirstPass: Boolean; +begin + FirstPass := False; + if FPreview.PreviewPages <> nil then + FirstPass := not FPreview.PreviewPages.Engine.FinalPass; + + if FirstPass and FPreview.FRunning then + StatusBar.Panels[0].Text := frxResources.Get('clFirstPass') + ' ' + + IntToStr(FPreview.PageCount) + else + StatusBar.Panels[0].Text := Format(frxResources.Get('clPageOf'), + [PageNo, FPreview.PageCount]); + PageE.Text := IntToStr(PageNo); +end; + +procedure TfrxPreviewForm.PageEClick(Sender: TObject); +begin + FPreview.PageNo := StrToInt(PageE.Text); + FPreview.SetFocus; +end; + +procedure TfrxPreviewForm.FirstBClick(Sender: TObject); +begin + FPreview.First; +end; + +procedure TfrxPreviewForm.PriorBClick(Sender: TObject); +begin + FPreview.Prior; +end; + +procedure TfrxPreviewForm.NextBClick(Sender: TObject); +begin + FPreview.Next; +end; + +procedure TfrxPreviewForm.LastBClick(Sender: TObject); +begin + FPreview.Last; +end; + +procedure TfrxPreviewForm.FormMouseWheel(Sender: TObject; + Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; + var Handled: Boolean); +begin + FPreview.MouseWheelScroll(WheelDelta, False, ssCtrl in Shift); +end; + +procedure TfrxPreviewForm.DesignerBClick(Sender: TObject); +begin + FPreview.Edit; +end; + +procedure TfrxPreviewForm.FormCloseQuery(Sender: TObject; + var CanClose: Boolean); +begin + CanClose := not FPreview.FRunning; +end; + +procedure TfrxPreviewForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + if FFreeOnClose then + Action := caFree; + if (Report <> nil) and (Assigned(Report.OnClosePreview)) then + Report.OnClosePreview(Self); +end; + +procedure TfrxPreviewForm.NewPageBClick(Sender: TObject); +begin + FPreview.AddPage; +end; + +procedure TfrxPreviewForm.DelPageBClick(Sender: TObject); +begin + FPreview.DeletePage; +end; + +procedure TfrxPreviewForm.CancelBClick(Sender: TObject); +begin + if FPreview.FRunning then + FPreview.Cancel else + Close; +end; + +procedure TfrxPreviewForm.ExportMIClick(Sender: TObject); +begin + FPreview.Export(TfrxCustomExportFilter(frxExportFilters[TMenuItem(Sender).Tag].Filter)); + Enabled := True; +end; + +procedure TfrxPreviewForm.DesignerBMouseUp(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + pt: TPoint; +begin + pt := DesignerB.ClientToScreen(Point(0, 0)); + if Button = mbRight then + HiddenMenu.Popup(pt.X, pt.Y); +end; + +procedure TfrxPreviewForm.Showtemplate1Click(Sender: TObject); +begin + FPreview.EditTemplate; +end; + +procedure TfrxPreviewForm.SetMessageText(const Value: String; IsHint: Boolean); +begin + if IsHint then + begin + if not ((Value = '') and (StatusBar.Panels[2].Text = '')) then + StatusBar.Panels[2].Text := Value; + end + else + StatusBar.Panels[1].Text := Value; + Application.ProcessMessages; +end; + +procedure TfrxPreviewForm.SwitchToFullScreen; +begin + if not FFullScreen then + begin + StatusBar.Visible := False; + ToolBar.Visible := False; + FOldBS := BorderStyle; + FOldState := WindowState; + BorderStyle := bsNone; + WindowState := wsMaximized; + FFullScreen := True; + end + else + begin + WindowState := FOldState; + BorderStyle := FOldBS; + FFullScreen := False; + StatusBar.Visible := True; + ToolBar.Visible := True; + end; +end; + +procedure TfrxPreviewForm.FullScreenBtnClick(Sender: TObject); +begin + SwitchToFullScreen; +end; + +procedure TfrxPreviewForm.PdfBClick(Sender: TObject); +begin + if Assigned(FPDFExport) then + FPreview.Export(FPDFExport); +end; + +procedure TfrxPreviewForm.EmailBClick(Sender: TObject); +begin + if Assigned(FEmailExport) then + FPreview.Export(FEmailExport); +end; + +procedure TfrxPreviewForm.WMActivateApp(var Msg: TWMActivateApp); +begin + if IsIconic(Application.Handle) then + begin + ShowWindow(Application.Handle, SW_RESTORE); + SetActiveWindow(Handle); + end; + inherited; +end; + +procedure TfrxPreviewForm.WMSysCommand(var Msg: TWMSysCommand); +begin + if Msg.CmdType = SC_MINIMIZE then + if not Report.PreviewOptions.MDIChild and Report.PreviewOptions.Modal then + ShowWindow(Application.Handle, SW_MINIMIZE) + else + inherited + else + inherited; +end; + +procedure TfrxPreviewForm.StatusBarWndProc(var Message: TMessage); +begin + if Message.Msg = WM_SYSCOLORCHANGE then + DefWindowProc(StatusBar.Handle,Message.Msg,Message.WParam,Message.LParam) + else + FStatusBarOldWindowProc(Message); +end; + +procedure TfrxPreviewForm.OutlineBClick(Sender: TObject); +begin + FPreview.OutlineVisible := OutlineB.Down; +end; + +procedure TfrxPreviewForm.ThumbBClick(Sender: TObject); +begin + FPreview.ThumbnailVisible := ThumbB.Down; +end; + +procedure TfrxPreviewForm.OnPreviewDblClick(Sender: TObject); +begin + if FFullScreen then + SwitchToFullScreen; +end; + +procedure TfrxPreviewForm.CollapseAllClick(Sender: TObject); +var + l: TList; + i: Integer; + c: TfrxComponent; +begin + FPreview.Lock; + l := Report.AllObjects; + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if (c is TfrxGroupHeader) and TfrxGroupHeader(c).DrillDown then + TfrxGroupHeader(c).ExpandDrillDown := False; + end; + Report.DrillState.Clear; + Preview.RefreshReport; + Preview.SetPosition(0,0); +end; + +procedure TfrxPreviewForm.ExpandAllClick(Sender: TObject); +var + l: TList; + i: Integer; + c: TfrxComponent; +begin + FPreview.Lock; + l := Report.AllObjects; + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if (c is TfrxGroupHeader) and TfrxGroupHeader(c).DrillDown then + TfrxGroupHeader(c).ExpandDrillDown := True; + end; + Report.DrillState.Clear; + Preview.RefreshReport; +end; + +procedure TfrxPreviewForm.FormResize(Sender: TObject); +var + Sz: Integer; +begin + Sz := Round((Self.ClientWidth - StatusBar.Panels[0].Width)/2); + StatusBar.Panels[1].Width := Sz; + StatusBar.Panels[2].Width := Sz; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPreview.res b/official/4.8.11/Source/frxPreview.res new file mode 100644 index 0000000..358bacf Binary files /dev/null and b/official/4.8.11/Source/frxPreview.res differ diff --git a/official/4.8.11/Source/frxPreviewPageSettings.dfm b/official/4.8.11/Source/frxPreviewPageSettings.dfm new file mode 100644 index 0000000..a88bcab Binary files /dev/null and b/official/4.8.11/Source/frxPreviewPageSettings.dfm differ diff --git a/official/4.8.11/Source/frxPreviewPageSettings.pas b/official/4.8.11/Source/frxPreviewPageSettings.pas new file mode 100644 index 0000000..76f7455 --- /dev/null +++ b/official/4.8.11/Source/frxPreviewPageSettings.pas @@ -0,0 +1,257 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Preview Page settings } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPreviewPageSettings; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, frxClass +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TfrxDesignerUnits = (duCM, duInches, duPixels, duChars); + + TfrxPageSettingsForm = class(TForm) + OKB: TButton; + CancelB: TButton; + SizeL: TGroupBox; + WidthL: TLabel; + HeightL: TLabel; + UnitL1: TLabel; + UnitL2: TLabel; + WidthE: TEdit; + HeightE: TEdit; + SizeCB: TComboBox; + OrientationL: TGroupBox; + PortraitImg: TImage; + LandscapeImg: TImage; + PortraitRB: TRadioButton; + LandscapeRB: TRadioButton; + MarginsL: TGroupBox; + LeftL: TLabel; + TopL: TLabel; + RightL: TLabel; + BottomL: TLabel; + UnitL3: TLabel; + UnitL4: TLabel; + UnitL5: TLabel; + UnitL6: TLabel; + MarginLeftE: TEdit; + MarginTopE: TEdit; + MarginRightE: TEdit; + MarginBottomE: TEdit; + OtherL: TGroupBox; + ApplyToCurRB: TRadioButton; + ApplyToAllRB: TRadioButton; + procedure FormShow(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure PortraitRBClick(Sender: TObject); + procedure SizeCBClick(Sender: TObject); + procedure WidthEChange(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + protected + { Private declarations } + FPage: TfrxReportPage; + FReport: TfrxReport; + FUnits: TfrxDesignerUnits; + FUpdating: Boolean; + function GetNeedRebuild: Boolean; + function mmToUnits(mm: Extended): Extended; + function UnitsTomm(mm: Extended): Extended; + public + { Public declarations } + property NeedRebuild: Boolean read GetNeedRebuild; + property Page: TfrxReportPage read FPage write FPage; + property Report: TfrxReport read FReport write FReport; + end; + + +implementation + +{$R *.DFM} + +uses Printers, frxPrinter, frxUtils, frxRes, IniFiles; + + +function TfrxPageSettingsForm.mmToUnits(mm: Extended): Extended; +begin + Result := 0; + case FUnits of + duCM, duPixels, duChars: + Result := mm / 10; + duInches: + Result := mm / 25.4; + end; +end; + +function TfrxPageSettingsForm.UnitsTomm(mm: Extended): Extended; +begin + Result := 0; + case FUnits of + duCM, duPixels, duChars: + Result := mm * 10; + duInches: + Result := mm * 25.4; + end; +end; + +function TfrxPageSettingsForm.GetNeedRebuild: Boolean; +begin + Result := ApplyToAllRB.Checked; +end; + +procedure TfrxPageSettingsForm.FormShow(Sender: TObject); +var + i: Integer; + Ini: TCustomIniFile; + uStr: String; +begin + FUpdating := True; + + Caption := frxGet(400); + WidthL.Caption := frxGet(401); + HeightL.Caption := frxGet(402); + SizeL.Caption := frxGet(403); + OrientationL.Caption := frxGet(404); + LeftL.Caption := frxGet(405); + TopL.Caption := frxGet(406); + RightL.Caption := frxGet(407); + BottomL.Caption := frxGet(408); + MarginsL.Caption := frxGet(409); + PortraitRB.Caption := frxGet(410); + LandscapeRB.Caption := frxGet(411); + OKB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + OtherL.Caption := frxGet(412); + ApplyToCurRB.Caption := frxGet(413); + ApplyToAllRB.Caption := frxGet(414); + + Ini := Report.GetIniFile; + FUnits := TfrxDesignerUnits(Ini.ReadInteger('Form.TfrxDesignerForm', 'Units', 0)); + Ini.Free; + + uStr := ''; + case FUnits of + duCM, duPixels, duChars: + uStr := frxResources.Get('uCm'); + duInches: + uStr := frxResources.Get('uInch'); + end; + + UnitL1.Caption := uStr; + UnitL2.Caption := uStr; + UnitL3.Caption := uStr; + UnitL4.Caption := uStr; + UnitL5.Caption := uStr; + UnitL6.Caption := uStr; + + SizeCB.Items := frxPrinters.Printer.Papers; + i := frxPrinters.Printer.PaperIndex(Page.PaperSize); + if i = -1 then + i := frxPrinters.Printer.PaperIndex(256); + SizeCB.ItemIndex := i; + + WidthE.Text := frxFloatToStr(mmToUnits(Page.PaperWidth)); + HeightE.Text := frxFloatToStr(mmToUnits(Page.PaperHeight)); + PortraitRB.Checked := Page.Orientation = poPortrait; + LandscapeRB.Checked := Page.Orientation = poLandscape; + + MarginLeftE.Text := frxFloatToStr(mmToUnits(Page.LeftMargin)); + MarginRightE.Text := frxFloatToStr(mmToUnits(Page.RightMargin)); + MarginTopE.Text := frxFloatToStr(mmToUnits(Page.TopMargin)); + MarginBottomE.Text := frxFloatToStr(mmToUnits(Page.BottomMargin)); + + PortraitRBClick(nil); + FUpdating := False; +end; + +procedure TfrxPageSettingsForm.FormHide(Sender: TObject); +begin + if ModalResult = mrOk then + begin + if PortraitRB.Checked then + Page.Orientation := poPortrait else + Page.Orientation := poLandscape; + + Page.PaperWidth := UnitsTomm(frxStrToFloat(WidthE.Text)); + Page.PaperHeight := UnitsTomm(frxStrToFloat(HeightE.Text)); + Page.PaperSize := frxPrinters.Printer.PaperNameToNumber(SizeCB.Text); + + Page.LeftMargin := UnitsTomm(frxStrToFloat(MarginLeftE.Text)); + Page.RightMargin := UnitsTomm(frxStrToFloat(MarginRightE.Text)); + Page.TopMargin := UnitsTomm(frxStrToFloat(MarginTopE.Text)); + Page.BottomMargin := UnitsTomm(frxStrToFloat(MarginBottomE.Text)); + + Page.AlignChildren; + end; +end; + +procedure TfrxPageSettingsForm.PortraitRBClick(Sender: TObject); +begin + PortraitImg.Visible := PortraitRB.Checked; + LandscapeImg.Visible := LandscapeRB.Checked; + SizeCBClick(nil); +end; + +procedure TfrxPageSettingsForm.SizeCBClick(Sender: TObject); +var + pOr: TPrinterOrientation; + pNumber: Integer; + pWidth, pHeight: Extended; +begin + if FUpdating then Exit; + FUpdating := True; + + with frxPrinters.Printer do + begin + pNumber := PaperNameToNumber(SizeCB.Text); + pWidth := UnitsTomm(frxStrToFloat(WidthE.Text)); + pHeight := UnitsTomm(frxStrToFloat(HeightE.Text)); + if PortraitRB.Checked then + pOr := poPortrait else + pOr := poLandscape; + + if pNumber = 256 then + SetViewParams(pNumber, pHeight, pWidth, pOr) else + SetViewParams(pNumber, pWidth, pHeight, pOr); + + WidthE.Text := frxFloatToStr(mmToUnits(PaperWidth)); + HeightE.Text := frxFloatToStr(mmToUnits(PaperHeight)); + end; + + FUpdating := False; +end; + +procedure TfrxPageSettingsForm.WidthEChange(Sender: TObject); +begin + if not FUpdating then + SizeCB.ItemIndex := 0; +end; + +procedure TfrxPageSettingsForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPreviewPages.pas b/official/4.8.11/Source/frxPreviewPages.pas new file mode 100644 index 0000000..b7c7fa6 --- /dev/null +++ b/official/4.8.11/Source/frxPreviewPages.pas @@ -0,0 +1,2457 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Preview Pages } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPreviewPages; + +interface + +{$I frx.inc} + +uses + Windows, SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, + frxClass, frxXML, frxPictureCache +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxOutline = class(TfrxCustomOutline) + private + protected + function GetCount: Integer; override; + public + function Root: TfrxXMLItem; + procedure AddItem(const Text: String; Top: Integer); override; + procedure LevelDown(Index: Integer); override; + procedure LevelRoot; override; + procedure LevelUp; override; + procedure GetItem(Index: Integer; var Text: String; + var Page, Top: Integer); override; + procedure ShiftItems(From: TfrxXMLItem; NewTop: Integer); override; + function GetCurPosition: TfrxXMLItem; override; + end; + + TfrxDictionary = class(TObject) + private + FNames: TStringList; + FSourceNames: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure Add(const Name, SourceName: String; Obj: TObject); + procedure Clear; + function AddUnique(const Base, SourceName: String; Obj: TObject): String; + function CreateUniqueName(const Base: String): String; + function GetSourceName(const Name: String): String; + function GetObject(const Name: String): TObject; + property Names: TStringList read FNames; + property SourceNames: TStringList read FSourceNames; + end; + + TfrxPreviewPages = class(TfrxCustomPreviewPages) + private + FAllowPartialLoading: Boolean; + FCopyNo: Integer; + FDictionary: TfrxDictionary; { list of all objects } + FFirstObjectIndex: Integer; { used in the ClearFirstPassPages } + FFirstPageIndex: Integer; { used in the ClearFirstPassPages } + FFirstOutlineIndex: Integer; { used in the ClearFirstPassPages } + FLogicalPageN: Integer; + FPageCache: TStringList; { last 20 TfrxPreviewPage } + FPagesItem: TfrxXMLItem; { shortcut to XMLDoc.Root.FindName('previewpages') } + FPictureCache: TfrxPictureCache; + FPrintScale: Extended; + FSourcePages: TList; { list of source pages } + FTempStream: TStream; + FXMLDoc: TfrxXMLDocument; { parsed FP3 document } + FXMLSize: Integer; + procedure AfterLoad; + procedure BeforeSave; + procedure ClearPageCache; + procedure ClearSourcePages; + function CurXMLPage: TfrxXMLItem; + function GetObject(const Name: String): TfrxComponent; + procedure DoLoadFromStream; + procedure DoSaveToStream; + protected + function GetCount: Integer; override; + function GetPage(Index: Integer): TfrxReportPage; override; + function GetPageSize(Index: Integer): TPoint; override; + public + constructor Create(AReport: TfrxReport); override; + destructor Destroy; override; + procedure Clear; override; + procedure Initialize; override; + + { engine commands } + procedure AddAnchor(const Text: String); + procedure AddObject(Obj: TfrxComponent); override; + procedure AddPage(Page: TfrxReportPage); override; + procedure AddPicture(Picture: TfrxPictureView); override; + procedure AddSourcePage(Page: TfrxReportPage); override; + procedure AddToSourcePage(Obj: TfrxComponent); override; + procedure BeginPass; override; + procedure ClearFirstPassPages; override; + procedure CutObjects(APosition: Integer); override; + procedure Finish; override; + procedure IncLogicalPageNumber; override; + procedure ResetLogicalPageNumber; override; + procedure PasteObjects(X, Y: Extended); override; + procedure ShiftAnchors(From, NewTop: Integer); override; + procedure UpdatePageDimensions(Page: TfrxReportPage; Width, Height: Extended); + function BandExists(Band: TfrxBand): Boolean; override; + function FindAnchor(const Text: String): TfrxXMLItem; + function GetAnchorPage(const Text: String): Integer; + function GetAnchorCurPosition: Integer; override; + function GetCurPosition: Integer; override; + function GetLastY(ColumnPosition: Extended = 0): Extended; override; + function GetLogicalPageNo: Integer; override; + function GetLogicalTotalPages: Integer; override; + + { preview commands } + procedure DrawPage(Index: Integer; Canvas: TCanvas; ScaleX, ScaleY, + OffsetX, OffsetY: Extended); override; + procedure AddEmptyPage(Index: Integer); override; + procedure DeletePage(Index: Integer); override; + procedure ModifyPage(Index: Integer; Page: TfrxReportPage); override; + procedure AddFrom(Report: TfrxReport); override; + procedure LoadFromStream(Stream: TStream; + AllowPartialLoading: Boolean = False); override; + procedure SaveToStream(Stream: TStream); override; + function LoadFromFile(const FileName: String; + ExceptionIfNotFound: Boolean = False): Boolean; override; + procedure SaveToFile(const FileName: String); override; + function Print: Boolean; override; + function Export(Filter: TfrxCustomExportFilter): Boolean; override; + procedure ObjectOver(Index: Integer; X, Y: Integer; Button: TMouseButton; + Shift: TShiftState; Scale, OffsetX, OffsetY: Extended; + Click: Boolean; var Cursor: TCursor; DBClick: Boolean = False); override; + property SourcePages: TList read FSourcePages; + end; + + +implementation + +uses + frxPreview, Printers, frxPrinter, frxPrintDialog, frxXMLSerializer, frxUtils, + ShellApi, frxDMPClass, frxRes; + +type + THackComponent = class(TfrxComponent); + THackMemoView = class(TfrxCustomMemoView); + THackThread = class(TThread); + +{$IFDEF TRIAL} +const + FR_UNREG = ')segap 5 ylno( noisrev deretsigernU - tropeRtsaF'; +{$ENDIF} + +{ TfrxOutline } + +procedure TfrxOutline.AddItem(const Text: String; Top: Integer); +begin + CurItem := CurItem.Add; + CurItem.Name := 'item'; + CurItem.Text := 'text="' + frxStrToXML(Text) + + '" page="' + IntToStr(PreviewPages.CurPage) + + '" top="' + IntToStr(Top) + '"'; +end; + +procedure TfrxOutline.GetItem(Index: Integer; var Text: String; var Page, + Top: Integer); +var + Item: TfrxXMLItem; + s: String; +begin + Item := CurItem[Index]; + Text := Item.Prop['text']; + + s := String(Item.Prop['page']); + if s <> '' then + Page := StrToInt(s); + + s := String(Item.Prop['top']); + if s <> '' then + Top := StrToInt(s); +end; + +procedure TfrxOutline.LevelDown(Index: Integer); +begin + CurItem := CurItem[Index]; +end; + +procedure TfrxOutline.LevelRoot; +begin + CurItem := Root; +end; + +procedure TfrxOutline.LevelUp; +begin + if CurItem <> Root then + CurItem := CurItem.Parent; +end; + +function TfrxOutline.Root: TfrxXMLItem; +begin + Result := TfrxPreviewPages(PreviewPages).FXMLDoc.Root.FindItem('outline'); +end; + +function TfrxOutline.GetCount: Integer; +begin + if CurItem = nil then + Result := 0 + else + Result := CurItem.Count; +end; + +procedure TfrxOutline.ShiftItems(From: TfrxXMLItem; NewTop: Integer); +var + i, TopY, CorrY: Integer; + + procedure EnumItems(Item: TfrxXMLItem); + var + i: Integer; + begin + Item.Prop['page'] := IntToStr(StrToInt(Item.Prop['page']) + 1); + Item.Prop['top'] := IntToStr(StrToInt(Item.Prop['top']) + CorrY); + for i := 0 to Item.Count - 1 do + EnumItems(Item[i]); + end; + +begin + if From = nil then Exit; + i := From.Parent.IndexOf(From); + if i + 1 >= From.Parent.Count then Exit; + From := From.Parent[i + 1]; + + TopY := StrToInt(String(From.Prop['top'])); + CorrY := NewTop - TopY; + EnumItems(From); +end; + +function TfrxOutline.GetCurPosition: TfrxXMLItem; +begin + if Count = 0 then + Result := nil else + Result := CurItem[Count - 1]; +end; + + +{ TfrxDictionary } + +constructor TfrxDictionary.Create; +begin + FNames := TStringList.Create; + FNames.Sorted := True; + FSourceNames := TStringList.Create; +end; + +destructor TfrxDictionary.Destroy; +begin + FNames.Free; + FSourceNames.Free; + inherited; +end; + +procedure TfrxDictionary.Clear; +begin + FNames.Clear; + FSourceNames.Clear; +end; + +procedure TfrxDictionary.Add(const Name, SourceName: String; Obj: TObject); +var + i: Integer; +begin + i := FSourceNames.AddObject(SourceName, Obj); + FNames.AddObject(Name, TObject(i)); +end; + +function TfrxDictionary.AddUnique(const Base, SourceName: String; Obj: TObject): String; +{$IFDEF Delphi12} +var + TempStr: String; +{$ENDIF} +begin +{$IFDEF Delphi12} + TempStr := CreateUniqueName(Base); + Add(TempStr, SourceName, Obj); + Result := TempStr; +{$ELSE} + Result := CreateUniqueName(Base); + Add(Result, SourceName, Obj); +{$ENDIF} +end; + +function TfrxDictionary.CreateUniqueName(const Base: String): String; +var + i: Integer; +begin + i := 10000; + while (i > 1) and (FNames.IndexOf(Base + IntToStr(i)) = -1) do + i := i div 2; + while FNames.IndexOf(Base + IntToStr(i)) <> -1 do + Inc(i); + Result := Base + IntToStr(i); +end; + +function TfrxDictionary.GetObject(const Name: String): TObject; +var + i: Integer; +begin + Result := nil; + i := FNames.IndexOf(Name); + if i <> -1 then + Result := FSourceNames.Objects[Integer(FNames.Objects[i])]; +end; + +function TfrxDictionary.GetSourceName(const Name: String): String; +var + i: Integer; +begin + Result := ''; + i := FNames.IndexOf(Name); + if i <> -1 then + Result := FSourceNames[Integer(FNames.Objects[i])]; +end; + + +{ TfrxPreviewPages } + +constructor TfrxPreviewPages.Create(AReport: TfrxReport); +begin + inherited; + FDictionary := TfrxDictionary.Create; + FSourcePages := TList.Create; + FXMLDoc := TfrxXMLDocument.Create; + FXMLDoc.Root.Name := 'preparedreport'; +// FXMLDoc.AutoIndent := True; + FPageCache := TStringList.Create; + FPictureCache := TfrxPictureCache.Create; +end; + +destructor TfrxPreviewPages.Destroy; +begin + ClearPageCache; + FPageCache.Free; + FDictionary.Free; + ClearSourcePages; + FPictureCache.Free; + FSourcePages.Free; + FXMLDoc.Free; + inherited; +end; + +procedure TfrxPreviewPages.Clear; +begin + ClearPageCache; + ClearSourcePages; + FXMLDoc.Clear; + FDictionary.Clear; + FPictureCache.Clear; + CurPage := -1; + FXMLSize := 0; +end; + +procedure TfrxPreviewPages.Initialize; +begin + FPictureCache.UseFileCache := Report.PreviewOptions.PictureCacheInFile; + FPictureCache.TempDir := Report.EngineOptions.TempDir; + FXMLDoc.TempDir := Report.EngineOptions.TempDir; + Report.InternalOnProgressStart(ptRunning); +end; + +procedure TfrxPreviewPages.ClearPageCache; +begin + while FPageCache.Count > 0 do + begin + TfrxReportPage(FPageCache.Objects[0]).Free; + FPageCache.Delete(0); + end; +end; + +procedure TfrxPreviewPages.ClearSourcePages; +begin + while FSourcePages.Count > 0 do + begin + TfrxReportPage(FSourcePages[0]).Free; + FSourcePages.Delete(0); + end; +end; + +procedure TfrxPreviewPages.BeginPass; +begin + FFirstPageIndex := Count - 1; + if FFirstPageIndex <> -1 then + begin + FFirstObjectIndex := FXMLDoc.Root.FindItem('previewpages')[FFirstPageIndex].Count; + FFirstOutlineIndex := FXMLDoc.Root.FindItem('outline').Count; + end; + ResetLogicalPageNumber; +end; + +procedure TfrxPreviewPages.ClearFirstPassPages; +var + PagesRoot, OutlineRoot: TfrxXMLItem; + p: TfrxXMLItem; + i: Integer; +begin + if FFirstPageIndex = -1 then + begin + for i := 0 to FXMLDoc.Root.Count - 1 do +{$IFDEF Delphi12} +{ if (AnsiStrIComp(PAnsiChar(FXMLDoc.Root[i].Name), PAnsiChar(AnsiString('anchors'))) <> 0) and + (AnsiStrIComp(PAnsiChar(FXMLDoc.Root[i].Name), PAnsiChar(AnsiString('logicalpagenumbers'))) <> 0) then} + if (CompareText(FXMLDoc.Root[i].Name, 'anchors') <> 0) and + (CompareText(FXMLDoc.Root[i].Name, 'logicalpagenumbers') <> 0) then +{$ELSE} + if (CompareText(FXMLDoc.Root[i].Name, 'anchors') <> 0) and + (CompareText(FXMLDoc.Root[i].Name, 'logicalpagenumbers') <> 0) then +{$ENDIF} + FXMLDoc.Root[i].Clear; + + end + else + begin + PagesRoot := FXMLDoc.Root.FindItem('previewpages'); + OutlineRoot := FXMLDoc.Root.FindItem('outline'); + p := PagesRoot[FFirstPageIndex]; + { clear some objects on first page } + while p.Count > FFirstObjectIndex do + p[FFirstObjectIndex].Free; + { clear remained pages } + while Count > FFirstPageIndex + 1 do + PagesRoot[FFirstPageIndex + 1].Free; + { clear remained outline } + while OutlineRoot.Count > FFirstOutlineIndex do + OutlineRoot[FFirstOutlineIndex].Free; + end; + + ResetLogicalPageNumber; + CurPage := FFirstPageIndex; + FXMLSize := 0; +end; + +function TfrxPreviewPages.CurXMLPage: TfrxXMLItem; +begin + Result := FXMLDoc.Root.FindItem('previewpages'); + Result := Result[CurPage]; +end; + +function TfrxPreviewPages.GetCount: Integer; +begin + Result := FXMLDoc.Root.FindItem('previewpages').Count; +end; + +function TfrxPreviewPages.GetCurPosition: Integer; +begin + Result := CurXMLPage.Count; +end; + +procedure TfrxPreviewPages.AddAnchor(const Text: String); +var + AnchorRoot, Item: TfrxXMLItem; +begin + AnchorRoot := FXMLDoc.Root.FindItem('anchors'); + Item := AnchorRoot.Add; + Item.Name := 'item'; + Item.Text := 'text="' + frxStrToXML(Text) + + '" page="' + IntToStr(CurPage) + + '" top="' + IntToStr(Round(Engine.CurY)) + '"'; +end; + +function TfrxPreviewPages.FindAnchor(const Text: String): TfrxXMLItem; +var + AnchorRoot, Item: TfrxXMLItem; + i: Integer; +begin + Result := nil; + AnchorRoot := FXMLDoc.Root.FindItem('anchors'); + for i := AnchorRoot.Count - 1 downto 0 do + begin + Item := AnchorRoot[i]; +{$IFDEF Delphi12} +// if AnsiCompareText(Item.Prop['text'], Text) = 0 then +// if AnsiStrIComp(PAnsiChar(Item.Prop['text']), Text) = 0 then + if AnsiCompareText(Item.Prop['text'], Text) = 0 then +{$ELSE} + if AnsiCompareText(Item.Prop['text'], Text) = 0 then +{$ENDIF} + begin + Result := Item; + Exit; + end; + end; +end; + +function TfrxPreviewPages.GetAnchorPage(const Text: String): Integer; +var + Item: TfrxXMLItem; +begin + Item := FindAnchor(Text); + if Item <> nil then + Result := StrToInt(String(Item.Prop['page'])) + 1 else + Result := 1; +end; + +function TfrxPreviewPages.GetAnchorCurPosition: Integer; +begin + Result := FXMLDoc.Root.FindItem('anchors').Count - 1; +end; + +procedure TfrxPreviewPages.ShiftAnchors(From, NewTop: Integer); +var + i, CorrY: Integer; + AnchorRoot, Item: TfrxXMLItem; +begin + AnchorRoot := FXMLDoc.Root.FindItem('anchors'); + if (From + 1 < 0) or (From + 1 >= AnchorRoot.Count) then Exit; + + Item := AnchorRoot[From + 1]; + CorrY := NewTop - StrToInt(String(Item.Prop['top'])); + + for i := From + 1 to AnchorRoot.Count - 1 do + begin + Item := AnchorRoot[i]; + Item.Prop['page'] := IntToStr(StrToInt(Item.Prop['page']) + 1); + Item.Prop['top'] := IntToStr(StrToInt(Item.Prop['top']) + CorrY); + end; +end; + +procedure TfrxPreviewPages.IncLogicalPageNumber; +var + xi: TfrxXMLItem; +begin + if Engine.FinalPass and Engine.DoublePass then Exit; + + Inc(FLogicalPageN); + xi := FXMLDoc.Root.FindItem('logicalpagenumbers').Add; + xi.Name := 'page'; + xi.Prop['n'] := IntToStr(FLogicalPageN); +end; + +procedure TfrxPreviewPages.ResetLogicalPageNumber; +var + i: Integer; + xi, pageItem: TfrxXMLItem; +begin + if Engine.FinalPass and Engine.DoublePass then Exit; + + pageItem := FXMLDoc.Root.FindItem('logicalpagenumbers'); + for i := CurPage downto FFirstPageIndex + 1 do + begin + if (i < 0) or (i >= pageItem.Count) then continue; + xi := pageItem[i]; + xi.Prop['t'] := IntToStr(FLogicalPageN); + if xi.Prop['n'] = '1' then + break; + end; + FLogicalPageN := 0; +end; + +function TfrxPreviewPages.GetLogicalPageNo: Integer; +var + xi: TfrxXMLItem; +begin + xi := FXMLDoc.Root.FindItem('logicalpagenumbers'); + if (CurPage < 0) or (CurPage >= xi.Count) then + Result := CurPage - FirstPage + 1 + else + begin + xi := xi[CurPage]; + Result := StrToInt(String(xi.Prop['n'])); + end; +end; + +function TfrxPreviewPages.GetLogicalTotalPages: Integer; +var + xi: TfrxXMLItem; +begin + xi := FXMLDoc.Root.FindItem('logicalpagenumbers'); + if (CurPage < 0) or (CurPage >= xi.Count) then + Result := Engine.TotalPages - FirstPage + else + begin + xi := xi[CurPage]; + if xi.Prop['t'] <> '' then + Result := StrToInt(String(xi.Prop['t'])) + else + Result := 0; + end; +end; + +procedure TfrxPreviewPages.AddObject(Obj: TfrxComponent); + + procedure DoAdd(c: TfrxComponent; Item: TfrxXMLItem); + var + i: Integer; + begin + if (not c.Visible) or not (csPreviewVisible in c.frComponentStyle) then Exit; + + with THackComponent(c) do + begin + Item := Item.Add; + { the component that was created after report has been started } + if FOriginalComponent = nil then + begin + Item.Name := ClassName; + Item.Text := AllDiff(nil); + end + else + begin + { the component that exists in the report template } + Item.Name := FAliasName; + if Engine.FinalPass then + begin + if csDefaultDiff in frComponentStyle then + Item.Text := AllDiff(FOriginalComponent) else + Item.Text := Diff(FOriginalComponent); + end + else + { we don't need to output all info on the first pass, only coordinates } + Item.Text := InternalDiff(FOriginalComponent); + end; + Inc(FXMLSize, Length(Item.Name) + Length(Item.Text) + Item.InstanceSize + 16); + end; + + for i := 0 to c.Objects.Count - 1 do + DoAdd(c.Objects[i], Item); + end; + +begin + DoAdd(Obj, CurXMLPage); +end; + +procedure TfrxPreviewPages.AddPage(Page: TfrxReportPage); +var + xi: TfrxXMLItem; + + procedure UnloadPages; + var + i: Integer; + begin + if Report.EngineOptions.UseFileCache then + if FXMLSize > Report.EngineOptions.MaxMemSize * 1024 * 1024 then + begin + for i := xi.Count - 2 downto 0 do + if xi[i].Loaded then + FXMLDoc.UnloadItem(xi[i]) else + break; + FXMLSize := 0; + end; + end; + + function GetSourceNo(Page: TfrxReportPage): Integer; + var + i: Integer; + begin + Result := -1; + for i := 0 to FSourcePages.Count - 1 do + if THackComponent(FSourcePages[i]).FOriginalComponent = Page then + begin + Result := i; + break; + end; + end; + +begin + FPagesItem := FXMLDoc.Root.FindItem('previewpages'); + xi := FPagesItem; + UnloadPages; + + CurPage := CurPage + 1; + if (CurPage >= Count) or (AddPageAction = apAdd) then + begin + xi := xi.Add; + xi.Name := 'page' + IntToStr(GetSourceNo(Page)); + if Count > 2 then + xi.Unloadable := True; + Report.InternalOnProgress(ptRunning, CurPage + 1); + AddPageAction := apWriteOver; + CurPage := Count - 1; + IncLogicalPageNumber; + end; +end; + +procedure TfrxPreviewPages.AddSourcePage(Page: TfrxReportPage); +var + p: TfrxReportPage; + xs: TfrxXMLSerializer; + xi: TfrxXMLItem; + i: Integer; + originals, copies: TList; + c1, c2: TfrxComponent; + s, s1: String; + + function EnumObjects(Parent, Parent1: TfrxComponent): TfrxComponent; + var + i: Integer; + c: TfrxComponent; + begin + Result := nil; + if not (csPreviewVisible in Parent.frComponentStyle) then Exit; + + c := TfrxComponent(Parent.NewInstance); + c.Create(Parent1); + if Parent is TfrxPictureView then + TfrxPictureView(Parent).IsPictureStored := False; + c.Assign(Parent); + if Parent is TfrxPictureView then + TfrxPictureView(Parent).IsPictureStored := True; + c.Name := Parent.Name; + originals.Add(Parent); + copies.Add(c); + + for i := 0 to Parent.Objects.Count - 1 do + EnumObjects(Parent.Objects[i], c); + Result := c; + end; + +begin + xs := TfrxXMLSerializer.Create(nil); + xi := TfrxXMLItem.Create; + originals := TList.Create; + copies := TList.Create; + + try + p := TfrxReportPage(EnumObjects(Page, nil)); + THackComponent(p).FOriginalComponent := Page; + FSourcePages.Add(p); + + for i := 1 to copies.Count - 1 do + begin + c1 := copies[i]; + c2 := originals[i]; + + THackComponent(c2).FOriginalComponent := c1; + THackComponent(c1).FOriginalComponent := c2; + + if c1 is TfrxBand then + s := 'b' else + s := LowerCase(c1.BaseName[1]); + s := FDictionary.AddUnique(String(s), 'Page' + IntToStr(FSourcePages.Count - 1) + + '.' + c1.Name, c1); + // speed optimization + if c1 is TfrxCustomMemoView then + begin + TfrxCustomMemoView(c1).DataSet := nil; + TfrxCustomMemoView(c1).DataField := ''; + end; + if csDefaultDiff in c1.frComponentStyle then + s1 := c1.ClassName + else + s1 := xs.WriteComponentStr(c1); + THackComponent(c1).FBaseName := s1; + THackComponent(c1).FAliasName := s; + THackComponent(c2).FAliasName := s; + end; + + finally + originals.Free; + copies.Free; + xs.Free; + xi.Free; + end; +end; + +procedure TfrxPreviewPages.AddPicture(Picture: TfrxPictureView); +begin + FPictureCache.AddPicture(Picture); +end; + +procedure TfrxPreviewPages.AddToSourcePage(Obj: TfrxComponent); +var + NewObj: TfrxComponent; + Page: TfrxReportPage; + s: String; + xs: TfrxXMLSerializer; +begin + xs := TfrxXMLSerializer.Create(nil); + Page := FSourcePages[FSourcePages.Count - 1]; + NewObj := TfrxComponent(Obj.NewInstance); + NewObj.Create(Page); + NewObj.Assign(Obj); + NewObj.CreateUniqueName; + + s := FDictionary.AddUnique(LowerCase(String(NewObj.BaseName[1])), + 'Page' + IntToStr(FSourcePages.Count - 1) + '.' + NewObj.Name, NewObj); + if csDefaultDiff in NewObj.frComponentStyle then + THackComponent(NewObj).FBaseName := NewObj.ClassName else + THackComponent(NewObj).FBaseName := xs.WriteComponentStr(NewObj); + + THackComponent(Obj).FOriginalComponent := NewObj; + THackComponent(Obj).FAliasName := s; + THackComponent(NewObj).FAliasName := s; + xs.Free; +end; + +procedure TfrxPreviewPages.UpdatePageDimensions(Page: TfrxReportPage; Width, Height: Extended); +var + SourcePage: TfrxReportPage; + xi: TfrxXMLItem; + i: Integer; +begin + SourcePage := nil; + for i := 0 to FSourcePages.Count - 1 do + begin + SourcePage := FSourcePages[i]; + if THackComponent(SourcePage).FOriginalComponent = Page then + break; + end; + + SourcePage.PaperSize := 256; + SourcePage.PaperWidth := Width / fr01cm; + SourcePage.PaperHeight := Height / fr01cm; + xi := TfrxXMLItem.Create; + xi.Text := THackComponent(SourcePage).FBaseName; + xi.Prop['PaperSize'] := '256'; + xi.Prop['PaperWidth'] := frxFloatToStr(SourcePage.PaperWidth); + xi.Prop['PaperHeight'] := frxFloatToStr(SourcePage.PaperHeight); + THackComponent(SourcePage).FBaseName := xi.Text; + xi.Free; +end; + +procedure TfrxPreviewPages.Finish; +var + i: Integer; +begin + ClearPageCache; + { avoid bug with multiple PrepareReport(False) } + for i := 0 to FSourcePages.Count - 1 do + THackComponent(FSourcePages[i]).FOriginalComponent := nil; + Report.InternalOnProgressStop(ptRunning); +end; + +function TfrxPreviewPages.BandExists(Band: TfrxBand): Boolean; +var + i: Integer; + c: TfrxComponent; +begin + Result := False; + for i := 0 to CurXMLPage.Count - 1 do + begin + c := GetObject(CurXMLPage[i].Name); + if c <> nil then + if (THackComponent(c).FOriginalComponent = Band) or + ((Band is TfrxPageFooter) and (c is TfrxPageFooter)) or + ((Band is TfrxColumnFooter) and (c is TfrxColumnFooter)) then + begin + Result := True; + break; + end; + end; +end; + +function TfrxPreviewPages.GetLastY(ColumnPosition: Extended): Extended; +var + i: Integer; + c: TfrxComponent; + s: String; + y, x: Extended; +begin + Result := 0; + y := 0; + for i := 0 to CurXMLPage.Count - 1 do + begin + c := GetObject(CurXMLPage[i].Name); + if c is TfrxBand then + if not (c is TfrxPageFooter) and not (c is TfrxOverlay) then + begin + s := String(CurXMLPage[i].Prop['l']); + if s <> '' then + x := frxStrToFloat(s) else + x := c.Left; + { check columns } + if (ColumnPosition = 0) or (ABS(ColumnPosition - x) < 0.001) + or (c is TfrxPageHeader) or (c is TfrxReportTitle) then + begin + s := String(CurXMLPage[i].Prop['t']); + if s <> '' then + y := frxStrToFloat(s) else + y := c.Top; + + s := String(CurXMLPage[i].Prop['h']); + if s <> '' then + y := y + frxStrToFloat(s) else + y := y + c.Height; + end; + if y > Result then + Result := y; + end; + end; +end; + +procedure TfrxPreviewPages.CutObjects(APosition: Integer); +var + xi: TfrxXMLItem; +begin + xi := FXMLDoc.Root.FindItem('cutted'); + while APosition < CurXMLPage.Count do + xi.AddItem(CurXMLPage[APosition]); +end; + +procedure TfrxPreviewPages.PasteObjects(X, Y: Extended); +var + xi: TfrxXMLItem; + LeftX, TopY, CorrX, CorrY: Extended; + + procedure CorrectX(xi: TfrxXMLItem); + var + X: Extended; + begin + if xi.Prop['l'] <> '' then + X := frxStrToFloat(xi.Prop['l']) else + X := 0; + X := X + CorrX; + xi.Prop['l'] := FloatToStr(X); + end; + + procedure CorrectY(xi: TfrxXMLItem); + var + Y: Extended; + begin + if xi.Prop['t'] <> '' then + Y := frxStrToFloat(xi.Prop['t']) else + Y := 0; + Y := Y + CorrY; + xi.Prop['t'] := FloatToStr(Y); + end; + +begin + xi := FXMLDoc.Root.FindItem('cutted'); + + if xi.Count > 0 then + begin + if xi[0].Prop['l'] <> '' then + LeftX := frxStrToFloat(xi[0].Prop['l']) else + LeftX := 0; + CorrX := X - LeftX; + + if xi[0].Prop['t'] <> '' then + TopY := frxStrToFloat(xi[0].Prop['t']) else + TopY := 0; + CorrY := Y - TopY; + + while xi.Count > 0 do + begin + CorrectX(xi[0]); + CorrectY(xi[0]); + CurXMLPage.AddItem(xi[0]); + end; + end; + + xi.Free; +end; + +procedure TfrxPreviewPages.DoLoadFromStream; +var + Compressor: TfrxCustomCompressor; +begin + Compressor := nil; + if frxCompressorClass <> nil then + begin + FAllowPartialLoading := False; + Compressor := TfrxCustomCompressor(frxCompressorClass.NewInstance); + Compressor.Create(nil); + Compressor.Report := Report; + Compressor.IsFR3File := False; + try + Compressor.CreateStream; + if Compressor.Decompress(FTempStream) then + FTempStream := Compressor.Stream; + except + Compressor.Free; + Report.Errors.Add(frxResources.Get('clDecompressError')); + frxCommonErrorHandler(Report, frxResources.Get('clErrors') + #13#10 + Report.Errors.Text); + Exit; + end; + end; + FXMLDoc.LoadFromStream(FTempStream, FAllowPartialLoading); + AfterLoad; + if Compressor <> nil then + Compressor.Free; +end; + +procedure TfrxPreviewPages.DoSaveToStream; +var + Compressor: TfrxCustomCompressor; + StreamTo: TStream; +begin + StreamTo := FTempStream; + Compressor := nil; + if Report.ReportOptions.Compressed and (frxCompressorClass <> nil) then + begin + Compressor := TfrxCustomCompressor(frxCompressorClass.NewInstance); + Compressor.Create(nil); + Compressor.Report := Report; + Compressor.IsFR3File := False; + Compressor.CreateStream; + StreamTo := Compressor.Stream; + end; + try + BeforeSave; + FXMLDoc.SaveToStream(StreamTo); + finally + if Compressor <> nil then + begin + try + Compressor.Compress(FTempStream); + finally + Compressor.Free; + end; + end; + end; +end; + +procedure TfrxPreviewPages.LoadFromStream(Stream: TStream; + AllowPartialLoading: Boolean = False); +begin + Clear; + FTempStream := Stream; + FAllowPartialLoading := AllowPartialLoading; +{$IFNDEF FR_COM} +// if Report.EngineOptions.ReportThread <> nil then +// THackThread(Report.EngineOptions.ReportThread).Synchronize(DoLoadFromStream) +// else +{$ENDIF} + DoLoadFromStream; +end; + +procedure TfrxPreviewPages.SaveToStream(Stream: TStream); +begin + FTempStream := Stream; +{$IFNDEF FR_COM} +// if Report.EngineOptions.ReportThread <> nil then +// THackThread(Report.EngineOptions.ReportThread).Synchronize(DoSaveToStream) +// else +{$ENDIF} + DoSaveToStream; +end; + +function TfrxPreviewPages.LoadFromFile(const FileName: String; + ExceptionIfNotFound: Boolean): Boolean; +var + Stream: TFileStream; +begin + Result := FileExists(FileName); + if Result or ExceptionIfNotFound then + begin + Stream := TFileStream.Create(FileName, fmOpenRead + fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +{ Clear; + FXMLDoc.LoadFromFile(FileName); + AfterLoad;} + end; +end; + +procedure TfrxPreviewPages.SaveToFile(const FileName: String); +var + Stream: TFileStream; +begin + Stream := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +{ BeforeSave; + FXMLDoc.SaveToFile(FileName); + ClearPageCache; + AfterLoad;} +end; + +procedure TfrxPreviewPages.AfterLoad; +var + i: Integer; + xs: TfrxXMLSerializer; + xi: TfrxXMLItem; + p: TfrxReportPage; + +{ store source objects' properties in the FBaseName to get it later in the GetPage } + procedure DoProps(p: TfrxReportPage); + var + i: Integer; + l: TList; + c: THackComponent; + begin + l := p.AllObjects; + for i := 0 to l.Count - 1 do + begin + c := l[i]; + c.FBaseName := xs.WriteComponentStr(c); + end; + end; + +{ fill FDictionary.Objects } + procedure FillDictionary; + var + i: Integer; + Name, PageName, ObjName: String; + PageN: Integer; + begin + xi := FXMLDoc.Root.FindItem('dictionary'); + FDictionary.Clear; + for i := 0 to xi.Count - 1 do + begin + Name := Copy(xi[i].Text, 7, Length(xi[i].Text) - 7); + PageName := Copy(Name, 1, Pos('.', Name) - 1); + ObjName := Copy(Name, Pos('.', Name) + 1, 255); + + PageN := StrToInt(Copy(PageName, 5, 255)); + FDictionary.Add(xi[i].Name, Name, + TfrxReportPage(FSourcePages[PageN]).FindObject(ObjName)); + end; + end; + +begin + FPagesItem := FXMLDoc.Root.FindItem('previewpages'); + xs := TfrxXMLSerializer.Create(nil); + xs.OldFormat := FXMLDoc.OldVersion; + +{ load the report settings } + xi := FXMLDoc.Root.FindItem('report'); + if xi.Count > 0 then + xs.ReadRootComponent(Report, xi[0]); + +{ build sourcepages } + try + xi := FXMLDoc.Root.FindItem('sourcepages'); + ClearSourcePages; + + for i := 0 to xi.Count - 1 do + begin +{$IFDEF Delphi12} +// if AnsiStrIComp(PAnsiChar(xi[i].Name), PansiChar(AnsiString('TfrxDMPPage'))) = 0 then + if CompareText(xi[i].Name, 'TfrxDMPPage') = 0 then +{$ELSE} + if CompareText(xi[i].Name, 'TfrxDMPPage') = 0 then +{$ENDIF} + p := TfrxDMPPage.Create(nil) else + p := TfrxReportPage.Create(nil); + xs.Owner := p; + xs.ReadRootComponent(p, xi[i]); + DoProps(p); + FSourcePages.Add(p); + end; + xi.Clear; + + finally + xs.Free; + end; + +{ build the dictionary } + FillDictionary; + +{ load the picturecache } + FPictureCache.LoadFromXML(FXMLDoc.Root.FindItem('picturecache')); +end; + +procedure TfrxPreviewPages.BeforeSave; +var + i: Integer; + xs: TfrxXMLSerializer; + xi: TfrxXMLItem; +begin + FPagesItem := FXMLDoc.Root.FindItem('previewpages'); + xs := TfrxXMLSerializer.Create(nil); + +{ upload the report settings } + xi := FXMLDoc.Root.FindItem('report'); + xi.Clear; + xi := xi.Add; + xi.Name := Report.ClassName; + xi.Text := 'DotMatrixReport="' + frxValueToXML(Report.DotMatrixReport) + + '" PreviewOptions.OutlineVisible="' + frxValueToXML(Report.PreviewOptions.OutlineVisible) + + '" PreviewOptions.OutlineWidth="' + frxValueToXML(Report.PreviewOptions.OutlineWidth) + + '" ReportOptions.Name="' + frxStrToXML(Report.ReportOptions.Name) + '"'; + +{ upload the sourcepages } + try + xi := FXMLDoc.Root.FindItem('sourcepages'); + xi.Clear; + for i := 0 to FSourcePages.Count - 1 do + xs.WriteRootComponent(FSourcePages[i], True, xi.Add); + + finally + xs.Free; + end; + +{ upload the dictionary } + xi := FXMLDoc.Root.FindItem('dictionary'); + xi.Clear; + for i := 0 to FDictionary.Names.Count - 1 do + with xi.Add do + begin + Name := FDictionary.Names[i]; + Text := 'name="' + FDictionary.GetSourceName(Name) + '"'; + end; + +{ upload the picturecache } + xi := FXMLDoc.Root.FindItem('picturecache'); + FPictureCache.SaveToXML(xi); +end; + +function TfrxPreviewPages.GetObject(const Name: String): TfrxComponent; +begin + Result := TfrxComponent(FDictionary.GetObject(Name)); +end; + +function TfrxPreviewPages.GetPage(Index: Integer): TfrxReportPage; +var + xi: TfrxXMLItem; + xs: TfrxXMLSerializer; + i: Integer; + Source: TfrxReportPage; + + procedure DoObjects(Item: TfrxXMLItem; Owner: TfrxComponent); + var + i: Integer; + c, c0: TfrxComponent; + begin + for i := 0 to Item.Count - 1 do + begin + c0 := GetObject(Item[i].Name); + { object not found in the dictionary } + if c0 = nil then + c := xs.ReadComponentStr(Owner, Item[i].Name + ' ' + Item[i].Text, True) + else + begin + c := xs.ReadComponentStr(Owner, + THackComponent(c0).FBaseName + ' ' + Item[i].Text, True); + c.Name := c0.Name; + if (c is TfrxPictureView) and (TfrxPictureView(c).Picture.Graphic = nil) then + FPictureCache.GetPicture(TfrxPictureView(c)); + end; + c.Parent := Owner; + + DoObjects(Item[i], c); + end; + end; + +begin + Result := nil; + if Count = 0 then Exit; + + { check pagecache first } + if not Engine.Running then + begin + i := FPageCache.IndexOf(IntToStr(Index)); + if i <> -1 then + begin + Result := TfrxReportPage(FPageCache.Objects[i]); + FPageCache.Exchange(i, 0); + Exit; + end; + end; + + xs := TfrxXMLSerializer.Create(nil); + xs.OldFormat := FXMLDoc.OldVersion; + try + { load the page item } + xi := FPagesItem[Index]; + FXMLDoc.LoadItem(xi); + +{$IFDEF Delphi12} +// if AnsiStrIComp(PAnsiChar(xi.Name), PAnsiChar(AnsiString('TfrxReportPage'))) = 0 then + if CompareText(xi.Name, 'TfrxReportPage') = 0 then +{$ELSE} + if CompareText(xi.Name, 'TfrxReportPage') = 0 then +{$ENDIF} + begin + { page item do not refer to the originalpages } + Result := TfrxReportPage.Create(nil); + xs.ReadRootComponent(Result, xi); + end +{$IFDEF Delphi12} +// else if AnsiStrIComp(PAnsiChar(xi.Name), PAnsiChar(AnsiString('TfrxDMPPage'))) = 0 then + else if CompareText(xi.Name, 'TfrxDMPPage') = 0 then +{$ELSE} + else if CompareText(xi.Name, 'TfrxDMPPage') = 0 then +{$ENDIF} + begin + { page item do not refer to the originalpages } + Result := TfrxDMPPage.Create(nil); + xs.ReadRootComponent(Result, xi); + end + else + begin + Source := FSourcePages[StrToInt(Copy(String(xi.Name), 5, 5))]; + { create reportpage and assign properties from original page } + if Source is TfrxDMPPage then + Result := TfrxDMPPage.Create(nil) else + Result := TfrxReportPage.Create(nil); + Result.Assign(Source); + + { create objects } + DoObjects(xi, Result); + end; + finally + xs.Free; + end; + + { update aligned objects } + Result.AlignChildren; + + { add this page to the pagecache } + FPageCache.InsertObject(0, IntToStr(Index), Result); + i := FPageCache.Count; + + { remove the least used item from the pagecache } + if (i > 1) and (i > Report.PreviewOptions.PagesInCache) then + begin + xi := FPagesItem[StrToInt(FPageCache[i - 1])]; + if Report.EngineOptions.UseFileCache and xi.Unloadable then + begin + FXMLDoc.UnloadItem(xi); + xi.Clear; + end; + + TfrxReportPage(FPageCache.Objects[i - 1]).Free; + FPageCache.Delete(i - 1); + end; +end; + +function TfrxPreviewPages.GetPageSize(Index: Integer): TPoint; +var + xi: TfrxXMLItem; + p: TfrxReportPage; +begin + if (Count = 0) or (Index < 0) or (Index >= Count) then + begin + Result := Point(0, 0); + Exit; + end; + + xi := FPagesItem[Index]; +{$IFDEF Delphi12} +{ if (AnsiStrIComp(PAnsiChar(xi.Name), PAnsiChar(AnsiString('TfrxReportPage'))) = 0) or + (AnsiStrIComp(PAnsiChar(xi.Name), PAnsiChar(AnsiString('TfrxDMPPage'))) = 0) then} + if (CompareText(xi.Name, 'TfrxReportPage') = 0) or + (CompareText(xi.Name, 'TfrxDMPPage') = 0) then +{$ELSE} + if (CompareText(xi.Name, 'TfrxReportPage') = 0) or + (CompareText(xi.Name, 'TfrxDMPPage') = 0) then +{$ENDIF} + p := GetPage(Index) else + p := FSourcePages[StrToInt(Copy(String(xi.Name), 5, 256))]; + Result.X := Round(p.Width); + Result.Y := Round(p.Height); +end; + +procedure TfrxPreviewPages.AddEmptyPage(Index: Integer); +var + xi: TfrxXMLItem; +begin + if Count = 0 then Exit; + + xi := TfrxXMLItem.Create; + xi.Name := FPagesItem[Index].Name; + FPagesItem.InsertItem(Index, xi); + ClearPageCache; +end; + +procedure TfrxPreviewPages.DeletePage(Index: Integer); +begin + if Count < 2 then Exit; + + FPagesItem[Index].Free; + ClearPageCache; +end; + +procedure TfrxPreviewPages.ModifyPage(Index: Integer; Page: TfrxReportPage); +var + xs: TfrxXMLSerializer; +begin + xs := TfrxXMLSerializer.Create(nil); + try + FPagesItem[Index].Clear; + xs.WriteRootComponent(Page, True, FPagesItem[Index]); + FPagesItem[Index].Unloadable := False; + ClearPageCache; + finally + xs.Free; + end; +end; + +procedure TfrxPreviewPages.AddFrom(Report: TfrxReport); +var + i, nPageOffset: Integer; + Page: TfrxReportPage; + xi: TfrxXMLItem; + xs: TfrxXMLSerializer; + + procedure CopyOutline; + var + nPage, nTop, idx: Integer; + sText: String; + begin + for idx := 0 to Report.PreviewPages.Outline.Count - 1 do + begin + Report.PreviewPages.Outline.GetItem(idx, sText, nPage, nTop); + CurPage := nPageOffset + nPage; + Outline.AddItem(sText, nTop); + Report.PreviewPages.Outline.LevelDown(idx); + CopyOutline; + Report.PreviewPages.Outline.LevelUp; + Outline.LevelUp; + end; + end; + +begin + xs := TfrxXMLSerializer.Create(nil); + + nPageOffset := Count; + + for i := 0 to Report.PreviewPages.Count - 1 do + begin + Page := Report.PreviewPages.Page[i]; + xi := TfrxXMLItem.Create; + xi.Name := FPagesItem[Count - 1].Name; + xs.WriteRootComponent(Page, True, xi); + xi.Unloadable := False; + FPagesItem.AddItem(xi); + end; + + {copy outline items} + Report.PreviewPages.Outline.LevelRoot; + Outline.LevelRoot; + CopyOutline; + + xs.Free; + ClearPageCache; +end; + +procedure TfrxPreviewPages.DrawPage(Index: Integer; Canvas: TCanvas; + ScaleX, ScaleY, OffsetX, OffsetY: Extended); +var + i: Integer; + Page: TfrxReportPage; + l: TList; + c: TfrxComponent; + IsPrinting: Boolean; + SaveLeftMargin, SaveRightMargin: Extended; + rgn: HRGN; + + function ViewVisible(c: TfrxComponent): Boolean; + var + r: TRect; + begin + with c do + r := Rect(Round(AbsLeft * ScaleX) - 20, Round(AbsTop * ScaleY) - 20, + Round((AbsLeft + Width) * ScaleX + 20), + Round((AbsTop + Height) * ScaleY + 20)); + OffsetRect(r, Round(OffsetX), Round(OffsetY)); + Result := RectVisible(Canvas.Handle, r) or (Canvas is TMetafileCanvas); + end; + +begin + Page := GetPage(Index); + if Page = nil then Exit; + + SaveLeftMargin := Page.LeftMargin; + SaveRightMargin := Page.RightMargin; + if Page.MirrorMargins and (Index mod 2 = 1) then + begin + Page.LeftMargin := SaveRightMargin; + Page.RightMargin := SaveLeftMargin; + end; + + IsPrinting := Canvas is TfrxPrinterCanvas; + rgn := 0; + if not IsPrinting then + begin + rgn := CreateRectRgn(0, 0, 10000, 10000); + GetClipRgn(Canvas.Handle, rgn); + IntersectClipRect(Canvas.Handle, + Round(OffsetX), + Round(OffsetY), + Round(OffsetX + Page.PaperWidth * fr01cm * ScaleX) - 1, + Round(OffsetY + Page.PaperHeight * fr01cm * ScaleY) - 1); + end; + + Page.IsPrinting := IsPrinting; + Page.Draw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY); + OffsetX := OffsetX + Page.LeftMargin * fr01cm * ScaleX; + OffsetY := OffsetY + Page.TopMargin * fr01cm * ScaleY; + + l := Page.AllObjects; + + for i := 0 to l.Count - 1 do + begin + c := l[i]; + if (c is TfrxView) and ViewVisible(c) then + if not IsPrinting or TfrxView(c).Printable then + begin + c.IsPrinting := IsPrinting; + { needed for TOTALPAGES macro } + if c is TfrxCustomMemoView then + begin + THackMemoView(c).FTotalPages := Count; + THackMemoView(c).FCopyNo := FCopyNo; + THackMemoView(c).FPrintScale := FPrintScale; + end; + { draw the object } + TfrxView(c).Draw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY); + c.IsPrinting := False; + end; + end; + + Page.LeftMargin := SaveLeftMargin; + Page.RightMargin := SaveRightMargin; + if not IsPrinting then + begin + SelectClipRgn(Canvas.Handle, rgn); + DeleteObject(rgn); + end; +end; + +function TfrxPreviewPages.Print: Boolean; +var + MaxCount: Integer; + PagesPrinted, ACopyNo: Integer; + pgList: TStringList; + LastDuplexMode: TfrxDuplexMode; + LastPaperSize, LastPaperWidth, LastPaperHeight, LastBin: Integer; + LastOrientation: TPrinterOrientation; + SplitAddX, SplitAddY: Extended; + DuplexMode: TfrxDuplexMode; + SavePrintOptions: TfrxPrintOptions; + SheetWidth, SheetHeight: Extended; + NeedFinishDuplex: Boolean; + + + function GetNextPage(var Index: Integer): TfrxReportPage; + begin + Result := nil; + while Index < Count - 1 do + begin + Inc(Index); + if (pgList.Count <> 0) and (pgList.IndexOf(IntToStr(Index + 1)) = -1) then + continue + else + begin + Result := GetPage(Index); + break; + end; + end; + end; + + procedure SplitPage(a, b, c, d: Extended; var x, y: Integer; var NeedRotate: Boolean); + var + tempX, tempY: Integer; + tempC: Extended; + + procedure TrySplit; + begin + if Abs(Trunc(a / c) * c - a) < 11 then + x := Round(a / c) + else + x := Trunc(a / c) + 1; + + if Abs(Trunc(b / d) * d - b) < 11 then + y := Round(b / d) + else + y := Trunc(b / d) + 1; + end; + + begin + NeedRotate := False; + + TrySplit; + + tempX := x; + tempY := y; + + tempC := c; + c := d; + d := tempC; + + TrySplit; + + if x * y >= tempX * tempY then + begin + x := tempX; + y := tempY; + end + else + NeedRotate := True; + end; + + procedure DoPrint; + var + i: Integer; + Printer: TfrxCustomPrinter; + PagePrinted: Boolean; + Page: TfrxReportPage; + + function PrintSplittedPage(Index: Integer): Boolean; + var + Bin, ACopies, x, y, countX, countY: Integer; + pieceX, pieceY, offsX, offsY, marginX, marginY, printedX, printedY: Extended; + orient: TPrinterOrientation; + NeedChangeOrientation: Boolean; + dup: TfrxDuplexMode; + begin + Result := True; + if Index >= Count then Exit; + + if (pgList.Count <> 0) and (pgList.IndexOf(IntToStr(Index + 1)) = -1) then Exit; + if ((Report.PrintOptions.PrintPages = ppOdd) and ((Index + 1) mod 2 = 0)) or + ((Report.PrintOptions.PrintPages = ppEven) and ((Index + 1) mod 2 = 1)) then Exit; + if Report.Terminated then + begin + Printer.Abort; + Result := False; + Exit; + end; + + Page := GetPage(Index); + + if Report.PrintOptions.Collate then + begin + ACopies := 1; + FCopyNo := ACopyNo; + end + else + begin + ACopies := Report.PrintOptions.Copies; + FCopyNo := 1; + end; + + if Assigned(Report.OnPrintPage) then + Report.OnPrintPage(Page, FCopyNo); + + if Index = 0 then + Bin := Page.Bin else + Bin := Page.BinOtherPages; + + SplitPage(Page.PaperWidth, Page.PaperHeight, SheetWidth, SheetHeight, + countX, countY, NeedChangeOrientation); + + orient := poPortrait; + if NeedChangeOrientation then + orient := poLandscape; + + dup := Page.Duplex; + if DuplexMode <> dmNone then + dup := DuplexMode; + + if not PagePrinted or (orient <> LastOrientation) then + Printer.SetPrintParams(Report.PrintOptions.PrintOnSheet, + SheetWidth, SheetHeight, orient, Bin, Integer(dup) + 1, ACopies); + if not PagePrinted then + Printer.BeginDoc; + + if orient = poPortrait then + begin + pieceX := SheetWidth * (Printer.DPI.X / 25.4); + pieceY := SheetHeight * (Printer.DPI.Y / 25.4); + end + else + begin + pieceX := SheetHeight * (Printer.DPI.X / 25.4); + pieceY := SheetWidth * (Printer.DPI.Y / 25.4); + end; + + marginY := 0; + printedY := 0; + offsY := -Printer.TopMargin * Printer.DPI.Y / 25.4; + + for y := 1 to countY do + begin + marginX := 0; + printedX := 0; + offsX := -Printer.LeftMargin * Printer.DPI.X / 25.4; + + for x := 1 to countX do + begin + Printer.BeginPage; + DrawPage(Index, Printer.Canvas, Printer.DPI.X / 96, Printer.DPI.Y / 96, + offsX, offsY); + +{$IFDEF TRIAL} + with Printer.Canvas do + begin + Font.Size := 12; + Font.Color := clBlack; + TextOut(0, 0, frxReverseString(FR_UNREG)); + end; +{$ENDIF} + Printer.EndPage; + + printedX := printedX + (pieceX - marginX - Printer.RightMargin * Printer.DPI.X / 25.4) - + SplitAddX * Printer.DPI.X / 25.4; + offsX := -printedX; + marginX := Printer.LeftMargin * Printer.DPI.X / 25.4; + end; + + printedY := printedY + (pieceY - marginY - Printer.BottomMargin * Printer.DPI.Y / 25.4) - + SplitAddY * Printer.DPI.Y / 25.4; + offsY := -printedY; + marginY := Printer.TopMargin * Printer.DPI.Y / 25.4; + end; + + Report.InternalOnProgress(ptPrinting, Index + 1); + Application.ProcessMessages; + + PagePrinted := True; + Inc(PagesPrinted); + + LastOrientation := Page.Orientation; + ClearPageCache; + end; + + + function PrintPage(Index: Integer): Boolean; + var + Bin, ACopies: Integer; + dup: TfrxDuplexMode; + ZoomX, ZoomY: Extended; + begin + Result := True; + if Index >= Count then Exit; + + if (pgList.Count <> 0) and (pgList.IndexOf(IntToStr(Index + 1)) = -1) then Exit; + if ((Report.PrintOptions.PrintPages = ppOdd) and ((Index + 1) mod 2 = 0)) or + ((Report.PrintOptions.PrintPages = ppEven) and ((Index + 1) mod 2 = 1)) then Exit; + if Report.Terminated then + begin + Printer.Abort; + Result := False; + Exit; + end; + + Page := GetPage(Index); + + if Report.PrintOptions.Collate then + begin + ACopies := 1; + FCopyNo := ACopyNo; + end + else + begin + ACopies := Report.PrintOptions.Copies; + FCopyNo := 1; + end; + + if Assigned(Report.OnPrintPage) then + Report.OnPrintPage(Page, FCopyNo); + + if Index = 0 then + Bin := Page.Bin else + Bin := Page.BinOtherPages; + + dup := Page.Duplex; + if DuplexMode <> dmNone then + dup := DuplexMode; + + if LastDuplexMode <> dup then + NeedFinishDuplex := False; + if dup in [dmVertical, dmHorizontal] then + NeedFinishDuplex := not NeedFinishDuplex; + + if Report.PrintOptions.PrintMode = pmDefault then + begin + if (not PagePrinted) or + (LastPaperSize <> Page.PaperSize) or + (LastPaperWidth <> Round(Page.PaperWidth)) or + (LastPaperHeight <> Round(Page.PaperHeight)) or + (LastBin <> Bin) or + (LastOrientation <> Page.Orientation) or + (LastDuplexMode <> dup) then + Printer.SetPrintParams(Page.PaperSize, Page.PaperWidth, Page.PaperHeight, + Page.Orientation, Bin, Integer(dup) + 1, ACopies); + end + else + if (not PagePrinted) or + (LastBin <> Bin) or + (LastOrientation <> Page.Orientation) or + (LastDuplexMode <> dup) then + begin + Printer.SetPrintParams(Report.PrintOptions.PrintOnSheet, + SheetWidth, SheetHeight, Page.Orientation, Bin, Integer(dup) + 1, ACopies); + SheetWidth := frxPrinters.Printer.PaperWidth; + SheetHeight := frxPrinters.Printer.PaperHeight; + end; + if not PagePrinted then + Printer.BeginDoc; + + Printer.BeginPage; + + if Report.PrintOptions.PrintMode = pmDefault then + begin + ZoomX := 1; + ZoomY := 1; + end + else + begin + ZoomX := SheetWidth / Page.PaperWidth; + ZoomY := SheetHeight / Page.PaperHeight; + if ZoomY < ZoomX then + FPrintScale := ZoomY + else + FPrintScale := ZoomX; + end; + + DrawPage(Index, Printer.Canvas, Printer.DPI.X / 96 * ZoomX, Printer.DPI.Y / 96 * ZoomY, + -Printer.LeftMargin * Printer.DPI.X / 25.4, + -Printer.TopMargin * Printer.DPI.Y / 25.4); + + Report.InternalOnProgress(ptPrinting, Index + 1); + +{$IFDEF TRIAL} + with Printer.Canvas do + begin + Font.Size := 12; + Font.Color := clBlack; + TextOut(0, 0, frxReverseString(FR_UNREG)); + end; +{$ENDIF} + Printer.EndPage; + Application.ProcessMessages; + + PagePrinted := True; + Inc(PagesPrinted); + + LastPaperSize := Page.PaperSize; + LastPaperWidth := Round(Page.PaperWidth); + LastPaperHeight := Round(Page.PaperHeight); + LastBin := Bin; + LastOrientation := Page.Orientation; + LastDuplexMode := dup; + ClearPageCache; + end; + + procedure PrintPages; + var + i: Integer; + begin + PagesPrinted := 0; + + if Report.PrintOptions.Reverse then + begin + for i := MaxCount - 1 downto 0 do + if not PrintPage(i) then + break; + end + else + for i := 0 to MaxCount - 1 do + if not PrintPage(i) then + break; + end; + + procedure PrintSplittedPages; + var + i: Integer; + begin + PagesPrinted := 0; + + if Report.PrintOptions.Reverse then + begin + for i := MaxCount - 1 downto 0 do + if not PrintSplittedPage(i) then + break; + end + else + for i := 0 to MaxCount - 1 do + if not PrintSplittedPage(i) then + break; + end; + + procedure PrintJoinedPages; + var + Index, cp, x, y, countX, countY: Integer; + pieceX, pieceY, offsX, offsY: Extended; + orient: TPrinterOrientation; + NeedChangeOrientation: Boolean; + dup: TfrxDuplexMode; + begin + PagesPrinted := 0; + if Count = 0 then Exit; + + { get the first page and calculate the join options } + Index := -1; + Page := GetNextPage(Index); + + SplitPage(SheetWidth, SheetHeight, Page.PaperWidth, Page.PaperHeight, + countX, countY, NeedChangeOrientation); + orient := poPortrait; + if NeedChangeOrientation then + begin + orient := poLandscape; + x := countX; + countX := countY; + countY := x; + end; + + { setup the printer } + dup := Page.Duplex; + if DuplexMode <> dmNone then + dup := DuplexMode; + Printer.SetPrintParams(Report.PrintOptions.PrintOnSheet, + SheetWidth, SheetHeight, orient, Page.Bin, Integer(dup) + 1, 1); + PagePrinted := True; + Printer.BeginDoc; + + { start the cycle } + pieceX := Page.PaperWidth * (Printer.DPI.X / 25.4); + pieceY := Page.PaperHeight * (Printer.DPI.Y / 25.4); + + Index := -1; + while Index < MaxCount - 1 do + begin + cp := 1; + offsY := -Printer.TopMargin * Printer.DPI.Y / 25.4; + Printer.BeginPage; + + for y := 1 to countY do + begin + offsX := -Printer.LeftMargin * Printer.DPI.X / 25.4; + + for x := 1 to countX do + begin + { get the next page } + FCopyNo := cp; + if cp = 1 then + Page := GetNextPage(Index); + Inc(cp); + if cp > Report.PrintOptions.Copies then + cp := 1; + + if Page = nil then break; + + DrawPage(Index, Printer.Canvas, Printer.DPI.X / 96, Printer.DPI.Y / 96, + offsX, offsY); + + offsX := offsX + pieceX; + end; + + if Page = nil then break; + offsY := offsY + pieceY; + end; + +{$IFDEF TRIAL} + with Printer.Canvas do + begin + Font.Size := 12; + Font.Color := clBlack; + TextOut(0, 0, frxReverseString(FR_UNREG)); + end; +{$ENDIF} + Printer.EndPage; + + Report.InternalOnProgress(ptPrinting, Index); + Application.ProcessMessages; + if Report.Terminated then + begin + Printer.Abort; + Exit; + end; + + Inc(PagesPrinted); + ClearPageCache; + end; + end; + + begin + Printer := frxPrinters.Printer; + Report.Terminated := False; + Report.InternalOnProgressStart(ptPrinting); + + if Report.ReportOptions.Name <> '' then + Printer.Title := Report.ReportOptions.Name else + Printer.Title := Report.FileName; + if Report.PrintOptions.Copies <= 0 then + Report.PrintOptions.Copies := 1; +{$IFNDEF TRIAL} + MaxCount := Count; +{$ELSE} + MaxCount := 5; +{$ENDIF} + + PagePrinted := False; + LastDuplexMode := dmNone; + NeedFinishDuplex := False; + + if Report.PrintOptions.Collate then + for i := 0 to Report.PrintOptions.Copies - 1 do + begin + ACopyNo := i + 1; + case Report.PrintOptions.PrintMode of + pmDefault, pmScale: + PrintPages; + pmSplit: + PrintSplittedPages; + pmJoin: + PrintJoinedPages; + end; + if NeedFinishDuplex then + begin + Printer.BeginPage; + Printer.EndPage; + end; + + if Report.Terminated then break; + end + else + begin + case Report.PrintOptions.PrintMode of + pmDefault, pmScale: + PrintPages; + pmSplit: + PrintSplittedPages; + pmJoin: + PrintJoinedPages; + end; + end; + + if PagePrinted then + Printer.EndDoc; + Report.InternalOnProgressStop(ptPrinting); + end; + +begin + Result := True; + if not frxPrinters.HasPhysicalPrinters then + begin + frxErrorMsg(frxResources.Get('clNoPrinters')); + Result := False; + Exit; + end; + + FPrintScale := 1; + + if Report.DotMatrixReport and (frxDotMatrixExport <> nil) then + begin + Report.SelectPrinter; + frxDotMatrixExport.ShowDialog := Report.PrintOptions.ShowDialog; + frxDotMatrixExport.PageNumbers := Report.PrintOptions.PageNumbers; + Result := Export(frxDotMatrixExport); + Exit; + end; + + SavePrintOptions := TfrxPrintOptions.Create; + SavePrintOptions.Assign(Report.PrintOptions); + DuplexMode := Report.PrintOptions.Duplex; + Report.SelectPrinter; + + if Report.PrintOptions.ShowDialog then + with TfrxPrintDialog.Create(Application) do + begin + AReport := Report; + ADuplexMode := DuplexMode; + ShowModal; + if ModalResult = mrOk then + begin + DuplexMode := ADuplexMode; + Report.PrintOptions.Duplex := DuplexMode; + Free; + end + else + begin + Free; + FCopyNo := 0; + Result := False; + SavePrintOptions.Free; + Exit; + end; + end; + + frxPrinters.Printer.SwapPaperSize := Report.PrintOptions.SwapPageSize; + frxPrinters.Printer.FileName := Report.PrintOptions.PrnOutFileName; + + if Report.PrintOptions.PrintMode <> pmDefault then + begin + if Report.PrintOptions.PrintOnSheet <> 256 then + frxPrinters.Printer.SetViewParams(Report.PrintOptions.PrintOnSheet, 0, 0, poPortrait) + else + frxPrinters.Printer.SetViewParams(Report.PrintOptions.PrintOnSheet, frxPrinters.Printer.PaperWidth, + frxPrinters.Printer.PaperHeight, poPortrait); + + SheetWidth := frxPrinters.Printer.PaperWidth; + SheetHeight := frxPrinters.Printer.PaperHeight; + SplitAddX := 3; + SplitAddY := 3; + end; + + if Assigned(Report.OnPrintReport) then + Report.OnPrintReport(Report); + Report.DoNotifyEvent(Report, Report.OnReportPrint, not Report.EngineOptions.DestroyForms); + + if Report.Preview <> nil then + begin + Report.Preview.Lock; + Report.Preview.Refresh; + end; + pgList := TStringList.Create; + try + if frxPrinters.Printer.Initialized then + begin + frxParsePageNumbers(Report.PrintOptions.PageNumbers, pgList, Count); + ClearPageCache; + DoPrint; + end + else frxErrorMsg('Printer selected is not valid'); + finally + if Assigned(Report.OnAfterPrintReport) then + Report.OnAfterPrintReport(Report); + FCopyNo := 0; + Report.PrintOptions.Assign(SavePrintOptions); + SavePrintOptions.Free; + pgList.Free; + end; +end; + +function TfrxPreviewPages.Export(Filter: TfrxCustomExportFilter): Boolean; +var + pgList: TStringList; + tempBMP: TBitmap; + + procedure ExportPage(Index: Integer); + var + i, j: Integer; + Page: TfrxReportPage; + c: TfrxComponent; + p: TfrxPictureView; +{$IFDEF TRIAL} + m: TfrxCustomMemoView; +{$ENDIF} + + procedure ExportObject(c: TfrxComponent); + begin + if c is TfrxCustomMemoView then + begin + { set up font if Highlight is active } + if TfrxCustomMemoView(c).Highlight.Active then + TfrxCustomMemoView(c).Font.Assign(TfrxCustomMemoView(c).Highlight.Font); + { needed for TOTALPAGES, COPYNAME macros } + THackMemoView(c).FTotalPages := Count; + THackMemoView(c).FCopyNo := 1; + THackMemoView(c).ExtractMacros; + { needed if memo has AutoWidth and Align properties } + if THackMemoView(c).AutoWidth then + THackMemoView(c).Draw(tempBMP.Canvas, 1, 1, 0, 0); + end; + Filter.ExportObject(c); + end; + + begin + if Index >= Count then Exit; + if (pgList.Count <> 0) and (pgList.IndexOf(IntToStr(Index + 1)) = -1) then Exit; + Page := GetPage(Index); + if Page = nil then Exit; + + if Filter.ShowProgress then + Report.InternalOnProgress(ptExporting, Index + 1); + + Filter.StartPage(Page, Index); + try + { set the offset of the page objects } + if Page.MirrorMargins and (Index mod 2 = 1) then + Page.Left := Page.RightMargin * fr01cm else + Page.Left := Page.LeftMargin * fr01cm; + Page.Top := Page.TopMargin * fr01cm; + + { export the page background picture and frame } + p := TfrxPictureView.Create(nil); + p.Name := '_pagebackground'; + p.Color := Page.Color; + p.Frame.Assign(Page.Frame); + p.Picture.Assign(Page.BackPicture); + p.Stretched := True; + p.KeepAspectRatio := False; + try + p.SetBounds(Page.Left, Page.Top, + Page.Width - (Page.LeftMargin + Page.RightMargin) * fr01cm, + Page.Height - (Page.TopMargin + Page.BottomMargin) * fr01cm); + Filter.ExportObject(p); + finally + p.Free; + end; +{$IFDEF TRIAL} + m := TfrxCustomMemoView.Create(nil); + try + m.SetBounds(Page.Left, Page.Top - 10, + Page.Width - (Page.LeftMargin + Page.RightMargin) * fr01cm, 10); + m.Text := frxReverseString(FR_UNREG); + m.HAlign := haRight; + m.Font.Size := 7; + m.Font.Color := clGray; + Filter.ExportObject(m); + finally + m.Free; + end; +{$ENDIF} + + for i := 0 to Page.Objects.Count - 1 do + begin + c := Page.Objects[i]; + if c is TfrxBand then + begin + if c is TfrxPageHeader then + begin + { suppress a header } + if Filter.SuppressPageHeadersFooters and (Index <> 0) then continue; + end; + if c is TfrxPageFooter then + begin + { suppress a footer } + if Filter.SuppressPageHeadersFooters and (Index <> Count - 1) then continue; + end; + end; + + ExportObject(c); + if c.Objects.Count <> 0 then + for j := 0 to c.Objects.Count - 1 do + ExportObject(c.Objects[j]); + end; + + finally + Filter.FinishPage(Page, Index); + end; + + if Report.Preview = nil then + ClearPageCache + else + begin + Page.Left := 0; + Page.Top := 0; + end; + end; + + procedure DoExport; + var + i: Integer; + begin + if Filter.Start then + try + if Report.Preview <> nil then + begin + Report.Preview.Lock; + Report.Preview.Refresh; + end; + + if Filter.ShowProgress then + Report.InternalOnProgressStart(ptExporting); + +{$IFNDEF TRIAL} + for i := 0 to Count - 1 do +{$ELSE} + for i := 0 to 4 do +{$ENDIF} + begin + ExportPage(i); + if Report.Terminated then break; + Application.ProcessMessages; + end; + + finally + if Report.Preview <> nil then + begin + TfrxPreview(Report.Preview).HideMessage; + Report.Preview.Refresh; + end; + + if Filter.ShowProgress then + Report.InternalOnProgressStop(ptExporting); + + Filter.Finish; + end; + end; + +begin + Result := False; + FCopyNo := 0; + if Filter = nil then Exit; + + Filter.Report := Report; + if (Filter.ShowDialog and (Filter.ShowModal <> mrOk)) then + Exit; + if Filter.CurPage then + if Report.Preview <> nil then + Filter.PageNumbers := IntToStr(CurPreviewPage) else + Filter.PageNumbers := '1'; + + Result := True; + Report.Terminated := False; + + pgList := TStringList.Create; + tempBMP := TBitmap.Create; + try + frxParsePageNumbers(Filter.PageNumbers, pgList, Count); + + if Filter = frxDotMatrixExport then + if Assigned(Report.OnPrintReport) then + Report.OnPrintReport(Report); + + try + DoExport; + except + on e: Exception do + begin + Result := False; + Report.Errors.Text := e.Message; + frxCommonErrorHandler(Report, frxResources.Get('clErrors') + #13#10 + Report.Errors.Text); + end; + end; + + if Filter = frxDotMatrixExport then + if Assigned(Report.OnAfterPrintReport) then + Report.OnAfterPrintReport(Report); + finally + pgList.Free; + tempBMP.Free; + end; +end; + +procedure TfrxPreviewPages.ObjectOver(Index: Integer; X, Y: Integer; + Button: TMouseButton; Shift: TShiftState; Scale, OffsetX, OffsetY: Extended; + Click: Boolean; var Cursor: TCursor; DBClick: Boolean); +var + Page: TfrxReportPage; + c: TfrxComponent; + l: TList; + i: Integer; + Flag: Boolean; + v: TfrxView; + drill: TfrxGroupHeader; + + function MouseInView(c: TfrxComponent): Boolean; + var + r: TRect; + begin + with c do + r := Rect(Round(AbsLeft * Scale), Round(AbsTop * Scale), + Round((AbsLeft + Width) * Scale), + Round((AbsTop + Height) * Scale)); + OffsetRect(r, Round(OffsetX), Round(OffsetY)); + Result := PtInRect(r, Point(X, Y)); + end; + + procedure SetToAnchor(const Text: String); + var + Item: TfrxXMLItem; + PageN, Top: Integer; + begin + Item := FindAnchor(Text); + if Item <> nil then + begin + PageN := StrToInt(String(Item.Prop['page'])); + Top := StrToInt(String(Item.Prop['top'])); + TfrxPreview(Report.Preview).SetPosition(PageN + 1, Top); + end; + end; + +begin + if (Index < 0) or (Index >= Count) or Engine.Running then Exit; + Page := GetPage(Index); + if Page = nil then Exit; + + if Page.MirrorMargins and (Index mod 2 = 1) then + OffsetX := OffsetX + Page.RightMargin * fr01cm * Scale else + OffsetX := OffsetX + Page.LeftMargin * fr01cm * Scale; + OffsetY := OffsetY + Page.TopMargin * fr01cm * Scale; + + Report.SetProgressMessage(''); + Report.SetProgressMessage('', True); + Page := GetPage(Index); // get page again to ensure it was not cleared during export + if Page = nil then Exit; + + drill := nil; + l := Page.AllObjects; + + for i := l.Count - 1 downto 0 do + begin + c := l[i]; + if (c is TfrxGroupHeader) and MouseInView(c) then + if TfrxGroupHeader(c).DrillDown then + begin + drill := TfrxGroupHeader(c); + //break; + end; + + if (c is TfrxView) and MouseInView(c) then + begin + v := TfrxView(c); + if (v.Parent is TfrxGroupHeader) and TfrxGroupHeader(v.Parent).DrillDown then + begin + drill := TfrxGroupHeader(v.Parent); + //break; + end; + if v.Cursor <> crDefault then + Cursor := v.Cursor; + if v.URL <> '' then + begin + Report.SetProgressMessage(v.URL); + if v.Cursor = crDefault then + Cursor := crHandPoint; + end; + if (v.Hint <> '') and (v.ShowHint) and (Report.Preview.UseReportHints) then + begin + Report.SetProgressMessage(GetLongHint(v.Hint), True); + Report.Preview.Hint := GetShortHint(v.Hint); + Report.Preview.ShowHint := True; + end; + + if Click and (drill = nil) then + begin + if v.URL <> '' then + if Pos('@', v.URL) = 1 then + TfrxPreview(Report.Preview).PageNo := StrToInt(Copy(v.URL, 2, 255)) + else if Pos('#', v.URL) = 1 then + SetToAnchor(Copy(v.URL, 2, 255)) + else + ShellExecute(GetDesktopWindow, nil, PChar(v.URL), nil, nil, sw_ShowNormal); + + Flag := False; + if DBClick then + Report.DoPreviewClick(v, Button, Shift, Flag, True) + else + Report.DoPreviewClick(v, Button, Shift, Flag); + if Flag then + begin + ModifyPage(Index, Page); + Report.Preview.Invalidate; + end; + end + else if Assigned(Report.OnMouseOverObject) then + Report.OnMouseOverObject(v); + break; + end + else if c is TfrxView then + if (TfrxView(c).ShowHint) and (Report.Preview <> nil) and (Report.Preview.UseReportHints) then + Report.Preview.ShowHint := False; + end; + + if drill <> nil then + begin + Cursor := crHandPoint; + if Click and (Button = mbLeft) then + begin + if Report.DrillState.IndexOf(drill.DrillName) = -1 then + Report.DrillState.Add(drill.DrillName) + else + Report.DrillState.Delete(Report.DrillState.IndexOf(drill.DrillName)); + Report.Preview.RefreshReport; + end; + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPrintDialog.dfm b/official/4.8.11/Source/frxPrintDialog.dfm new file mode 100644 index 0000000..4922599 Binary files /dev/null and b/official/4.8.11/Source/frxPrintDialog.dfm differ diff --git a/official/4.8.11/Source/frxPrintDialog.pas b/official/4.8.11/Source/frxPrintDialog.pas new file mode 100644 index 0000000..2b1dae2 --- /dev/null +++ b/official/4.8.11/Source/frxPrintDialog.pas @@ -0,0 +1,341 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Print dialog } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPrintDialog; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, frxCtrls, ExtCtrls, Buttons, ComCtrls, frxClass +{$IFDEF Delphi6} +, Variants, ImgList +{$ENDIF}; + + +type + TfrxPrintDialog = class(TForm) + OkB: TButton; + CancelB: TButton; + FileDlg: TSaveDialog; + Label12: TGroupBox; + WhereL: TLabel; + WhereL1: TLabel; + PrintersCB: TComboBox; + PropButton: TButton; + FileCB: TCheckBox; + Label1: TGroupBox; + DescrL: TLabel; + AllRB: TRadioButton; + CurPageRB: TRadioButton; + PageNumbersRB: TRadioButton; + PageNumbersE: TEdit; + Label2: TGroupBox; + CopiesL: TLabel; + CollateImg: TImage; + NonCollateImg: TImage; + CopiesPB: TPaintBox; + CopiesE: TEdit; + CollateCB: TCheckBox; + UpDown1: TUpDown; + ScaleGB: TGroupBox; + PagPageSizeCB: TComboBox; + NameL: TLabel; + PagSizeL: TLabel; + PrintModeCB: TComboBox; + PrintModeIL: TImageList; + OtherGB: TGroupBox; + PrintL: TLabel; + DuplexL: TLabel; + PrintPagesCB: TComboBox; + DuplexCB: TComboBox; + OrderL: TLabel; + OrderCB: TComboBox; + SwapCB: TCheckBox; + PagesL: TLabel; + procedure PrintersCBDrawItem(Control: TWinControl; Index: Integer; + ARect: TRect; State: TOwnerDrawState); + procedure FormCreate(Sender: TObject); + procedure PropButtonClick(Sender: TObject); + procedure PrintersCBClick(Sender: TObject); + procedure PageNumbersRBClick(Sender: TObject); + procedure CollateLClick(Sender: TObject); + procedure CollateCBClick(Sender: TObject); + procedure CopiesPBPaint(Sender: TObject); + procedure PageNumbersEEnter(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure PrintModeCBDrawItem(Control: TWinControl; Index: Integer; + ARect: TRect; State: TOwnerDrawState); + procedure FormShow(Sender: TObject); + procedure PrintModeCBClick(Sender: TObject); + private + { Private declarations } + OldIndex: Integer; + public + { Public declarations } + AReport: TfrxReport; + ADuplexMode: TfrxDuplexMode; + end; + + +implementation + +{$R *.DFM} + +uses frxPrinter, Printers, frxUtils, frxRes; + + +procedure TfrxPrintDialog.FormCreate(Sender: TObject); +begin + Caption := frxGet(200); + Label12.Caption := frxGet(201); + DescrL.Caption := frxGet(9); + Label1.Caption := frxGet(202); + CopiesL.Caption := frxGet(203); + CollateCB.Caption := frxGet(204); + Label2.Caption := frxGet(205); + PrintL.Caption := frxGet(206); + WhereL.Caption := frxGet(208); + OkB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + PropButton.Caption := frxGet(209); + AllRB.Caption := frxGet(3); + CurPageRB.Caption := frxGet(4); + PageNumbersRB.Caption := frxGet(5); + FileCB.Caption := frxGet(210); + NameL.Caption := frxGet(212); + ScaleGB.Caption := frxGet(213); + PagSizeL.Caption := frxGet(214); + DuplexL.Caption := frxGet(216); + OtherGB.Caption := frxGet(207); + OrderL.Caption := frxGet(211); + FileDlg.Title := frxGet(507); + FileDlg.Filter := frxGet(510); + + OrderCB.Items.Clear; + OrderCB.Items.Add(frxResources.Get('poDirect')); + OrderCB.Items.Add(frxResources.Get('poReverse')); + + PrintPagesCB.Items.Clear; + PrintPagesCB.Items.Add(frxResources.Get('ppAll')); + PrintPagesCB.Items.Add(frxResources.Get('ppOdd')); + PrintPagesCB.Items.Add(frxResources.Get('ppEven')); + PrintPagesCB.ItemIndex := 0; + + DuplexCB.Items.Clear; + DuplexCB.Items.Add(frxResources.Get('dupDefault')); + DuplexCB.Items.Add(frxResources.Get('dupVert')); + DuplexCB.Items.Add(frxResources.Get('dupHorz')); + DuplexCB.Items.Add(frxResources.Get('dupSimpl')); + DuplexCB.ItemIndex := 0; + + PrintModeCB.Items.Clear; + PrintModeCB.Items.Add(frxResources.Get('pmDefault')); + PrintModeCB.Items.Add(frxResources.Get('pmSplit')); + PrintModeCB.Items.Add(frxResources.Get('pmJoin')); + PrintModeCB.Items.Add(frxResources.Get('pmScale')); + + SetWindowLong(CopiesE.Handle, GWL_STYLE, GetWindowLong(CopiesE.Handle, GWL_STYLE) or ES_NUMBER); + + if Screen.PixelsPerInch > 96 then + PrintersCB.ItemHeight := 19; + PrintersCB.Items.Assign(frxPrinters.Printers); + PrintersCB.ItemIndex := frxPrinters.PrinterIndex; + PrintersCBClick(nil); + + OldIndex := frxPrinters.PrinterIndex; + CollateCBClick(nil); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxPrintDialog.FormShow(Sender: TObject); +begin + UpDown1.Position := AReport.PrintOptions.Copies; + CollateCB.Checked := AReport.PrintOptions.Collate; + PageNumbersE.Text := AReport.PrintOptions.PageNumbers; + SwapCB.Checked := AReport.PrintOptions.SwapPageSize; + if AReport.PrintOptions.PageNumbers <> '' then + PageNumbersRB.Checked := True; + PrintPagesCB.ItemIndex := Integer(AReport.PrintOptions.PrintPages); + if AReport.PrintOptions.Reverse then + OrderCB.ItemIndex := 1 + else + OrderCB.ItemIndex := 0; + + PrintModeCB.ItemIndex := Integer(AReport.PrintOptions.PrintMode); + DuplexCB.ItemIndex := Integer(ADuplexMode); + PrintModeCBClick(nil); + if AReport.PrintOptions.PrintMode <> pmDefault then + begin + PagPageSizeCB.ItemIndex := frxPrinters.Printer.PaperIndex(AReport.PrintOptions.PrintOnSheet) + 1; + if frxPrinters.Printer.PaperIndex(256) < frxPrinters.Printer.PaperIndex(AReport.PrintOptions.PrintOnSheet) then + PagPageSizeCB.ItemIndex := PagPageSizeCB.ItemIndex - 1; + end; +end; + +procedure TfrxPrintDialog.FormHide(Sender: TObject); +begin + if ModalResult <> mrOk then + frxPrinters.PrinterIndex := OldIndex + else + begin + frxPrinters.Printer.FileName := ''; + if FileCB.Checked then + if FileDlg.Execute then + frxPrinters.Printer.FileName := ChangeFileExt(FileDlg.FileName, '.prn') else + ModalResult := mrCancel; + end; + + if ModalResult = mrOk then + begin + AReport.PrintOptions.Copies := StrToInt(CopiesE.Text); + AReport.PrintOptions.Collate := CollateCB.Checked; + if AllRB.Checked then + AReport.PrintOptions.PageNumbers := '' + else if CurPageRB.Checked then + AReport.PrintOptions.PageNumbers := IntToStr(AReport.PreviewPages.CurPreviewPage) + else + AReport.PrintOptions.PageNumbers := PageNumbersE.Text; + AReport.PrintOptions.PrintPages := TfrxPrintPages(PrintPagesCB.ItemIndex); + ADuplexMode := TfrxDuplexMode(DuplexCB.ItemIndex); + AReport.PrintOptions.Reverse := OrderCB.ItemIndex = 1; + + AReport.PrintOptions.PrintMode := TfrxPrintMode(PrintModeCB.ItemIndex); + AReport.PrintOptions.PrintOnSheet := frxPrinters.Printer.PaperNameToNumber(PagPageSizeCB.Text); + AReport.PrintOptions.SwapPageSize := SwapCB.Checked; + end; +end; + +procedure TfrxPrintDialog.PrintersCBDrawItem(Control: TWinControl; Index: Integer; + ARect: TRect; State: TOwnerDrawState); +begin + with PrintersCB.Canvas do + begin + FillRect(ARect); + frxResources.PreviewButtonImages.Draw(PrintersCB.Canvas, ARect.Left + 2, ARect.Top, 2); + TextOut(ARect.Left + 24, ARect.Top + 1, PrintersCB.Items[Index]); + end; +end; + +procedure TfrxPrintDialog.PropButtonClick(Sender: TObject); +var + dup: Integer; +begin + frxPrinters.Printer.PropertiesDlg; + dup := frxPrinters.Printer.Duplex - 1; + if dup = 0 then dup := 3; + + if dup > 0 then + begin + ADuplexMode := TfrxDuplexMode(dup); + DuplexCB.ItemIndex := dup; + end; +end; + +procedure TfrxPrintDialog.PrintersCBClick(Sender: TObject); +var + SaveSheet: Integer; +begin + if PagPageSizeCB.ItemIndex <= 0 then + SaveSheet := -1 + else + SaveSheet := frxPrinters.Printer.PaperNameToNumber(PagPageSizeCB.Text); + + frxPrinters.PrinterIndex := PrintersCB.ItemIndex; + WhereL1.Caption := frxPrinters.Printer.Port; + PagPageSizeCB.Items := frxPrinters.Printer.Papers; + PagPageSizeCB.Items.Delete(frxPrinters.Printer.PaperIndex(256)); + PagPageSizeCB.Items.Insert(0, frxResources.Get('pgDefault')); + + if (SaveSheet <> -1) and (frxPrinters.Printer.PaperIndex(SaveSheet) <> -1) then + begin + PagPageSizeCB.ItemIndex := frxPrinters.Printer.PaperIndex(SaveSheet) + 1; + if frxPrinters.Printer.PaperIndex(256) < frxPrinters.Printer.PaperIndex(SaveSheet) then + PagPageSizeCB.ItemIndex := PagPageSizeCB.ItemIndex - 1 + end + else + PagPageSizeCB.ItemIndex := 0 +end; + +procedure TfrxPrintDialog.PageNumbersEEnter(Sender: TObject); +begin + PageNumbersRB.Checked := True; +end; + +procedure TfrxPrintDialog.PageNumbersRBClick(Sender: TObject); +begin + if Visible then + PageNumbersE.SetFocus; +end; + +procedure TfrxPrintDialog.CollateLClick(Sender: TObject); +begin + CollateCB.Checked := not CollateCB.Checked; +end; + +procedure TfrxPrintDialog.CollateCBClick(Sender: TObject); +begin + CopiesPBPaint(nil); +end; + +procedure TfrxPrintDialog.CopiesPBPaint(Sender: TObject); +begin + with CopiesPB.Canvas do + begin + Brush.Color := Color; + FillRect(Rect(0, 0, CopiesPB.Width, CopiesPB.Height)); + if CollateCB.Checked then + frxDrawTransparent(CopiesPB.Canvas, 0, 0, CollateImg.Picture.Bitmap) else + frxDrawTransparent(CopiesPB.Canvas, 0, 0, NonCollateImg.Picture.Bitmap); + end; +end; + +procedure TfrxPrintDialog.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +procedure TfrxPrintDialog.PrintModeCBDrawItem(Control: TWinControl; + Index: Integer; ARect: TRect; State: TOwnerDrawState); +begin + with PrintModeCB do + begin + Canvas.FillRect(ARect); + PrintModeIL.Draw(Canvas, ARect.Left + 2, ARect.Top + 1, Index); + Canvas.TextOut(ARect.Left + 74, ARect.Top + 10, Items[Index]); + end; +end; + +procedure TfrxPrintDialog.PrintModeCBClick(Sender: TObject); +var + DefaultMode: Boolean; +begin + DefaultMode := PrintModeCB.ItemIndex = 0; + if DefaultMode then + PagPageSizeCB.ItemIndex := 0; + PagPageSizeCB.Enabled := not DefaultMode; + if not DefaultMode and (PagPageSizeCB.ItemIndex = 0) then + PagPageSizeCB.ItemIndex := frxPrinters.Printer.PaperIndex(DMPAPER_A4); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxPrinter.pas b/official/4.8.11/Source/frxPrinter.pas new file mode 100644 index 0000000..12e69f4 --- /dev/null +++ b/official/4.8.11/Source/frxPrinter.pas @@ -0,0 +1,1020 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Printer } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxPrinter; + +interface + +{$I frx.inc} + +uses + Windows, SysUtils, Classes, Graphics, Forms, Printers +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxPrinterCanvas = class; + + TfrxCustomPrinter = class(TObject) + private + FBin: Integer; + FDuplex: Integer; + FBins: TStrings; + FCanvas: TfrxPrinterCanvas; + FDefOrientation: TPrinterOrientation; + FDefPaper: Integer; + FDefPaperHeight: Extended; + FDefPaperWidth: Extended; + FDPI: TPoint; + FFileName: String; + FHandle: THandle; + FInitialized: Boolean; + FName: String; + FPaper: Integer; + FPapers: TStrings; + FPaperHeight: Extended; + FPaperWidth: Extended; + FLeftMargin: Extended; + FTopMargin: Extended; + FRightMargin: Extended; + FBottomMargin: Extended; + FOrientation: TPrinterOrientation; + FPort: String; + FPrinting: Boolean; + FTitle: String; + FSwapPaperSize: Boolean; + public + constructor Create(const AName, APort: String); virtual; + destructor Destroy; override; + procedure Init; virtual; abstract; + procedure Abort; virtual; abstract; + procedure BeginDoc; virtual; abstract; + procedure BeginPage; virtual; abstract; + procedure BeginRAWDoc; virtual; abstract; + procedure EndDoc; virtual; abstract; + procedure EndPage; virtual; abstract; + procedure EndRAWDoc; virtual; abstract; + procedure WriteRAWDoc(const buf: AnsiString); virtual; abstract; + + function BinIndex(ABin: Integer): Integer; + function PaperIndex(APaper: Integer): Integer; + function BinNameToNumber(const ABin: String): Integer; + function PaperNameToNumber(const APaper: String): Integer; + procedure SetViewParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; + AOrientation: TPrinterOrientation); virtual; abstract; + procedure SetPrintParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation; + ABin, ADuplex, ACopies: Integer); virtual; abstract; + procedure PropertiesDlg; virtual; abstract; + + property Bin: Integer read FBin; + property Duplex: Integer read FDuplex; + property Bins: TStrings read FBins; + property Canvas: TfrxPrinterCanvas read FCanvas; + property DefOrientation: TPrinterOrientation read FDefOrientation; + property DefPaper: Integer read FDefPaper; + property DefPaperHeight: Extended read FDefPaperHeight; + property DefPaperWidth: Extended read FDefPaperWidth; + property DPI: TPoint read FDPI; + property FileName: String read FFileName write FFileName; + property Handle: THandle read FHandle; + property Name: String read FName; + property Paper: Integer read FPaper; + property Papers: TStrings read FPapers; + property PaperHeight: Extended read FPaperHeight; + property PaperWidth: Extended read FPaperWidth; + property LeftMargin: Extended read FLeftMargin; + property TopMargin: Extended read FTopMargin; + property RightMargin: Extended read FRightMargin; + property BottomMargin: Extended read FBottomMargin; + property Orientation: TPrinterOrientation read FOrientation; + property Port: String read FPort; + property Title: String read FTitle write FTitle; + property Initialized: Boolean read FInitialized; + property SwapPaperSize: Boolean read FSwapPaperSize write FSwapPaperSize; + end; + + TfrxVirtualPrinter = class(TfrxCustomPrinter) + public + procedure Init; override; + procedure Abort; override; + procedure BeginDoc; override; + procedure BeginPage; override; + procedure BeginRAWDoc; override; + procedure EndDoc; override; + procedure EndPage; override; + procedure EndRAWDoc; override; + procedure WriteRAWDoc(const buf: AnsiString); override; + procedure SetViewParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; + AOrientation: TPrinterOrientation); override; + procedure SetPrintParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation; + ABin, ADuplex, ACopies: Integer); override; + procedure PropertiesDlg; override; + end; + + TfrxPrinter = class(TfrxCustomPrinter) + private + FDeviceMode: THandle; + FDC: HDC; + FDriver: String; + FMode: PDeviceMode; + procedure CreateDevMode; + procedure FreeDevMode; + procedure GetDC; + public + destructor Destroy; override; + procedure Init; override; + procedure RecreateDC; + procedure Abort; override; + procedure BeginDoc; override; + procedure BeginPage; override; + procedure BeginRAWDoc; override; + procedure EndDoc; override; + procedure EndPage; override; + procedure EndRAWDoc; override; + procedure WriteRAWDoc(const buf: AnsiString); override; + procedure SetViewParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; + AOrientation: TPrinterOrientation); override; + procedure SetPrintParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation; + ABin, ADuplex, ACopies: Integer); override; + procedure PropertiesDlg; override; + function UpdateDeviceCaps: Boolean; + property DeviceMode: PDeviceMode read FMode; + end; + + + TfrxPrinters = class(TObject) + private + FHasPhysicalPrinters: Boolean; + FPrinters: TStrings; + FPrinterIndex: Integer; + FPrinterList: TList; + function GetDefaultPrinter: String; + function GetItem(Index: Integer): TfrxCustomPrinter; + function GetCurrentPrinter: TfrxCustomPrinter; + procedure SetPrinterIndex(Value: Integer); + public + constructor Create; + destructor Destroy; override; + function IndexOf(AName: String): Integer; + procedure Clear; + procedure FillPrinters; + property Items[Index: Integer]: TfrxCustomPrinter read GetItem; default; + property HasPhysicalPrinters: Boolean read FHasPhysicalPrinters; + property Printer: TfrxCustomPrinter read GetCurrentPrinter; + property PrinterIndex: Integer read FPrinterIndex write SetPrinterIndex; + property Printers: TStrings read FPrinters; + end; + + TfrxPrinterCanvas = class(TCanvas) + private + FPrinter: TfrxCustomPrinter; + procedure UpdateFont; + public + procedure Changing; override; + end; + + +function frxPrinters: TfrxPrinters; +function frxGetPaperDimensions(PaperSize: Integer; var Width, Height: Extended): Boolean; + + +implementation + +uses frxUtils, WinSpool, Dialogs, frxRes; + + +type + TPaperInfo = {packed} record + Typ: Integer; + Name: String; + X, Y: Integer; + end; + + +const + PAPERCOUNT = 66; + PaperInfo: array[0..PAPERCOUNT - 1] of TPaperInfo = ( + (Typ:1; Name: ''; X:2159; Y:2794), + (Typ:2; Name: ''; X:2159; Y:2794), + (Typ:3; Name: ''; X:2794; Y:4318), + (Typ:4; Name: ''; X:4318; Y:2794), + (Typ:5; Name: ''; X:2159; Y:3556), + (Typ:6; Name: ''; X:1397; Y:2159), + (Typ:7; Name: ''; X:1842; Y:2667), + (Typ:8; Name: ''; X:2970; Y:4200), + (Typ:9; Name: ''; X:2100; Y:2970), + (Typ:10; Name: ''; X:2100; Y:2970), + (Typ:11; Name: ''; X:1480; Y:2100), + (Typ:12; Name: ''; X:2500; Y:3540), + (Typ:13; Name: ''; X:1820; Y:2570), + (Typ:14; Name: ''; X:2159; Y:3302), + (Typ:15; Name: ''; X:2150; Y:2750), + (Typ:16; Name: ''; X:2540; Y:3556), + (Typ:17; Name: ''; X:2794; Y:4318), + (Typ:18; Name: ''; X:2159; Y:2794), + (Typ:19; Name: ''; X:984; Y:2254), + (Typ:20; Name: ''; X:1048; Y:2413), + (Typ:21; Name: ''; X:1143; Y:2635), + (Typ:22; Name: ''; X:1207; Y:2794), + (Typ:23; Name: ''; X:1270; Y:2921), + (Typ:24; Name: ''; X:4318; Y:5588), + (Typ:25; Name: ''; X:5588; Y:8636), + (Typ:26; Name: ''; X:8636; Y:11176), + (Typ:27; Name: ''; X:1100; Y:2200), + (Typ:28; Name: ''; X:1620; Y:2290), + (Typ:29; Name: ''; X:3240; Y:4580), + (Typ:30; Name: ''; X:2290; Y:3240), + (Typ:31; Name: ''; X:1140; Y:1620), + (Typ:32; Name: ''; X:1140; Y:2290), + (Typ:33; Name: ''; X:2500; Y:3530), + (Typ:34; Name: ''; X:1760; Y:2500), + (Typ:35; Name: ''; X:1760; Y:1250), + (Typ:36; Name: ''; X:1100; Y:2300), + (Typ:37; Name: ''; X:984; Y:1905), + (Typ:38; Name: ''; X:920; Y:1651), + (Typ:39; Name: ''; X:3778; Y:2794), + (Typ:40; Name: ''; X:2159; Y:3048), + (Typ:41; Name: ''; X:2159; Y:3302), + (Typ:42; Name: ''; X:2500; Y:3530), + (Typ:43; Name: ''; X:1000; Y:1480), + (Typ:44; Name: ''; X:2286; Y:2794), + (Typ:45; Name: ''; X:2540; Y:2794), + (Typ:46; Name: ''; X:3810; Y:2794), + (Typ:47; Name: ''; X:2200; Y:2200), + (Typ:50; Name: ''; X:2355; Y:3048), + (Typ:51; Name: ''; X:2355; Y:3810), + (Typ:52; Name: ''; X:2969; Y:4572), + (Typ:53; Name: ''; X:2354; Y:3223), + (Typ:54; Name: ''; X:2101; Y:2794), + (Typ:55; Name: ''; X:2100; Y:2970), + (Typ:56; Name: ''; X:2355; Y:3048), + (Typ:57; Name: ''; X:2270; Y:3560), + (Typ:58; Name: ''; X:3050; Y:4870), + (Typ:59; Name: ''; X:2159; Y:3223), + (Typ:60; Name: ''; X:2100; Y:3300), + (Typ:61; Name: ''; X:1480; Y:2100), + (Typ:62; Name: ''; X:1820; Y:2570), + (Typ:63; Name: ''; X:3220; Y:4450), + (Typ:64; Name: ''; X:1740; Y:2350), + (Typ:65; Name: ''; X:2010; Y:2760), + (Typ:66; Name: ''; X:4200; Y:5940), + (Typ:67; Name: ''; X:2970; Y:4200), + (Typ:68; Name: ''; X:3220; Y:4450)); + + +var + FPrinters: TfrxPrinters = nil; + + +function frxGetPaperDimensions(PaperSize: Integer; var Width, Height: Extended): Boolean; +var + i: Integer; +begin + Result := False; + for i := 0 to PAPERCOUNT - 1 do + if PaperInfo[i].Typ = PaperSize then + begin + Width := PaperInfo[i].X / 10; + Height := PaperInfo[i].Y / 10; + Result := True; + break; + end; +end; + + +{ TfrxPrinterCanvas } + +procedure TfrxPrinterCanvas.Changing; +begin + inherited; + UpdateFont; +end; + +procedure TfrxPrinterCanvas.UpdateFont; +var + FontSize: Integer; +begin + if FPrinter.DPI.Y <> Font.PixelsPerInch then + begin + FontSize := Font.Size; + Font.PixelsPerInch := FPrinter.DPI.Y; + Font.Size := FontSize; + end; +end; + + +{ TfrxCustomPrinter } + +constructor TfrxCustomPrinter.Create(const AName, APort: String); +begin + FName := AName; + FPort := APort; + + FBins := TStringList.Create; + FBins.AddObject(frxResources.Get('prDefault'), Pointer(DMBIN_AUTO)); + + FPapers := TStringList.Create; + FPapers.AddObject(frxResources.Get('prCustom'), Pointer(256)); + + FCanvas := TfrxPrinterCanvas.Create; + FCanvas.FPrinter := Self; +end; + +destructor TfrxCustomPrinter.Destroy; +begin + FBins.Free; + FPapers.Free; + FCanvas.Free; + inherited; +end; + +function TfrxCustomPrinter.BinIndex(ABin: Integer): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to FBins.Count - 1 do + if Integer(FBins.Objects[i]) = ABin then + begin + Result := i; + break; + end; +end; + +function TfrxCustomPrinter.PaperIndex(APaper: Integer): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to FPapers.Count - 1 do + if Integer(FPapers.Objects[i]) = APaper then + begin + Result := i; + break; + end; +end; + +function TfrxCustomPrinter.BinNameToNumber(const ABin: String): Integer; +var + i: Integer; +begin + i := FBins.IndexOf(ABin); + if i = -1 then + i := 0; + Result := Integer(FBins.Objects[i]); +end; + +function TfrxCustomPrinter.PaperNameToNumber(const APaper: String): Integer; +var + i: Integer; +begin + i := FPapers.IndexOf(APaper); + if i = -1 then + i := 0; + Result := Integer(FPapers.Objects[i]); +end; + + +{ TfrxVirtualPrinter } + +procedure TfrxVirtualPrinter.Init; +var + i: Integer; +begin + if FInitialized then Exit; + + FDPI := Point(600, 600); + FDefPaper := DMPAPER_A4; + FDefOrientation := poPortrait; + FDefPaperWidth := 210; + FDefPaperHeight := 297; + + for i := 0 to PAPERCOUNT - 1 do + FPapers.AddObject(PaperInfo[i].Name, Pointer(PaperInfo[i].Typ)); + + FBin := -1; + FDuplex := -1; + FInitialized := True; +end; + +procedure TfrxVirtualPrinter.Abort; +begin +end; + +procedure TfrxVirtualPrinter.BeginDoc; +begin +end; + +procedure TfrxVirtualPrinter.BeginPage; +begin +end; + +procedure TfrxVirtualPrinter.EndDoc; +begin +end; + +procedure TfrxVirtualPrinter.EndPage; +begin +end; + +procedure TfrxVirtualPrinter.BeginRAWDoc; +begin +end; + +procedure TfrxVirtualPrinter.EndRAWDoc; +begin +end; + +procedure TfrxVirtualPrinter.WriteRAWDoc(const buf: AnsiString); +begin +end; + +procedure TfrxVirtualPrinter.SetViewParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation); +var + i: Integer; + Found: Boolean; +begin + Found := False; + if APaperSize <> 256 then + for i := 0 to PAPERCOUNT - 1 do + if PaperInfo[i].Typ = APaperSize then + begin + if AOrientation = poPortrait then + begin + APaperWidth := PaperInfo[i].X / 10; + APaperHeight := PaperInfo[i].Y / 10; + end + else + begin + APaperWidth := PaperInfo[i].Y / 10; + APaperHeight := PaperInfo[i].X / 10; + end; + Found := True; + break; + end; + + if not Found then + APaperSize := 256; + + FOrientation := AOrientation; + FPaper := APaperSize; + FPaperWidth := APaperWidth; + FPaperHeight := APaperHeight; + FLeftMargin := 5; + FTopMargin := 5; + FRightMargin := 5; + FBottomMargin := 5; +end; + +procedure TfrxVirtualPrinter.SetPrintParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation; + ABin, ADuplex, ACopies: Integer); +begin + SetViewParams(APaperSize, APaperWidth, APaperHeight, AOrientation); + FBin := ABin; +end; + +procedure TfrxVirtualPrinter.PropertiesDlg; +begin +end; + + +{ TfrxPrinter } + +destructor TfrxPrinter.Destroy; +begin + FreeDevMode; + inherited; +end; + +procedure TfrxPrinter.Init; + + procedure FillPapers; + var + i, PaperSizesCount: Integer; + PaperSizes: array[0..255] of Word; + PaperNames: PChar; + begin + FillChar(PaperSizes, SizeOf(PaperSizes), 0); + PaperSizesCount := DeviceCapabilities(PChar(FName), PChar(FPort), DC_PAPERS, @PaperSizes, FMode); + GetMem(PaperNames, PaperSizesCount * 64 * sizeof(char)); + DeviceCapabilities(PChar(FName), PChar(FPort), DC_PAPERNAMES, PaperNames, FMode); + for i := 0 to PaperSizesCount - 1 do + if PaperSizes[i] <> 256 then +{$IFDEF Delphi12} + FPapers.AddObject(StrPas(PWideChar(PaperNames + i * 64)), Pointer(PaperSizes[i])); +{$ELSE} + FPapers.AddObject(StrPas(PAnsiChar(PaperNames + i * 64)), Pointer(PaperSizes[i])); +{$ENDIF} + + FreeMem(PaperNames, PaperSizesCount * 64 * sizeof(char)); + end; + + procedure FillBins; + var + i, BinsCount: Integer; + BinNumbers: array[0..255] of Word; + BinNames: PChar; + begin + FillChar(BinNumbers, SizeOf(BinNumbers), 0); + BinsCount := DeviceCapabilities(PChar(FName), PChar(FPort), DC_BINS, @BinNumbers[0], FMode); + GetMem(BinNames, BinsCount * 24 * sizeof(char)); + DeviceCapabilities(PChar(FName), PChar(FPort), DC_BINNAMES, BinNames, FMode); + + for i := 0 to BinsCount - 1 do + if BinNumbers[i] <> DMBIN_AUTO then +{$IFDEF Delphi12} + FBins.AddObject(StrPas(PwideChar(BinNames + i * 24)), Pointer(BinNumbers[i])); +{$ELSE} + FBins.AddObject(StrPas(BinNames + i * 24), Pointer(BinNumbers[i])); +{$ENDIF} + + FreeMem(BinNames, BinsCount * 24 * sizeof(char)); + end; + +begin + if FInitialized then Exit; + CreateDevMode; + if FDeviceMode = 0 then Exit; + RecreateDC; + + if not UpdateDeviceCaps then + begin + FreeDevMode; + Exit; + end; + + FDefPaper := FMode.dmPaperSize; + FPaper := FDefPaper; + FDefPaperWidth := FPaperWidth; + FDefPaperHeight := FPaperHeight; + if FMode.dmOrientation = DMORIENT_PORTRAIT then + FDefOrientation := poPortrait else + FDefOrientation := poLandscape; + FOrientation := FDefOrientation; + FillPapers; + FillBins; + FBin := -1; + FDuplex := -1; + + FInitialized := True; +end; + +procedure TfrxPrinter.Abort; +begin + AbortDoc(FDC); + EndDoc; +end; + +procedure TfrxPrinter.BeginDoc; +var + DocInfo: TDocInfo; +begin + FPrinting := True; + + FillChar(DocInfo, SizeOf(DocInfo), 0); + DocInfo.cbSize := SizeOf(DocInfo); + if FTitle <> '' then + DocInfo.lpszDocName := PChar(FTitle) + else DocInfo.lpszDocName := PChar('Fast Report Document'); + + if FFileName <> '' then + DocInfo.lpszOutput := PChar(FFileName); + + RecreateDC; + StartDoc(FDC, DocInfo); +end; + +procedure TfrxPrinter.BeginPage; +begin + StartPage(FDC); +end; + +procedure TfrxPrinter.EndDoc; +var + Saved8087CW: Word; +begin + Saved8087CW := Default8087CW; + Set8087CW($133F); + try + Windows.EndDoc(FDC); + except + end; + Set8087CW(Saved8087CW); + + FPrinting := False; + RecreateDC; + FBin := -1; + FDuplex := -1; +end; + +procedure TfrxPrinter.EndPage; +begin + Windows.EndPage(FDC); +end; + +procedure TfrxPrinter.BeginRAWDoc; +var + DocInfo1: TDocInfo1; +begin + RecreateDC; + DocInfo1.pDocName := PChar(FTitle); + DocInfo1.pOutputFile := nil; + DocInfo1.pDataType := 'RAW'; + StartDocPrinter(FHandle, 1, @DocInfo1); + StartPagePrinter(FHandle); +end; + +procedure TfrxPrinter.EndRAWDoc; +begin + EndPagePrinter(FHandle); + EndDocPrinter(FHandle); +end; + +procedure TfrxPrinter.WriteRAWDoc(const buf: AnsiString); +var + N: DWORD; +begin + WritePrinter(FHandle, PAnsiChar(buf), Length(buf), N); +end; + +procedure TfrxPrinter.CreateDevMode; +var + bufSize: Integer; +{$IFNDEF Delphi12} + dm: TDeviceMode; +{$ENDIF} +begin + if OpenPrinter(PChar(FName), FHandle, nil) then + begin +{$IFDEF Delphi12} + bufSize := DocumentProperties(0, FHandle, PChar(FName), nil, nil, 0); +{$ELSE} + bufSize := DocumentProperties(0, FHandle, PChar(FName), dm, dm, 0); +{$ENDIF} + if bufSize > 0 then + begin + FDeviceMode := GlobalAlloc(GHND, bufSize); + if FDeviceMode <> 0 then + begin + FMode := GlobalLock(FDeviceMode); + if DocumentProperties(0, FHandle, PChar(FName), FMode^, FMode^, + DM_OUT_BUFFER) < 0 then + begin + GlobalUnlock(FDeviceMode); + GlobalFree(FDeviceMode); + FDeviceMode := 0; + FMode := nil; + end + end; + end; + end; +end; + +procedure TfrxPrinter.FreeDevMode; +begin + FCanvas.Handle := 0; + if FDC <> 0 then + DeleteDC(FDC); + if FHandle <> 0 then + ClosePrinter(FHandle); + if FDeviceMode <> 0 then + begin + GlobalUnlock(FDeviceMode); + GlobalFree(FDeviceMode); + end; + FDeviceMode := 0; + FDC := 0; + FHandle := 0; +end; + +procedure TfrxPrinter.RecreateDC; +begin + if FDC <> 0 then + try + DeleteDC(FDC); + except + end; + FDC := 0; + GetDC; +end; + +procedure TfrxPrinter.GetDC; +begin + if FDC = 0 then + begin + if FPrinting then + FDC := CreateDC(PChar(FDriver), PChar(FName), nil, FMode) else + FDC := CreateIC(PChar(FDriver), PChar(FName), nil, FMode); + FCanvas.Handle := FDC; + FCanvas.Refresh; + FCanvas.UpdateFont; + end; +end; + +procedure TfrxPrinter.SetViewParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation); +begin + if APaperSize <> 256 then + begin + FMode.dmFields := DM_PAPERSIZE or DM_ORIENTATION; + FMode.dmPaperSize := APaperSize; + if AOrientation = poPortrait then + FMode.dmOrientation := DMORIENT_PORTRAIT else + FMode.dmOrientation := DMORIENT_LANDSCAPE; + RecreateDC; + if not UpdateDeviceCaps then Exit; + end + else + begin + // copy the margins from A4 paper + SetViewParams(DMPAPER_A4, 0, 0, AOrientation); + FPaperHeight := APaperHeight; + FPaperWidth := APaperWidth; + end; + + FPaper := APaperSize; + FOrientation := AOrientation; +end; + +procedure TfrxPrinter.SetPrintParams(APaperSize: Integer; + APaperWidth, APaperHeight: Extended; AOrientation: TPrinterOrientation; + ABin, ADuplex, ACopies: Integer); +begin + FMode.dmFields := FMode.dmFields or DM_PAPERSIZE or DM_ORIENTATION or DM_COPIES; + if ADuplex <> FMode.dmDuplex then + FMode.dmFields := FMode.dmFields or DM_DUPLEX; + if ABin <> FMode.dmDefaultSource then + FMode.dmFields := FMode.dmFields or DM_DEFAULTSOURCE; + + if APaperSize = 256 then + begin + FMode.dmFields := FMode.dmFields or DM_PAPERLENGTH or DM_PAPERWIDTH; + if (AOrientation = poLandscape) and FSwapPaperSize then + begin + FMode.dmPaperLength := Round(APaperWidth * 10); + FMode.dmPaperWidth := Round(APaperHeight * 10); + end + else + begin + FMode.dmPaperLength := Round(APaperHeight * 10); + FMode.dmPaperWidth := Round(APaperWidth * 10); + end; + end + else + begin + FMode.dmPaperLength := 0; + FMode.dmPaperWidth := 0; + end; + + FMode.dmPaperSize := APaperSize; + + if AOrientation = poPortrait then + FMode.dmOrientation := DMORIENT_PORTRAIT else + FMode.dmOrientation := DMORIENT_LANDSCAPE; + + FMode.dmCopies := ACopies; + if FBin <> -1 then + ABin := FBin; + if ABin <> FMode.dmDefaultSource then + FMode.dmDefaultSource := ABin; + if FDuplex <> -1 then + ADuplex := FDuplex; + if ADuplex = 4 then + FMode.dmDuplex := DMDUP_SIMPLEX + else if ADuplex <> FMode.dmDuplex then + FMode.dmDuplex := ADuplex; + + FDC := ResetDC(FDC, FMode^); + FDC := ResetDC(FDC, FMode^); // needed for some printers + FCanvas.Refresh; + if not UpdateDeviceCaps then Exit; + FPaper := APaperSize; + FOrientation := AOrientation; +end; + +function TfrxPrinter.UpdateDeviceCaps: Boolean; +begin + Result := True; + if FDC = 0 then GetDC; + + FDPI := Point(GetDeviceCaps(FDC, LOGPIXELSX), GetDeviceCaps(FDC, LOGPIXELSY)); + if (FDPI.X = 0) or (FDPI.Y = 0) then + begin + Result := False; + frxErrorMsg('Printer selected is not valid'); + Exit; + end; + FPaperHeight := Round(GetDeviceCaps(FDC, PHYSICALHEIGHT) / FDPI.Y * 25.4); + FPaperWidth := Round(GetDeviceCaps(FDC, PHYSICALWIDTH) / FDPI.X * 25.4); + FLeftMargin := Round(GetDeviceCaps(FDC, PHYSICALOFFSETX) / FDPI.X * 25.4); + FTopMargin := Round(GetDeviceCaps(FDC, PHYSICALOFFSETY) / FDPI.Y * 25.4); + FRightMargin := FPaperWidth - Round(GetDeviceCaps(FDC, HORZRES) / FDPI.X * 25.4) - FLeftMargin; + FBottomMargin := FPaperHeight - Round(GetDeviceCaps(FDC, VERTRES) / FDPI.Y * 25.4) - FTopMargin; +end; + +procedure TfrxPrinter.PropertiesDlg; +var + h: THandle; + PrevDuplex: Integer; +begin + PrevDuplex := FMode.dmDuplex; + if Screen.ActiveForm <> nil then + h := Screen.ActiveForm.Handle else + h := 0; + if DocumentProperties(h, FHandle, PChar(FName), FMode^, + FMode^, DM_IN_BUFFER or DM_OUT_BUFFER or DM_IN_PROMPT) > 0 then + begin + FBin := FMode.dmDefaultSource; + if PrevDuplex <> FMode.dmDuplex then + FDuplex := FMode.dmDuplex; + RecreateDC; + end; +end; + +{ TfrxPrinters } + +constructor TfrxPrinters.Create; +begin + FPrinterList := TList.Create; + FPrinters := TStringList.Create; + + FillPrinters; + if FPrinterList.Count = 0 then + begin + FPrinterList.Add(TfrxVirtualPrinter.Create(frxResources.Get('prVirtual'), '')); + FHasPhysicalPrinters := False; + PrinterIndex := 0; + end + else + begin + FHasPhysicalPrinters := True; + PrinterIndex := IndexOf(GetDefaultPrinter); + if PrinterIndex = -1 then // important + PrinterIndex := 0; + end; +end; + +destructor TfrxPrinters.Destroy; +begin + Clear; + FPrinterList.Free; + FPrinters.Free; + inherited; +end; + +procedure TfrxPrinters.Clear; +begin + while FPrinterList.Count > 0 do + begin + TObject(FPrinterList[0]).Free; + FPrinterList.Delete(0); + end; + FPrinters.Clear; +end; + +function TfrxPrinters.GetItem(Index: Integer): TfrxCustomPrinter; +begin + if Index >= 0 then + Result := FPrinterList[Index] + else + Result := nil +end; + +function TfrxPrinters.IndexOf(AName: String): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to FPrinterList.Count - 1 do + if AnsiCompareText(Items[i].Name, AName) = 0 then + begin + Result := i; + break; + end; +end; + +procedure TfrxPrinters.SetPrinterIndex(Value: Integer); +begin + if Value <> -1 then + FPrinterIndex := Value + else + FPrinterIndex := IndexOf(GetDefaultPrinter); + if FPrinterIndex <> -1 then + Items[FPrinterIndex].Init; +end; + +function TfrxPrinters.GetCurrentPrinter: TfrxCustomPrinter; +begin + Result := Items[PrinterIndex]; +end; + +function TfrxPrinters.GetDefaultPrinter: String; +var + prnName: array[0..255] of Char; +begin + GetProfileString('windows', 'device', '', prnName, 255); + Result := Copy(prnName, 1, Pos(',', prnName) - 1); +end; + +procedure TfrxPrinters.FillPrinters; +var + i, j: Integer; + Buf, prnInfo: PByte; + Flags, bufSize, prnCount: DWORD; + Level: Byte; + sl: TStringList; + + procedure AddPrinter(ADevice, APort: String); + begin + FPrinterList.Add(TfrxPrinter.Create(ADevice, APort)); + FPrinters.Add(ADevice); + end; + +begin + Clear; + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL; + Level := 4; + end + else + begin + Flags := PRINTER_ENUM_LOCAL; + Level := 5; + end; + + bufSize := 0; + EnumPrinters(Flags, nil, Level, nil, 0, bufSize, prnCount); + if bufSize = 0 then Exit; + + GetMem(Buf, bufSize); + try + + if not EnumPrinters(Flags, nil, Level, PByte(Buf), bufSize, bufSize, prnCount) then + Exit; + prnInfo := Buf; + for i := 0 to prnCount - 1 do + if Level = 4 then + with PPrinterInfo4(prnInfo)^ do + begin + AddPrinter(pPrinterName, ''); + Inc(prnInfo, SizeOf(TPrinterInfo4)); + end + else + with PPrinterInfo5(prnInfo)^ do + begin + sl := TStringList.Create; + frxSetCommaText(pPortName, sl, ','); + + for j := 0 to sl.Count - 1 do + AddPrinter(pPrinterName, sl[j]); + + sl.Free; + Inc(prnInfo, SizeOf(TPrinterInfo5)); + end; + + finally + FreeMem(Buf, bufSize); + end; +end; + + + +function frxPrinters: TfrxPrinters; +begin + if FPrinters = nil then + FPrinters := TfrxPrinters.Create; + Result := FPrinters; +end; + + +initialization + +finalization + if FPrinters <> nil then + FPrinters.Free; + FPrinters := nil; + +end. + + +// diff --git a/official/4.8.11/Source/frxProgress.dfm b/official/4.8.11/Source/frxProgress.dfm new file mode 100644 index 0000000..eeb58fa Binary files /dev/null and b/official/4.8.11/Source/frxProgress.dfm differ diff --git a/official/4.8.11/Source/frxProgress.pas b/official/4.8.11/Source/frxProgress.pas new file mode 100644 index 0000000..854f0c4 --- /dev/null +++ b/official/4.8.11/Source/frxProgress.pas @@ -0,0 +1,169 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Progress } +{ } +{ Copyright (c) 2004-2008 } +{ by Alexander Fediachov, } +{ Fast Reports, Inc. } +{ } +{******************************************} + +unit frxProgress; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ComCtrls, StdCtrls, ExtCtrls; + +type + TfrxProgress = class(TForm) + Panel1: TPanel; + LMessage: TLabel; + Bar: TProgressBar; + CancelB: TButton; + procedure WMNCHitTest(var Message :TWMNCHitTest); message WM_NCHITTEST; + procedure FormCreate(Sender: TObject); + procedure CancelBClick(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + FActiveForm: TForm; + FTerminated: Boolean; + FPosition: Integer; + FMessage: String; + FProgress: Boolean; + procedure SetPosition(Value: Integer); + procedure SetMessage(const Value: String); + procedure SetTerminated(Value: Boolean); + procedure SetProgress(Value: Boolean); + public + procedure Reset; + procedure Execute(MaxValue: Integer; const Msg: String; + Canceled: Boolean; Progress: Boolean); + procedure Tick; + property Terminated: Boolean read FTerminated write SetTerminated; + property Position: Integer read FPosition write SetPosition; + property ShowProgress: Boolean read FProgress write SetProgress; + property Message: String read FMessage write SetMessage; + end; + + +implementation + +{$R *.DFM} + +uses frxRes; + +{ TfrxProgress } + +procedure TfrxProgress.WMNCHitTest(var Message: TWMNCHitTest); +begin + inherited; + if Message.Result = htClient then + Message.Result := htCaption; +end; + +procedure TfrxProgress.FormCreate(Sender: TObject); +begin + CancelB.Caption := frxGet(2); + FActiveForm := Screen.ActiveForm; + if FActiveForm <> nil then + begin + FActiveForm.Enabled := False; + end; + Bar.Min := 0; + Bar.Max := 100; + Position := 0; + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxProgress.FormDestroy(Sender: TObject); +begin + if FActiveForm <> nil then + FActiveForm.Enabled := True; +end; + +procedure TfrxProgress.FormHide(Sender: TObject); +begin + if FActiveForm <> nil then + FActiveForm.Enabled := True; +end; + +procedure TfrxProgress.Reset; +begin + Position := 0; +end; + +procedure TfrxProgress.SetPosition(Value: Integer); +begin + FPosition := Value; + Bar.Position := Value; + BringToFront; + Application.ProcessMessages; +end; + +procedure TfrxProgress.Execute(MaxValue: Integer; const Msg: String; + Canceled: Boolean; Progress: Boolean); +begin + Terminated := False; + CancelB.Visible := Canceled; + ShowProgress := Progress; + Bar.Min := 0; + Reset; + Bar.Max := MaxValue; + Message := Msg; + Show; +{$IFDEF Delphi6} + if FActiveForm <> nil then + begin + Self.MakeFullyVisible(FActiveForm.Monitor);//DualView workground + end; +{$ENDIF} + Application.ProcessMessages; +end; + +procedure TfrxProgress.Tick; +begin + if (Position < Bar.Max) and (Position >= Bar.Min) then + Position := Position + 1; +end; + +procedure TfrxProgress.SetMessage(const Value: String); +begin + FMessage := Value; + LMessage.Caption := Value; + LMessage.Refresh; +end; + +procedure TfrxProgress.CancelBClick(Sender: TObject); +begin + Terminated := True; +end; + +procedure TfrxProgress.SetTerminated(Value: boolean); +begin + FTerminated := Value; + if Value then Close; +end; + +procedure TfrxProgress.SetProgress(Value: boolean); +begin + Bar.Visible := Value; + FProgress := Value; + if Value then + LMessage.Top := 15 + else + LMessage.Top := 35; +end; + +end. + + + +// diff --git a/official/4.8.11/Source/frxReg.dcr b/official/4.8.11/Source/frxReg.dcr new file mode 100644 index 0000000..6ae3f88 Binary files /dev/null and b/official/4.8.11/Source/frxReg.dcr differ diff --git a/official/4.8.11/Source/frxReg.pas b/official/4.8.11/Source/frxReg.pas new file mode 100644 index 0000000..4d87291 --- /dev/null +++ b/official/4.8.11/Source/frxReg.pas @@ -0,0 +1,145 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Registration unit } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxReg; + +{$I frx.inc} +//{$I frxReg.inc} + +interface + + +procedure Register; + +implementation + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, +{$IFNDEF Delphi6} + DsgnIntf, +{$ELSE} + DesignIntf, DesignEditors, +{$ENDIF} +{$IFDEF Delphi9} + ToolsAPI, +{$ENDIF} + Dialogs, frxClass, + frxDock, frxCtrls, frxDesgnCtrls, + frxDesgn, frxPreview, frxRich, frxOLE, frxBarCode, + frxChBox, frxDMPExport, +{$IFNDEF FR_VER_BASIC} + frxDCtrl, +{$ENDIF} + frxCross, frxRichEdit, frxGradient, + frxGZip, frxEditAliases, frxCrypt; + +{-----------------------------------------------------------------------} +type + TfrxReportEditor = class(TComponentEditor) + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): String; override; + function GetVerbCount: Integer; override; + end; + + TfrxDataSetEditor = class(TComponentEditor) + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): String; override; + function GetVerbCount: Integer; override; + end; + + +{ TfrxReportEditor } + +procedure TfrxReportEditor.ExecuteVerb(Index: Integer); +var + Report: TfrxReport; +begin + Report := TfrxReport(Component); + if Report.Designer <> nil then + Report.Designer.BringToFront + else + begin + Report.DesignReport(Designer, Self); + if Report.StoreInDFM then + Designer.Modified; + end; +end; + +function TfrxReportEditor.GetVerb(Index: Integer): String; +begin + Result := 'Edit Report...'; +end; + +function TfrxReportEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + + +{ TfrxDataSetEditor } + +procedure TfrxDataSetEditor.ExecuteVerb(Index: Integer); +begin + with TfrxAliasesEditorForm.Create(Application) do + begin + DataSet := TfrxCustomDBDataSet(Component); + if ShowModal = mrOk then + Self.Designer.Modified; + Free; + end; +end; + +function TfrxDataSetEditor.GetVerb(Index: Integer): String; +begin + Result := 'Edit Fields Aliases...'; +end; + +function TfrxDataSetEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + + +{-----------------------------------------------------------------------} +procedure Register; +begin +{$IFDEF Delphi9} + SplashScreenServices.AddPluginBitmap('Fast Report 4', + LoadBitmap(HInstance, 'SPLASH_ICON')); +{$ENDIF} + RegisterComponents('FastReport 4.0', + [TfrxReport, TfrxUserDataset, +{$IFNDEF FR_VER_BASIC} + TfrxDesigner, +{$ENDIF} + TfrxPreview, + TfrxBarcodeObject, TfrxOLEObject, TfrxRichObject, + TfrxCrossObject, TfrxCheckBoxObject, TfrxGradientObject, + TfrxDotMatrixExport +{$IFNDEF FR_VER_BASIC} + , TfrxDialogControls +{$ENDIF} + , TfrxGZipCompressor, TfrxCrypt + ]); + + RegisterComponents('FR4 tools', + [TfrxDockSite, TfrxTBPanel, TfrxComboEdit, + TfrxComboBox, TfrxFontComboBox, TfrxRuler, TfrxScrollBox]); + + RegisterComponentEditor(TfrxReport, TfrxReportEditor); + RegisterComponentEditor(TfrxCustomDBDataSet, TfrxDataSetEditor); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxRegDB.pas b/official/4.8.11/Source/frxRegDB.pas new file mode 100644 index 0000000..7fb46d4 --- /dev/null +++ b/official/4.8.11/Source/frxRegDB.pas @@ -0,0 +1,48 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Registration unit } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRegDB; + +{$I frx.inc} + +interface + + +procedure Register; + +implementation + +uses + Windows, Messages, SysUtils, Classes, Forms, Controls, +{$IFNDEF Delphi6} + DsgnIntf, +{$ELSE} + DesignIntf, DesignEditors, +{$ENDIF} + frxDBSet, + frxCustomDB, + frxCustomDBEditor, + frxCustomDBRTTI, + frxEditMD, + frxEditQueryParams; + + +{-----------------------------------------------------------------------} +procedure Register; +begin + RegisterComponents('FastReport 4.0', [TfrxDBDataset]); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxRegIBO.pas b/official/4.8.11/Source/frxRegIBO.pas new file mode 100644 index 0000000..811fce8 --- /dev/null +++ b/official/4.8.11/Source/frxRegIBO.pas @@ -0,0 +1,42 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Registration unit } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRegIBO; + +{$I frx.inc} + +interface + + +procedure Register; + +implementation + +uses + Windows, Messages, SysUtils, Classes, Forms, Controls, +{$IFNDEF Delphi6} + DsgnIntf, +{$ELSE} + DesignIntf, DesignEditors, +{$ENDIF} + frxIBOSet; + +{-----------------------------------------------------------------------} +procedure Register; +begin + RegisterComponents('FastReport 4.0', [TfrxIBODataset]); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxRegTee.pas b/official/4.8.11/Source/frxRegTee.pas new file mode 100644 index 0000000..7eaab7c --- /dev/null +++ b/official/4.8.11/Source/frxRegTee.pas @@ -0,0 +1,43 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Registration unit } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRegTee; + +{$I frx.inc} + +interface + + +procedure Register; + +implementation + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, +{$IFNDEF Delphi6} + DsgnIntf, +{$ELSE} + DesignIntf, DesignEditors, +{$ENDIF} + frxChart; + + +procedure Register; +begin + RegisterComponents('FastReport 4.0', + [TfrxChartObject]); +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxReportTree.dfm b/official/4.8.11/Source/frxReportTree.dfm new file mode 100644 index 0000000..d27ad2a Binary files /dev/null and b/official/4.8.11/Source/frxReportTree.dfm differ diff --git a/official/4.8.11/Source/frxReportTree.pas b/official/4.8.11/Source/frxReportTree.pas new file mode 100644 index 0000000..741d9d8 --- /dev/null +++ b/official/4.8.11/Source/frxReportTree.pas @@ -0,0 +1,214 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Report Tree } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxReportTree; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ComCtrls, frxClass +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxReportTreeForm = class(TForm) + Tree: TTreeView; + procedure FormShow(Sender: TObject); + procedure TreeChange(Sender: TObject; Node: TTreeNode); + procedure FormCreate(Sender: TObject); + procedure TreeKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + FComponents: TList; + FDesigner: TfrxCustomDesigner; + FNodes: TList; + FReport: TfrxReport; + FUpdating: Boolean; + FOnSelectionChanged: TNotifyEvent; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetColor(Value: TColor); + procedure UpdateItems; + procedure UpdateSelection; + property OnSelectionChanged: TNotifyEvent read FOnSelectionChanged + write FOnSelectionChanged; + end; + + +implementation + +{$R *.DFM} + +uses frxRes, frxDesgn, frxDsgnIntf; + +type + THackWinControl = class(TWinControl); + + +{ TfrxReportTreeForm } + +constructor TfrxReportTreeForm.Create(AOwner: TComponent); +begin + inherited; + FComponents := TList.Create; + FNodes := TList.Create; +{$IFDEF UseTabset} + Tree.BevelKind := bkFlat; +{$ELSE} + Tree.BorderStyle := bsSingle; +{$ENDIF} +end; + +destructor TfrxReportTreeForm.Destroy; +begin + FComponents.Free; + FNodes.Free; + inherited; +end; + +procedure TfrxReportTreeForm.FormShow(Sender: TObject); +begin + UpdateItems; +end; + +procedure TfrxReportTreeForm.UpdateItems; + + procedure SetImageIndex(Node: TTreeNode; Index: Integer); + begin + Node.ImageIndex := Index; + Node.StateIndex := Index; + Node.SelectedIndex := Index; + end; + + procedure EnumItems(c: TfrxComponent; RootNode: TTreeNode); + var + i: Integer; + Node: TTreeNode; + Item: TfrxObjectItem; + begin + Node := Tree.Items.AddChild(RootNode, c.Name); + FComponents.Add(c); + FNodes.Add(Node); + Node.Data := c; + if c is TfrxReport then + begin + Node.Text := 'Report'; + SetImageIndex(Node, 34); + end + else if c is TfrxReportPage then + SetImageIndex(Node, 35) + else if c is TfrxDialogPage then + SetImageIndex(Node, 36) + else if c is TfrxDataPage then + SetImageIndex(Node, 37) + else if c is TfrxBand then + SetImageIndex(Node, 40) + else + begin + for i := 0 to frxObjects.Count - 1 do + begin + Item := frxObjects[i]; + if Item.ClassRef = c.ClassType then + begin + SetImageIndex(Node, Item.ButtonImageIndex); + break; + end; + end; + end; + + if c is TfrxDataPage then + begin + for i := 0 to c.Objects.Count - 1 do + if TObject(c.Objects[i]) is TfrxDialogComponent then + EnumItems(c.Objects[i], Node) + end + else + for i := 0 to c.Objects.Count - 1 do + EnumItems(c.Objects[i], Node); + end; + +begin + Tree.Items.BeginUpdate; + Tree.Items.Clear; + FComponents.Clear; + FNodes.Clear; + EnumItems(FReport, nil); + + Tree.FullExpand; + UpdateSelection; + Tree.Items.EndUpdate; +end; + +procedure TfrxReportTreeForm.TreeChange(Sender: TObject; Node: TTreeNode); +begin + if FUpdating then Exit; + FDesigner.SelectedObjects.Clear; + FDesigner.SelectedObjects.Add(Tree.Selected.Data); + if Assigned(FOnSelectionChanged) then + FOnSelectionChanged(Self); +end; + +procedure TfrxReportTreeForm.SetColor(Value: TColor); +begin + Tree.Color := Value; + UpdateItems; +end; + +procedure TfrxReportTreeForm.FormCreate(Sender: TObject); +begin + FDesigner := TfrxCustomDesigner(Owner); + FReport := FDesigner.Report; + Tree.Images := frxResources.ObjectImages; + Caption := frxGet(2200); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxReportTreeForm.UpdateSelection; +var + c: TComponent; + i: Integer; +begin + if FDesigner.SelectedObjects.Count = 0 then Exit; + c := FDesigner.SelectedObjects[0]; + FUpdating := True; + + i := FComponents.IndexOf(c); + if i <> -1 then + begin + TTreeNode(FNodes[i]).Selected := True; + Tree.TopItem := TTreeNode(FNodes[i]); + end; + + FUpdating := False; +end; + +procedure TfrxReportTreeForm.TreeKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = vk_Delete then + begin + THackWinControl(TfrxDesignerForm(FDesigner).Workspace).KeyDown(Key, Shift); + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxRes.pas b/official/4.8.11/Source/frxRes.pas new file mode 100644 index 0000000..38349c4 --- /dev/null +++ b/official/4.8.11/Source/frxRes.pas @@ -0,0 +1,569 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Language resources management } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRes; + +interface + +{$I frx.inc} + +uses + Windows, SysUtils, Classes, Controls, Graphics, Forms, ImgList, TypInfo, frxUnicodeUtils +{$IFDEF Delphi6} +, Variants +{$ENDIF} +{$IFDEF FR_COM} +, ComObj +, FastReport_TLB +, DispatchablePersistent +{$ENDIF} +{$IFDEF Delphi10} +, WideStrings +{$ENDIF} +; + + +type +{$IFDEF FR_COM} + TfrxResources = class(TDispatchablePersistent, IfrxResources) +{$ELSE} + TfrxResources = class(TObject) +{$ENDIF} + private + FDisabledButtonImages: TImageList; + FMainButtonImages: TImageList; + FNames: TStringList; + FObjectImages: TImageList; + FPreviewButtonImages: TImageList; + FValues: TWideStrings;// TStringList; + FWizardImages: TImageList; + FLanguages: TStringList; + FHelpFile: String; + FCP: Cardinal; + procedure BuildLanguagesList; + function GetMainButtonImages: TImageList; + function GetObjectImages: TImageList; + function GetPreviewButtonImages: TImageList; + function GetWizardImages: TImageList; + public + constructor Create; + destructor Destroy; override; + function Get(const StrName: String): String; + procedure Add(const Ref, Str: String); + procedure AddW(const Ref: String; Str: WideString); + procedure AddStrings(const Str: String); + procedure AddXML(const Str: AnsiString); + procedure Clear; + procedure LoadFromFile(const FileName: String); + procedure LoadFromStream(Stream: TStream); + procedure SetButtonImages(Images: TBitmap; Clear: Boolean = False); + procedure SetObjectImages(Images: TBitmap; Clear: Boolean = False); + procedure SetPreviewButtonImages(Images: TBitmap; Clear: Boolean = False); + procedure SetWizardImages(Images: TBitmap; Clear: Boolean = False); + procedure UpdateFSResources; + procedure Help(Sender: TObject); overload; + property DisabledButtonImages: TImageList read FDisabledButtonImages; + property MainButtonImages: TImageList read GetMainButtonImages; + property PreviewButtonImages: TImageList read GetPreviewButtonImages; + property ObjectImages: TImageList read GetObjectImages; + property WizardImages: TImageList read GetWizardImages; + property Languages: TStringList read FLanguages; + property HelpFile: String read FHelpFile write FHelpFile; +{$IFDEF FR_COM} + function Get_HelpFile(out Value: WideString): HResult; stdcall; + function Set_HelpFile(const Value: WideString): HResult; stdcall; + function Help: HResult; overload; stdcall; + function GetResourceString(const ID: WideString; out Value: WideString): HResult; stdcall; + function LoadLanguageResourcesFromFile(const FileName: WideString): HResult; stdcall; +{$ENDIF} + end; + +function frxResources: TfrxResources; +function frxGet(ID: Integer): String; + + +implementation + +uses frxUtils, frxChm, fs_iconst, frxGZip, frxXML; + +var + FResources: TfrxResources = nil; + + +{ TfrxResources } + +constructor TfrxResources.Create; +begin + try +{$IFDEF FR_COM} + inherited Create(IfrxResources); +{$ELSE} + inherited; +{$ENDIF} + FDisabledButtonImages := TImageList.Create(nil); + FDisabledButtonImages.Width := 16; + FDisabledButtonImages.Height := 16; + FMainButtonImages := TImageList.Create(nil); + FMainButtonImages.Width := 16; + FMainButtonImages.Height := 16; + FObjectImages := TImageList.Create(nil); + FObjectImages.Width := 16; + FObjectImages.Height := 16; + FPreviewButtonImages := TImageList.Create(nil); + FPreviewButtonImages.Width := 16; + FPreviewButtonImages.Height := 16; + FWizardImages := TImageList.Create(nil); + FWizardImages.Width := 32; + FWizardImages.Height := 32; + FNames := TStringList.Create; +{$IFDEF Delphi10} + FValues := TfrxWideStrings.Create; +{$ELSE} + FValues := TWideStrings.Create; +{$ENDIF} + FNames.Sorted := True; + FLanguages := TStringList.Create; + HelpFile := 'FRUser.chm'; + FCP := 0; + BuildLanguagesList; + finally + end; +end; + +destructor TfrxResources.Destroy; +begin + FLanguages.Free; + FDisabledButtonImages.Free; + FMainButtonImages.Free; + FObjectImages.Free; + FPreviewButtonImages.Free; + FWizardImages.Free; + FNames.Free; + FValues.Free; + inherited; +end; + +procedure TfrxResources.AddW(const Ref: String; Str: WideString); +var + i: Integer; +begin + i := FNames.IndexOf(Ref); + if i = -1 then + begin + FNames.AddObject(Ref, Pointer(FValues.Count)); + FValues.Add(Str); + end + else + FValues[Integer(FNames.Objects[i])] := Str; +end; + +procedure TfrxResources.Add(const Ref, Str: String); +begin +{$IFDEF Delphi12} + AddW(Ref, Str); +{$ELSE} + AddW(Ref, WideString(AnsiToUnicode(Str, DEFAULT_CHARSET, FCP))); +{$ENDIF} +end; + +procedure TfrxResources.AddStrings(const Str: String); +var + i: Integer; + sl: TWideStrings; + nm, vl: WideString; +begin +{$IFDEF Delphi10} + sl := TfrxWideStrings.Create; +{$ELSE} + sl := TWideStrings.Create; +{$ENDIF} + sl.Text := Str; + for i := 0 to sl.Count - 1 do + begin + nm := sl[i]; + vl := Copy(nm, Pos('=', nm) + 1, MaxInt); + nm := Copy(nm, 1, Pos('=', nm) - 1); + if (nm <> '') and (vl <> '') then + Add(nm, vl); + end; + sl.Free; +end; + +procedure TfrxResources.AddXML(const Str: AnsiString); +var + Stream: TStringStream; +begin + Stream := TStringStream.Create(Str); + LoadFromStream(Stream); + Stream.Free; +end; + +procedure TfrxResources.Clear; +begin + FNames.Clear; + FValues.Clear; +end; + +function TfrxResources.Get(const StrName: String): String; +var + i: Integer; +begin + i := FNames.IndexOf(StrName); + if i <> -1 then +{$IFDEF Delphi12} + Result := FValues[Integer(FNames.Objects[i])] else //_UnicodeToAnsi(FValues[Integer(FNames.Objects[i])], DEFAULT_CHARSET, FCP) else + Result := StrName; +{$ELSE} + Result := _UnicodeToAnsi(FValues[Integer(FNames.Objects[i])], DEFAULT_CHARSET, FCP) else + Result := StrName; +{$ENDIF} + if (Result <> '') and (Result[1] = '!') then + Delete(Result, 1, 1); +end; + + +function TfrxResources.GetMainButtonImages: TImageList; +var + Images: TBitmap; + stm: TMemoryStream; + res: TResourceStream; +begin + if FMainButtonImages.Count = 0 then + begin + Images := TBitmap.Create; + stm := TMemoryStream.Create; + res := TResourceStream.Create(hInstance, 'DesgnButtons', RT_RCDATA); + try + frxDecompressStream(res, stm); + stm.Position := 0; + Images.LoadFromStream(stm); + SetButtonImages(Images); + finally + stm.Free; + res.Free; + Images.Free; + end; + end; + + Result := FMainButtonImages; +end; + +function TfrxResources.GetPreviewButtonImages: TImageList; +var + Images: TBitmap; + stm: TMemoryStream; + res: TResourceStream; +begin + if FPreviewButtonImages.Count = 0 then + begin + Images := TBitmap.Create; + stm := TMemoryStream.Create; + res := TResourceStream.Create(hInstance, 'PreviewButtons', RT_RCDATA); + try + frxDecompressStream(res, stm); + stm.Position := 0; + Images.LoadFromStream(stm); + SetPreviewButtonImages(Images); + finally + stm.Free; + res.Free; + Images.Free; + end; + end; + + Result := FPreviewButtonImages; +end; + +function TfrxResources.GetObjectImages: TImageList; +var + Images: TBitmap; + stm: TMemoryStream; + res: TResourceStream; +begin + if FObjectImages.Count = 0 then + begin + Images := TBitmap.Create; + stm := TMemoryStream.Create; + res := TResourceStream.Create(hInstance, 'ObjectButtons', RT_RCDATA); + try + frxDecompressStream(res, stm); + stm.Position := 0; + Images.LoadFromStream(stm); + SetObjectImages(Images); + finally + stm.Free; + res.Free; + Images.Free; + end; + end; + + Result := FObjectImages; +end; + +function TfrxResources.GetWizardImages: TImageList; +var + Images: TBitmap; + stm: TMemoryStream; + res: TResourceStream; +begin + if FWizardImages.Count = 0 then + begin + Images := TBitmap.Create; + stm := TMemoryStream.Create; + res := TResourceStream.Create(hInstance, 'WizardButtons', RT_RCDATA); + try + frxDecompressStream(res, stm); + stm.Position := 0; + Images.LoadFromStream(stm); + SetWizardImages(Images); + finally + stm.Free; + res.Free; + Images.Free; + end; + end; + + Result := FWizardImages; +end; + +procedure TfrxResources.SetButtonImages(Images: TBitmap; Clear: Boolean = False); +begin + if Clear then + begin + FMainButtonImages.Clear; + FDisabledButtonImages.Clear; + end; + frxAssignImages(Images, 16, 16, FMainButtonImages, FDisabledButtonImages); +end; + +procedure TfrxResources.SetObjectImages(Images: TBitmap; Clear: Boolean = False); +begin + if Clear then + FObjectImages.Clear; + frxAssignImages(Images, 16, 16, FObjectImages); +end; + +procedure TfrxResources.SetPreviewButtonImages(Images: TBitmap; Clear: Boolean = False); +begin + if Clear then + FPreviewButtonImages.Clear; + frxAssignImages(Images, 16, 16, FPreviewButtonImages); +end; + +procedure TfrxResources.SetWizardImages(Images: TBitmap; Clear: Boolean = False); +begin + if Clear then + FWizardImages.Clear; + frxAssignImages(Images, 32, 32, FWizardImages); +end; + +procedure TfrxResources.LoadFromFile(const FileName: String); +var + f: TFileStream; +begin + if FileExists(FileName) then + begin + f := TFileStream.Create(FileName, fmOpenRead); + try + LoadFromStream(f); + finally + f.Free; + end; + end; +end; + +procedure TfrxResources.LoadFromStream(Stream: TStream); +var + FXMLRes: TfrxXMLDocument; + idx: Integer; +begin + FXMLRes := TfrxXMLDocument.Create; + FXMLRes.LoadFromStream(Stream); + try + with FXMLRes.Root do + begin + if Name = 'Resources' then + begin + FCP := StrToInt(Prop['CodePage']); + for idx := 0 to Count - 1 do + if Items[idx].Name = 'StrRes' then +{$IFDEF Delphi12} + if not FXMLRes.OldVersion then + Self.AddW(Items[idx].Prop['Name'], frxXMLToStr(Items[idx].Prop['Text'])) else +{$ENDIF} + Self.AddW(Items[idx].Prop['Name'], UTF8Decode(AnsiString(frxXMLToStr(Items[idx].Prop['Text'])))); + + end; + end; + finally + FXMLRes.Free; + end; + UpdateFSResources; +end; + +procedure TfrxResources.UpdateFSResources; +begin + SLangNotFound := Get('SLangNotFound'); + SInvalidLanguage := Get('SInvalidLanguage'); + SIdRedeclared := Get('SIdRedeclared'); + SUnknownType := Get('SUnknownType'); + SIncompatibleTypes := Get('SIncompatibleTypes'); + SIdUndeclared := Get('SIdUndeclared'); + SClassRequired := Get('SClassRequired'); + SIndexRequired := Get('SIndexRequired'); + SStringError := Get('SStringError'); + SClassError := Get('SClassError'); + SArrayRequired := Get('SArrayRequired'); + SVarRequired := Get('SVarRequired'); + SNotEnoughParams := Get('SNotEnoughParams'); + STooManyParams := Get('STooManyParams'); + SLeftCantAssigned := Get('SLeftCantAssigned'); + SForError := Get('SForError'); + SEventError := Get('SEventError'); +end; + +type + THelpTopic = record + Sender: String; + Topic: String; + end; + +const + helpTopicsCount = 17; + helpTopics: array[0..helpTopicsCount - 1] of THelpTopic = + ( +{$IFNDEF FR_COM} + (Sender: 'TfrxDesignerForm'; Topic: 'Designer.htm'),{$ELSE}(Sender: 'TfrxDesignerForm'; Topic: 'main.htm'), +{$ENDIF} + (Sender: 'TfrxOptionsEditor'; Topic: 'Designer_options.htm'), + (Sender: 'TfrxReportEditorForm'; Topic: 'Report_options.htm'), + (Sender: 'TfrxPageEditorForm'; Topic: 'Page_options.htm'), + (Sender: 'TfrxCrossEditorForm'; Topic: 'Cross_tab_reports.htm'), + (Sender: 'TfrxChartEditorForm'; Topic: 'Diagrams.htm'), + (Sender: 'TfrxSyntaxMemo'; Topic: 'Script.htm'), + (Sender: 'TfrxDialogPage'; Topic: 'Dialogue_forms.htm'), + (Sender: 'TfrxDialogComponent'; Topic: 'Data_access_components.htm'), + (Sender: 'TfrxVarEditorForm'; Topic: 'Variables.htm'), + (Sender: 'TfrxHighlightEditorForm'; Topic: 'Conditional_highlighting.htm'), + (Sender: 'TfrxSysMemoEditorForm'; Topic: 'Inserting_aggregate_function.htm'), + (Sender: 'TfrxFormatEditorForm'; Topic: 'Values_formatting.htm'), + (Sender: 'TfrxGroupEditorForm'; Topic: 'Report_with_groups.htm'), + (Sender: 'TfrxPictureEditorForm'; Topic: 'Picture_object.htm'), + (Sender: 'TfrxMemoEditorForm'; Topic: 'Text_object.htm'), + (Sender: 'TfrxSQLEditorForm'; Topic: 'TfrxADOQuery.htm') + ); + + + + +procedure TfrxResources.Help(Sender: TObject); +var + i: Integer; + topic: String; +begin + topic := ''; + if Sender <> nil then + for i := 0 to helpTopicsCount - 1 do + if CompareText(helpTopics[i].Sender, Sender.ClassName) = 0 then + topic := '::/' + helpTopics[i].Topic; +{$IFNDEF FR_COM} + frxDisplayHHTopic(Application.Handle, ExtractFilePath(Application.ExeName) + FHelpFile + topic); +{$ELSE} + frxDisplayHHTopic(Application.Handle, FHelpFile + topic); +{$ENDIF} +end; + +procedure TfrxResources.BuildLanguagesList; +var + i: Integer; + SRec: TSearchRec; + Dir: String; + s: String; +begin + Dir := GetAppPath; + FLanguages.Clear; + i := FindFirst(Dir + '*.frc', faAnyFile, SRec); + try + while i = 0 do + begin + s := LowerCase(SRec.Name); + s := UpperCase(Copy(s, 1, 1)) + Copy(s, 2, Length(s) - 1); + s := StringReplace(s, '.frc', '', []); + FLanguages.Add(s); + i := FindNext(SRec); + end; + FLanguages.Sort; + finally + FindClose(Srec); + end; +end; + + +function frxResources: TfrxResources; +begin + if FResources = nil then + FResources := TfrxResources.Create; + Result := FResources; +end; + +function frxGet(ID: Integer): String; +begin + Result := frxResources.Get(IntToStr(ID)); +end; + +{$IFDEF FR_COM} +function TfrxResources.Get_HelpFile(out Value: WideString): HResult; stdcall; +begin + Value := HelpFile; + Result := S_OK; +end; + +function TfrxResources.Set_HelpFile(const Value: WideString): HResult; stdcall; +begin + HelpFile := Value; + Result := S_OK; +end; + +function TfrxResources.Help: HResult; stdcall; +begin + Help(nil); + Result := S_OK; +end; + +function TfrxResources.GetResourceString(const ID: WideString; out Value: WideString): HResult; stdcall; +begin + Value := Get(ID); + Result := S_OK; +end; + +function TfrxResources.LoadLanguageResourcesFromFile(const FileName: WideString): HResult; stdcall; +begin + try + LoadFromFile(FileName); + Result := S_OK; + except + Result := E_FAIL; + end; +end; +{$ENDIF} + +initialization + +finalization + if FResources <> nil then + FResources.Free; + FResources := nil; + +end. + + +// diff --git a/official/4.8.11/Source/frxRich.pas b/official/4.8.11/Source/frxRich.pas new file mode 100644 index 0000000..4613d9c --- /dev/null +++ b/official/4.8.11/Source/frxRich.pas @@ -0,0 +1,690 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ RichEdit Add-In Object } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRich; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Forms, Menus, frxClass, + RichEdit, frxRichEdit, frxPrinter +{$IFDEF Delphi6} +, Variants +{$ENDIF} +{$IFDEF FR_COM} +, ActiveX, AxCtrls +, ClrStream +, FastReport_TLB +{$ENDIF}; + + +type + TfrxRichObject = class(TComponent) // fake component + end; + +{$IFDEF FR_COM} + TfrxRichView = class(TfrxStretcheable, IfrxRichView) +{$ELSE} + TfrxRichView = class(TfrxStretcheable) +{$ENDIF} + private + FAllowExpressions: Boolean; + FExpressionDelimiters: String; + FFlowTo: TfrxRichView; + FGapX: Extended; + FGapY: Extended; + FParaBreak: Boolean; + FRichEdit: TrxRichEdit; + FTempStream: TMemoryStream; + FTempStream1: TMemoryStream; + FWysiwyg: Boolean; + function CreateMetafile: TMetafile; + function IsExprDelimitersStored: Boolean; + function UsePrinterCanvas: Boolean; + procedure ReadData(Stream: TStream); + procedure WriteData(Stream: TStream); +{$IFDEF FR_COM} + function LoadViewFromStream(const Stream: IUnknown): HResult; stdcall; + function SaveViewToStream(const Stream: IUnknown): HResult; stdcall; + function Get_RichAlign(out Value: frxHAlign): HResult; stdcall; + function Set_RichAlign(Value: frxHAlign): HResult; stdcall; + function Get_WYSIWIG(out Value: WordBool): HResult; stdcall; + function Set_WYSIWIG(Value: WordBool): HResult; stdcall; + function Get_AllowExpressions(out Value: WordBool): HResult; stdcall; + function Set_AllowExpressions(Value: WordBool): HResult; stdcall; +{$ENDIF} + protected + procedure DefineProperties(Filer: TFiler); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override; + procedure AfterPrint; override; + procedure BeforePrint; override; + procedure GetData; override; + procedure InitPart; override; + function CalcHeight: Extended; override; + function DrawPart: Extended; override; + class function GetDescription: String; override; + function GetComponentText: String; override; + property RichEdit: TrxRichEdit read FRichEdit; + published + property AllowExpressions: Boolean read FAllowExpressions + write FAllowExpressions default True; + property BrushStyle; + property Color; + property Cursor; + property DataField; + property DataSet; + property DataSetName; + property ExpressionDelimiters: String read FExpressionDelimiters + write FExpressionDelimiters stored IsExprDelimitersStored; + property FlowTo: TfrxRichView read FFlowTo write FFlowTo; + property Frame; + property GapX: Extended read FGapX write FGapX; + property GapY: Extended read FGapY write FGapY; + property TagStr; + property URL; + property Wysiwyg: Boolean read FWysiwyg write FWysiwyg default True; + end; + + +procedure frxAssignRich(RichFrom, RichTo: TrxRichEdit); + + +implementation + +uses + frxRichRTTI, +{$IFNDEF NO_EDITORS} + frxRichEditor, +{$ENDIF} + frxUtils, frxDsgnIntf, frxRes; + + +procedure frxAssignRich(RichFrom, RichTo: TrxRichEdit); +var + st: TMemoryStream; +begin + st := TMemoryStream.Create; + try + RichFrom.Lines.SaveToStream(st); + st.Position := 0; + RichTo.Lines.LoadFromStream(st); + finally + st.Free; + end; +end; + + +{ TfrxRichView } + +constructor TfrxRichView.Create(AOwner: TComponent); +begin + inherited; + FRichEdit := TrxRichEdit.Create(nil); + FRichEdit.Parent := frxParentForm; + SendMessage(frxParentForm.Handle, WM_CREATEHANDLE, Integer(FRichEdit), 0); + FRichEdit.AutoURLDetect := False; + { make rich transparent } + SetWindowLong(FRichEdit.Handle, GWL_EXSTYLE, + GetWindowLong(FRichEdit.Handle, GWL_EXSTYLE) or WS_EX_TRANSPARENT); + + FTempStream := TMemoryStream.Create; + FTempStream1 := TMemoryStream.Create; + + FAllowExpressions := True; + FExpressionDelimiters := '[,]'; + FGapX := 2; + FGapY := 1; + FWysiwyg := True; +end; + +destructor TfrxRichView.Destroy; +begin + SendMessage(frxParentForm.Handle, WM_DESTROYHANDLE, Integer(FRichEdit), 0); + FRichEdit.Free; + FTempStream.Free; + FTempStream1.Free; + inherited; +end; + +class function TfrxRichView.GetDescription: String; +begin + Result := frxResources.Get('obRich'); +end; + +function TfrxRichView.IsExprDelimitersStored: Boolean; +begin + Result := FExpressionDelimiters <> '[,]'; +end; + +procedure TfrxRichView.DefineProperties(Filer: TFiler); +begin + inherited; + Filer.DefineBinaryProperty('RichEdit', ReadData, WriteData, True); +end; + +procedure TfrxRichView.ReadData(Stream: TStream); +begin + FRichEdit.Lines.LoadFromStream(Stream); +end; + +procedure TfrxRichView.WriteData(Stream: TStream); +begin + FRichEdit.Lines.SaveToStream(Stream); +end; + +procedure TfrxRichView.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (AComponent = FFlowTo) then + FFlowTo := nil; +end; + +function TfrxRichView.UsePrinterCanvas: Boolean; +begin + Result := frxPrinters.HasPhysicalPrinters and FWysiwyg; +end; + +function TfrxRichView.CreateMetafile: TMetafile; +var + Range: TFormatRange; + EMFCanvas: TMetafileCanvas; + PrinterHandle: THandle; +begin + if UsePrinterCanvas then + PrinterHandle := frxPrinters.Printer.Canvas.Handle + else + PrinterHandle := GetDC(0); + FillChar(Range, SizeOf(TFormatRange), 0); + + with Range do + begin + rc := Rect(Round(GapX * 1440 / 96), Round(GapY * 1440 / 96), + Round((Width - GapX) * 1440 / 96), + Round((Height - GapY) * 1440 / 96)); + rcPage := rc; + + Result := TMetafile.Create; + Result.Width := Round(Width * GetDeviceCaps(PrinterHandle, LOGPIXELSX) / 96); + Result.Height := Round(Height * GetDeviceCaps(PrinterHandle, LOGPIXELSY) / 96); + + EMFCanvas := TMetafileCanvas.Create(Result, PrinterHandle); + hdc := EMFCanvas.Handle; + hdcTarget := hdc; + + chrg.cpMin := 0; + chrg.cpMax := -1; + FRichEdit.Perform(EM_FORMATRANGE, 1, Integer(@Range)); + end; + + if not UsePrinterCanvas then + ReleaseDC(0, PrinterHandle); + + FRichEdit.Perform(EM_FORMATRANGE, 0, 0); + EMFCanvas.Free; +end; + +procedure TfrxRichView.Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, + OffsetY: Extended); +var + EMF: TMetafile; +begin + BeginDraw(Canvas, ScaleX, ScaleY, OffsetX, OffsetY); + DrawBackground; + + EMF := CreateMetafile; + try + Canvas.StretchDraw(Rect(FX, FY, FX1, FY1), EMF); + finally + EMF.Free; + end; + + DrawFrame; +end; + +procedure TfrxRichView.BeforePrint; +begin + inherited; + FTempStream.Position := 0; + FRichEdit.Lines.SaveToStream(FTempStream); +end; + +procedure TfrxRichView.AfterPrint; +begin + FTempStream.Position := 0; + FRichEdit.Lines.LoadFromStream(FTempStream); + inherited; +end; + +procedure TfrxRichView.GetData; +const + RTFHeader = '{\rtf'; + URTFHeader = '{urtf'; +type + tag_settextex = record + flags: DWORD; + codepage: UINT; + end; +var + ss: TStringStream; + i, j, TextLen: Integer; + s1, s2, dc1, dc2: String; + SetText: tag_settextex; +{$IFDEF Delphi12} + AnsiStr: AnsiString; +{$ENDIF} + + function GetSpecial(const s: String; Pos: Integer): Integer; + var + i: Integer; + begin + Result := 0; + for i := 1 to Pos do +{$IFDEF Delphi12} + if CharInSet(s[i], [#10, #13]) then +{$ELSE} + if s[i] in [#10, #13] then +{$ENDIF} + Inc(Result); + end; + + function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer; + var + I,X: Integer; + Len, LenSubStr: Integer; + begin + if Offset = 1 then + Result := Pos(SubStr, S) + else + begin + I := Offset; + LenSubStr := Length(SubStr); + Len := Length(S) - LenSubStr + 1; + while I <= Len do + begin + if S[I] = SubStr[1] then + begin + X := 1; + while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do + Inc(X); + if (X = LenSubStr) then + begin + Result := I; + exit; + end; + end; + Inc(I); + end; + Result := 0; + end; + end; + +begin + inherited; + if IsDataField then + begin + if DataSet.IsBlobField(DataField) then + begin + ss := TStringStream.Create(''); + DataSet.AssignBlobTo(DataField, ss) + end + else + ss := TStringStream.Create(VarToStr(DataSet.Value[DataField])); + try + FRichEdit.Lines.LoadFromStream(ss); + finally + ss.Free; + end; + end; + + if FAllowExpressions then + begin + dc1 := FExpressionDelimiters; + dc2 := Copy(dc1, Pos(',', dc1) + 1, 255); + dc1 := Copy(dc1, 1, Pos(',', dc1) - 1); + + with FRichEdit do + try + Lines.BeginUpdate; + i := Pos(dc1, Text); + while i > 0 do + begin + SelStart := i - 1 - GetSpecial(Text, i) div 2; +{$IFDEF Delphi12} + s1 := frxGetBrackedVariableW(Text, dc1, dc2, i, j); +{$ELSE} + s1 := frxGetBrackedVariable(Text, dc1, dc2, i, j); +{$ENDIF} + s2 := VarToStr(Report.Calc(s1)); + + SelLength := j - i + 1; + TextLen := Length(Text) - SelLength; + if (Copy(s2, 1, 5) = RTFHeader) or (Copy(s2, 1, 6) = URTFHeader) then + begin +{$IFDEF Delphi12} + AnsiStr := AnsiString(s2); +{$ENDIF} + if RichEditVersion = 4 then + begin + SetText.flags := 2;//ST_SELECTION +{$IFDEF Delphi12} + SetText.codepage := 1200; +{$ELSE} + SetText.codepage := CP_ACP; +{$ENDIF} + SendMessage(FRichEdit.Handle, WM_USER + 97 {EM_SETTEXTEX}, Integer(@SetText), + Integer({$IFDEF Delphi12}PAnsiChar(AnsiStr){$ELSE}PChar(s2){$ENDIF})) + end + else + SendMessage(FRichEdit.Handle, EM_REPLACESEL, Integer(True), + Integer({$IFDEF Delphi12}PAnsiChar(AnsiStr){$ELSE}PChar(s2){$ENDIF}));// rich text workground + + end else + SelText := s2; + i := PosEx(dc1, Text, i + Length(Text) - TextLen); + end; + finally + Lines.EndUpdate; + end; + end; + + if FFlowTo <> nil then + begin + InitPart; + DrawPart; + FTempStream1.Position := 0; + FlowTo.RichEdit.Lines.LoadFromStream(FTempStream1); + FFlowTo.AllowExpressions := False; + end; +end; + +function TfrxRichView.CalcHeight: Extended; +var + Range: TFormatRange; +begin + FillChar(Range, SizeOf(TFormatRange), 0); + with Range do + begin + rc := Rect(0, 0, Round((Width - GapX * 2) * 1440 / 96), Round(1000000 * 1440.0 / 96)); + rcPage := rc; + if UsePrinterCanvas then + hdc := frxPrinters.Printer.Canvas.Handle + else + hdc := GetDC(0); + hdcTarget := hdc; + + chrg.cpMin := 0; + chrg.cpMax := -1; + FRichEdit.Perform(EM_FORMATRANGE, 0, Integer(@Range)); + + if not UsePrinterCanvas then + ReleaseDC(0, hdc); + if RichEdit.GetTextLen = 0 then + Result := 0 + else + Result := Round(rc.Bottom / (1440.0 / 96)) + 2 * GapY + 2; + end; + + FRichEdit.Perform(EM_FORMATRANGE, 0, 0); +end; + +function TfrxRichView.DrawPart: Extended; +var + Range: TFormatRange; + LastChar: Integer; +begin + { get remained part of text } + FTempStream1.Position := 0; + FRichEdit.Lines.LoadFromStream(FTempStream1); + if FParaBreak then + begin +// FRichEdit.SelStart := 1; +// FRichEdit.SelLength := 1; + FRichEdit.Paragraph.FirstIndent := 0; + FRichEdit.Paragraph.LeftIndent := 0; + end; + + { calculate the last visible char } + FillChar(Range, SizeOf(TFormatRange), 0); + with Range do + begin + rc := Rect(0, 0, Round((Width - GapX * 2) * 1440 / 96), + Round((Height - GapY * 2) * 1440 / 96)); + rcPage := rc; + if UsePrinterCanvas then + hdc := frxPrinters.Printer.Canvas.Handle + else + hdc := GetDC(0); + hdcTarget := hdc; + + chrg.cpMin := 0; + chrg.cpMax := -1; + LastChar := FRichEdit.Perform(EM_FORMATRANGE, 0, Integer(@Range)); + Result := Round((rcPage.Bottom - rc.Bottom) / (1440.0 / 96)) + 2 * GapY + 0.1; + + if not UsePrinterCanvas then + ReleaseDC(0, hdc); + end; + FRichEdit.Perform(EM_FORMATRANGE, 0, 0); + + { text can't fit } + if Result < 0 then + begin + Result := Height; + Exit; + end; + + { copy the outbounds text to the temp stream } + try + if LastChar > 1 then + begin + FRichEdit.SelStart := LastChar - 1; + FRichEdit.SelLength := 1; + FParaBreak := FRichEdit.SelText <> #13; + end; + + FRichEdit.SelStart := LastChar; + FRichEdit.SelLength := FRichEdit.GetTextLen - LastChar + 1; + if FRichEdit.SelLength = 1 then + Result := 0; + FTempStream1.Clear; + FRichEdit.StreamMode := [smSelection]; + FRichEdit.Lines.SaveToStream(FTempStream1); + FRichEdit.SelText := ''; + finally + FRichEdit.StreamMode := []; + end; +end; + +procedure TfrxRichView.InitPart; +begin + FTempStream1.Clear; + FRichEdit.Lines.SaveToStream(FTempStream1); + FParaBreak := False; +end; + +function TfrxRichView.GetComponentText: String; +var + FTStream: TMemoryStream; +{$IFDEF Delphi12} + TempStr: AnsiString; +{$ENDIF} +begin + if PlainText then + begin + FTStream := TMemoryStream.Create; + try + FTempStream.Clear; + FRichEdit.Lines.SaveToStream(FTStream); + FRichEdit.PlainText := True; + FRichEdit.Lines.SaveToStream(FTempStream); +{$IFDEF Delphi12} + SetLength(TempStr, FTempStream.Size); + FTempStream.Position := 0; + FTempStream.Read(TempStr[1], FTempStream.Size); + Result := String(TempStr); +{$ELSE} + SetLength(Result, FTempStream.Size); + FTempStream.Position := 0; + FTempStream.Read(Result[1], FTempStream.Size); +{$ENDIF} + FRichEdit.PlainText := False; + FTStream.Position := 0; + FRichEdit.Lines.LoadFromStream(FTStream); + finally + FTStream.Free; + end; + end + else + begin + FTempStream.Clear; + FRichEdit.Lines.SaveToStream(FTempStream); +{$IFDEF Delphi12} + SetLength(TempStr, FTempStream.Size); + FTempStream.Position := 0; + FTempStream.Read(TempStr[1], FTempStream.Size); + Result := String(TempStr); +{$ELSE} + SetLength(Result, FTempStream.Size); + FTempStream.Position := 0; + FTempStream.Read(Result[1], FTempStream.Size); +{$ENDIF} + end; +end; + +{$IFDEF FR_COM} +function TfrxRichView.LoadViewFromStream(const Stream: IUnknown): HResult; stdcall; +var + ComStream: IStream; + OleStream: TOleStream; + + NetStream: _Stream; + ClrStream: TClrStream; +begin + try + Result := Stream.QueryInterface(IStream, ComStream); + if Result = S_OK then + begin + OleStream := TOleStream.Create(ComStream); + ReadData(OleStream); + OleStream.Free; + ComStream := nil; + end + else + begin + Result := Stream.QueryInterface(_Stream, NetStream); + if Result = S_OK then + begin + ClrStream := TClrStream.Create(NetStream); + ReadData(ClrStream); + ClrStream.Free; + NetStream._Release(); + end; + end; + except + Result := E_FAIL; + end; +end; + +function TfrxRichView.SaveViewToStream(const Stream: IUnknown): HResult; stdcall; +var + ComStream: IStream; + OleStream: TOleStream; + + NetStream: _Stream; + ClrStream: TClrStream; +begin + try + Result := Stream.QueryInterface(IStream, ComStream); + if Result = S_OK then + begin + OleStream := TOleStream.Create(ComStream); + WriteData(OleStream); + OleStream.Free; + ComStream := nil; + end + else + begin + Result := Stream.QueryInterface(_Stream, NetStream); + if Result = S_OK then + begin + ClrStream := TClrStream.Create(NetStream); + WriteData(ClrStream); + ClrStream.Free; + NetStream._Release(); + end; + end; + except + Result := E_FAIL; + end; +end; + +function TfrxRichView.Get_RichAlign(out Value: frxHAlign): HResult; stdcall; +begin + Result := S_OK; + Value := frxHAlign(FRichEdit.Paragraph.Alignment); +end; + +function TfrxRichView.Set_RichAlign(Value: frxHAlign): HResult; stdcall; +begin + Result := S_OK; + FRichEdit.SelectAll; + case Value of + hAlignLeft: FRichEdit.Paragraph.Alignment := paLeftJustify; + hAlignRight: FRichEdit.Paragraph.Alignment := paRightJustify; + hAlignCenter: FRichEdit.Paragraph.Alignment := paCenter; + hAlignBlock: FRichEdit.Paragraph.Alignment := paJustify; + else Result := E_FAIL; + end; +end; + +function TfrxRichView.Get_WYSIWIG(out Value: WordBool): HResult; stdcall; +begin + Value := FWysiwyg; + Result := S_OK; +end; + +function TfrxRichView.Set_WYSIWIG(Value: WordBool): HResult; stdcall; +begin + FWysiwyg := Value; + Result := S_OK; +end; + +function TfrxRichView.Get_AllowExpressions(out Value: WordBool): HResult; stdcall; +begin + Value := FAllowExpressions; + Result := S_OK; +end; + +function TfrxRichView.Set_AllowExpressions(Value: WordBool): HResult; stdcall; +begin + FAllowExpressions := Value; + Result := S_OK; +end; +{$ENDIF} + +initialization + frxObjects.RegisterObject1(TfrxRichView, nil, '', '', 0, 26); + +finalization + frxObjects.UnRegister(TfrxRichView); + + +end. + + +// diff --git a/official/4.8.11/Source/frxRichEdit.pas b/official/4.8.11/Source/frxRichEdit.pas new file mode 100644 index 0000000..11512f4 --- /dev/null +++ b/official/4.8.11/Source/frxRichEdit.pas @@ -0,0 +1,4523 @@ +{*******************************************************} +{ } +{ Delphi VCL Extensions (RX) } +{ } +{ Copyright (c) 1998 Master-Bank } +{ } +{ Changes made by Alexander Tzyganenko: } +{ - removed ifdefs to match Delphi4 and above } +{ - removed maxmin unit from uses list } +{ } +{*******************************************************} + +unit frxRichEdit; + +{$I frx.inc} + +interface + +uses + Windows, ActiveX, ComObj, CommCtrl, Messages, SysUtils, Classes, Controls, + Forms, Graphics, StdCtrls, Dialogs, RichEdit, Menus, ComCtrls; + +type + TRichEditVersion = 1..4; + +{$IFDEF RICHBCB} + TCharFormat2A = record + cbSize: UINT; + dwMask: DWORD; + dwEffects: DWORD; + yHeight: Longint; + yOffset: Longint; + crTextColor: TColorRef; + bCharSet: Byte; + bPitchAndFamily: Byte; + szFaceName: array[0..LF_FACESIZE - 1] of Char; + { new fields in version 2.0 } + wWeight: Word; { Font weight (LOGFONT value) } + sSpacing: Smallint; { Amount to space between letters } + crBackColor: TColorRef; { Background color } + lid: LCID; { Locale ID } + dwReserved: DWORD; { Reserved. Must be 0 } + sStyle: Smallint; { Style handle } + wKerning: Word; { Twip size above which to kern char pair } + bUnderlineType: Byte; { Underline type } + bAnimation: Byte; { Animated text like marching ants } + bRevAuthor: Byte; { Revision author index } + bReserved1: Byte; + end; + TCharFormat2 = TCharFormat2A; + + TParaFormat2 = record + cbSize: UINT; + dwMask: DWORD; + wNumbering: Word; + wReserved: Word; + dxStartIndent: Longint; + dxRightIndent: Longint; + dxOffset: Longint; + wAlignment: Word; + cTabCount: Smallint; + rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint; + { new fields in version 2.0 } + dySpaceBefore: Longint; { Vertical spacing before paragraph } + dySpaceAfter: Longint; { Vertical spacing after paragraph } + dyLineSpacing: Longint; { Line spacing depending on Rule } + sStyle: Smallint; { Style handle } + bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) } + bCRC: Byte; { Reserved for CRC for rapid searching } + wShadingWeight: Word; { Shading in hundredths of a per cent } + wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat } + wNumberingStart: Word; { Starting value for numbering } + wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc.} + wNumberingTab: Word; { Space bet 1st indent and 1st-line text } + wBorderSpace: Word; { Space between border and text (twips) } + wBorderWidth: Word; { Border pen width (twips) } + wBorders: Word; { Byte 0: bits specify which borders } + { Nibble 2: border style, 3: color index } + end; +{$ENDIF} + +type + TRxCustomRichEdit = class; + +{ TRxTextAttributes } + + TRxAttributeType = (atDefaultText, atSelected, atWord); + TRxConsistentAttribute = (caBold, caColor, caFace, caItalic, caSize, + caStrikeOut, caUnderline, caProtected, caOffset, caHidden, caLink, + caBackColor, caDisabled, caWeight, caSubscript, caRevAuthor); + TRxConsistentAttributes = set of TRxConsistentAttribute; + TSubscriptStyle = (ssNone, ssSubscript, ssSuperscript); + TUnderlineType = (utNone, utSolid, utWord, utDouble, utDotted, utWave); + + TRxTextAttributes = class(TPersistent) + private + RichEdit: TRxCustomRichEdit; + FType: TRxAttributeType; + procedure AssignFont(Font: TFont); + procedure GetAttributes(var Format: TCharFormat2); + function GetCharset: TFontCharset; + procedure SetCharset(Value: TFontCharset); + function GetSubscriptStyle: TSubscriptStyle; + procedure SetSubscriptStyle(Value: TSubscriptStyle); + function GetBackColor: TColor; + function GetColor: TColor; + function GetConsistentAttributes: TRxConsistentAttributes; + function GetHeight: Integer; + function GetHidden: Boolean; + function GetDisabled: Boolean; + function GetLink: Boolean; + function GetName: TFontName; + function GetOffset: Integer; + function GetPitch: TFontPitch; + function GetProtected: Boolean; + function GetRevAuthorIndex: Byte; + function GetSize: Integer; + function GetStyle: TFontStyles; + function GetUnderlineType: TUnderlineType; + procedure SetAttributes(var Format: TCharFormat2); + procedure SetBackColor(Value: TColor); + procedure SetColor(Value: TColor); + procedure SetDisabled(Value: Boolean); + procedure SetHeight(Value: Integer); + procedure SetHidden(Value: Boolean); + procedure SetLink(Value: Boolean); + procedure SetName(Value: TFontName); + procedure SetOffset(Value: Integer); + procedure SetPitch(Value: TFontPitch); + procedure SetProtected(Value: Boolean); + procedure SetRevAuthorIndex(Value: Byte); + procedure SetSize(Value: Integer); + procedure SetStyle(Value: TFontStyles); + procedure SetUnderlineType(Value: TUnderlineType); + protected + procedure InitFormat(var Format: TCharFormat2); + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create(AOwner: TRxCustomRichEdit; AttributeType: TRxAttributeType); + procedure Assign(Source: TPersistent); override; + property Charset: TFontCharset read GetCharset write SetCharset; + property BackColor: TColor read GetBackColor write SetBackColor; + property Color: TColor read GetColor write SetColor; + property ConsistentAttributes: TRxConsistentAttributes read GetConsistentAttributes; + property Disabled: Boolean read GetDisabled write SetDisabled; + property Hidden: Boolean read GetHidden write SetHidden; + property Link: Boolean read GetLink write SetLink; + property Name: TFontName read GetName write SetName; + property Offset: Integer read GetOffset write SetOffset; + property Pitch: TFontPitch read GetPitch write SetPitch; + property Protected: Boolean read GetProtected write SetProtected; + property RevAuthorIndex: Byte read GetRevAuthorIndex write SetRevAuthorIndex; + property SubscriptStyle: TSubscriptStyle read GetSubscriptStyle write SetSubscriptStyle; + property Size: Integer read GetSize write SetSize; + property Style: TFontStyles read GetStyle write SetStyle; + property Height: Integer read GetHeight write SetHeight; + property UnderlineType: TUnderlineType read GetUnderlineType write SetUnderlineType; + end; + +{ TRxParaAttributes } + + TRxNumbering = (nsNone, nsBullet, nsArabicNumbers, nsLoCaseLetter, + nsUpCaseLetter, nsLoCaseRoman, nsUpCaseRoman); + TRxNumberingStyle = (nsParenthesis, nsPeriod, nsEnclosed, nsSimple); + TParaAlignment = (paLeftJustify, paRightJustify, paCenter, paJustify); + TLineSpacingRule = (lsSingle, lsOneAndHalf, lsDouble, lsSpecifiedOrMore, + lsSpecified, lsMultiple); + THeadingStyle = 0..9; + TParaTableStyle = (tsNone, tsTableRow, tsTableCellEnd, tsTableCell); + + TRxParaAttributes = class(TPersistent) + private + RichEdit: TRxCustomRichEdit; + procedure GetAttributes(var Paragraph: TParaFormat2); + function GetAlignment: TParaAlignment; + function GetFirstIndent: Longint; + function GetHeadingStyle: THeadingStyle; + function GetLeftIndent: Longint; + function GetRightIndent: Longint; + function GetSpaceAfter: Longint; + function GetSpaceBefore: Longint; + function GetLineSpacing: Longint; + function GetLineSpacingRule: TLineSpacingRule; + function GetNumbering: TRxNumbering; + function GetNumberingStyle: TRxNumberingStyle; + function GetNumberingTab: Word; + function GetTab(Index: Byte): Longint; + function GetTabCount: Integer; + function GetTableStyle: TParaTableStyle; + procedure SetAlignment(Value: TParaAlignment); + procedure SetAttributes(var Paragraph: TParaFormat2); + procedure SetFirstIndent(Value: Longint); + procedure SetHeadingStyle(Value: THeadingStyle); + procedure SetLeftIndent(Value: Longint); + procedure SetRightIndent(Value: Longint); + procedure SetSpaceAfter(Value: Longint); + procedure SetSpaceBefore(Value: Longint); + procedure SetLineSpacing(Value: Longint); + procedure SetLineSpacingRule(Value: TLineSpacingRule); + procedure SetNumbering(Value: TRxNumbering); + procedure SetNumberingStyle(Value: TRxNumberingStyle); + procedure SetNumberingTab(Value: Word); + procedure SetTab(Index: Byte; Value: Longint); + procedure SetTabCount(Value: Integer); + procedure SetTableStyle(Value: TParaTableStyle); + protected + procedure InitPara(var Paragraph: TParaFormat2); + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create(AOwner: TRxCustomRichEdit); + procedure Assign(Source: TPersistent); override; + property Alignment: TParaAlignment read GetAlignment write SetAlignment; + property FirstIndent: Longint read GetFirstIndent write SetFirstIndent; + property HeadingStyle: THeadingStyle read GetHeadingStyle write SetHeadingStyle; + property LeftIndent: Longint read GetLeftIndent write SetLeftIndent; + property LineSpacing: Longint read GetLineSpacing write SetLineSpacing; + property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule write SetLineSpacingRule; + property Numbering: TRxNumbering read GetNumbering write SetNumbering; + property NumberingStyle: TRxNumberingStyle read GetNumberingStyle write SetNumberingStyle; + property NumberingTab: Word read GetNumberingTab write SetNumberingTab; + property RightIndent: Longint read GetRightIndent write SetRightIndent; + property SpaceAfter: Longint read GetSpaceAfter write SetSpaceAfter; + property SpaceBefore: Longint read GetSpaceBefore write SetSpaceBefore; + property Tab[Index: Byte]: Longint read GetTab write SetTab; + property TabCount: Integer read GetTabCount write SetTabCount; + property TableStyle: TParaTableStyle read GetTableStyle write SetTableStyle; + end; + +{ TOEMConversion } + TOEMConversion = class(TConversion) + public +{$IFDEF Delphi12} + function ConvertReadStream(Stream: TStream; Buffer: TBytes; BufSize: Integer): Integer; override; + function ConvertWriteStream(Stream: TStream; Buffer: TBytes; BufSize: Integer): Integer; override; +{$ELSE} + function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; override; + function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; override; +{$ENDIF} + end; + +{ TRxCustomRichEdit } + + TUndoName = (unUnknown, unTyping, unDelete, unDragDrop, unCut, unPaste); + TRichSearchType = (stWholeWord, stMatchCase, stBackward, stSetSelection); + TRichSearchTypes = set of TRichSearchType; + TRichSelection = (stText, stObject, stMultiChar, stMultiObject); + TRichSelectionType = set of TRichSelection; + TRichLangOption = (rlAutoKeyboard, rlAutoFont, rlImeCancelComplete, + rlImeAlwaysSendNotify); + TRichLangOptions = set of TRichLangOption; + TRichStreamFormat = (sfDefault, sfRichText, sfPlainText); + TRichStreamMode = (smSelection, smPlainRtf, smNoObjects, smUnicode); + TRichStreamModes = set of TRichStreamMode; + TRichEditURLClickEvent = procedure(Sender: TObject; const URLText: string; + Button: TMouseButton) of object; + TRichEditProtectChangeEx = procedure(Sender: TObject; const Message: TMessage; + StartPos, EndPos: Integer; var AllowChange: Boolean) of object; + TRichEditFindErrorEvent = procedure(Sender: TObject; const FindText: string) of object; + TRichEditFindCloseEvent = procedure(Sender: TObject; Dialog: TFindDialog) of object; + + PRichConversionFormat = ^TRichConversionFormat; + TRichConversionFormat = record + ConversionClass: TConversionClass; + Extension: string; + PlainText: Boolean; + Next: PRichConversionFormat; + end; + + TRxCustomRichEdit = class(TCustomMemo) + private + FHideScrollBars: Boolean; + FSelectionBar: Boolean; + FAutoURLDetect: Boolean; + FWordSelection: Boolean; + FPlainText: Boolean; + FSelAttributes: TRxTextAttributes; + FDefAttributes: TRxTextAttributes; + FWordAttributes: TRxTextAttributes; + FParagraph: TRxParaAttributes; + FOldParaAlignment: TParaAlignment; + FScreenLogPixels: Integer; + FUndoLimit: Integer; + FRichEditStrings: TStrings; + FMemStream: TMemoryStream; + FHideSelection: Boolean; + FLangOptions: TRichLangOptions; + FModified: Boolean; + FLinesUpdating: Boolean; + FPageRect: TRect; + FClickRange: TCharRange; + FClickBtn: TMouseButton; + FFindDialog: TFindDialog; + FReplaceDialog: TReplaceDialog; + FLastFind: TFindDialog; + FAllowObjects: Boolean; + FCallback: TObject; + FRichEditOle: IUnknown; + FPopupVerbMenu: TPopupMenu; + FTitle: string; + FAutoVerbMenu: Boolean; + FAllowInPlace: Boolean; + FDefaultConverter: TConversionClass; + FOnSelChange: TNotifyEvent; + FOnResizeRequest: TRichEditResizeEvent; + FOnProtectChange: TRichEditProtectChange; + FOnProtectChangeEx: TRichEditProtectChangeEx; + FOnSaveClipboard: TRichEditSaveClipboard; + FOnURLClick: TRichEditURLClickEvent; + FOnTextNotFound: TRichEditFindErrorEvent; + FOnCloseFindDialog: TRichEditFindCloseEvent; + function GetAutoURLDetect: Boolean; + function GetWordSelection: Boolean; + function GetLangOptions: TRichLangOptions; + function GetCanRedo: Boolean; + function GetCanPaste: Boolean; + function GetRedoName: TUndoName; + function GetUndoName: TUndoName; + function GetStreamFormat: TRichStreamFormat; + function GetStreamMode: TRichStreamModes; + function GetSelectionType: TRichSelectionType; + procedure PopupVerbClick(Sender: TObject); + procedure ObjectPropsClick(Sender: TObject); + procedure CloseObjects; + procedure UpdateHostNames; + procedure SetAllowObjects(Value: Boolean); + procedure SetStreamFormat(Value: TRichStreamFormat); + procedure SetStreamMode(Value: TRichStreamModes); + procedure SetAutoURLDetect(Value: Boolean); + procedure SetWordSelection(Value: Boolean); + procedure SetHideScrollBars(Value: Boolean); + procedure SetHideSelection(Value: Boolean); + procedure SetTitle(const Value: string); + procedure SetLangOptions(Value: TRichLangOptions); + procedure SetRichEditStrings(Value: TStrings); + procedure SetDefAttributes(Value: TRxTextAttributes); + procedure SetSelAttributes(Value: TRxTextAttributes); + procedure SetWordAttributes(Value: TRxTextAttributes); + procedure SetSelectionBar(Value: Boolean); + procedure SetUndoLimit(Value: Integer); + procedure UpdateTextModes(Plain: Boolean); + procedure AdjustFindDialogPosition(Dialog: TFindDialog); + procedure SetupFindDialog(Dialog: TFindDialog; const SearchStr, + ReplaceStr: string); + function FindEditText(Dialog: TFindDialog; AdjustPos, Events: Boolean): Boolean; + function GetCanFindNext: Boolean; + procedure FindDialogFind(Sender: TObject); + procedure ReplaceDialogReplace(Sender: TObject); + procedure FindDialogClose(Sender: TObject); + procedure SetUIActive(Active: Boolean); + procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE; + procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE; + procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; + procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; + procedure EMReplaceSel(var Message: TMessage); message EM_REPLACESEL; + procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY; + procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; + procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT; +{$IFDEF Delphi5} + procedure WMRButtonUp(var Message: TMessage); message WM_RBUTTONUP; +{$ENDIF} + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + function GetPopupMenu: TPopupMenu; override; + procedure TextNotFound(Dialog: TFindDialog); virtual; + procedure RequestSize(const Rect: TRect); virtual; + procedure SelectionChange; dynamic; + function ProtectChange(const Message: TMessage; StartPos, + EndPos: Integer): Boolean; dynamic; + function SaveClipboard(NumObj, NumChars: Integer): Boolean; dynamic; + procedure URLClick(const URLText: string; Button: TMouseButton); dynamic; + procedure SetPlainText(Value: Boolean); virtual; + procedure CloseFindDialog(Dialog: TFindDialog); virtual; + procedure DoSetMaxLength(Value: Integer); override; + function GetSelLength: Integer; override; + function GetSelStart: Integer; override; + function GetSelText: string; override; + procedure SetSelLength(Value: Integer); override; + procedure SetSelStart(Value: Integer); override; + property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True; + property AllowObjects: Boolean read FAllowObjects write SetAllowObjects default True; + property AutoURLDetect: Boolean read GetAutoURLDetect write SetAutoURLDetect default True; + property AutoVerbMenu: Boolean read FAutoVerbMenu write FAutoVerbMenu default True; + property HideSelection: Boolean read FHideSelection write SetHideSelection default True; + property HideScrollBars: Boolean read FHideScrollBars + write SetHideScrollBars default True; + property Title: string read FTitle write SetTitle; + property LangOptions: TRichLangOptions read GetLangOptions write SetLangOptions default [rlAutoFont]; + property Lines: TStrings read FRichEditStrings write SetRichEditStrings; + property PlainText: Boolean read FPlainText write SetPlainText default False; + property SelectionBar: Boolean read FSelectionBar write SetSelectionBar default True; + property StreamFormat: TRichStreamFormat read GetStreamFormat write SetStreamFormat default sfDefault; + property StreamMode: TRichStreamModes read GetStreamMode write SetStreamMode default []; + property UndoLimit: Integer read FUndoLimit write SetUndoLimit default 100; + property WordSelection: Boolean read GetWordSelection write SetWordSelection default True; + property ScrollBars default ssBoth; + property TabStop default True; + property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard + write FOnSaveClipboard; + property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange; + property OnProtectChange: TRichEditProtectChange read FOnProtectChange + write FOnProtectChange; { obsolete } + property OnProtectChangeEx: TRichEditProtectChangeEx read FOnProtectChangeEx + write FOnProtectChangeEx; + property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest + write FOnResizeRequest; + property OnURLClick: TRichEditURLClickEvent read FOnURLClick write FOnURLClick; + property OnTextNotFound: TRichEditFindErrorEvent read FOnTextNotFound write FOnTextNotFound; + property OnCloseFindDialog: TRichEditFindCloseEvent read FOnCloseFindDialog + write FOnCloseFindDialog; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Clear; override; + procedure SetSelection(StartPos, EndPos: Longint; ScrollCaret: Boolean); + function GetSelection: TCharRange; + function GetTextRange(StartPos, EndPos: Longint): string; + function LineFromChar(CharIndex: Integer): Integer; + function GetLineIndex(LineNo: Integer): Integer; + function GetLineLength(CharIndex: Integer): Integer; + function WordAtCursor: string; + function FindText(const SearchStr: string; + StartPos, Length: Integer; Options: TRichSearchTypes): Integer; + function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override; + function GetCaretPos: TPoint; override; + function GetCharPos(CharIndex: Integer): TPoint; + function InsertObjectDialog: Boolean; + function ObjectPropertiesDialog: Boolean; + function PasteSpecialDialog: Boolean; + function FindDialog(const SearchStr: string): TFindDialog; + function ReplaceDialog(const SearchStr, ReplaceStr: string): TReplaceDialog; + function FindNext: Boolean; + procedure Print(const Caption: string); virtual; + class procedure RegisterConversionFormat(const AExtension: string; + APlainText: Boolean; AConversionClass: TConversionClass); + procedure ClearUndo; + procedure Redo; + procedure StopGroupTyping; + property CanFindNext: Boolean read GetCanFindNext; + property CanRedo: Boolean read GetCanRedo; + property CanPaste: Boolean read GetCanPaste; + property RedoName: TUndoName read GetRedoName; + property UndoName: TUndoName read GetUndoName; + property DefaultConverter: TConversionClass read FDefaultConverter + write FDefaultConverter; + property DefAttributes: TRxTextAttributes read FDefAttributes write SetDefAttributes; + property SelAttributes: TRxTextAttributes read FSelAttributes write SetSelAttributes; + property WordAttributes: TRxTextAttributes read FWordAttributes write SetWordAttributes; + property PageRect: TRect read FPageRect write FPageRect; + property Paragraph: TRxParaAttributes read FParagraph; + property SelectionType: TRichSelectionType read GetSelectionType; + end; + + TRxRichEdit = class(TRxCustomRichEdit) + published + property Align; + property Alignment; + property AutoURLDetect; + property AutoVerbMenu; + property AllowObjects; + property AllowInPlace; + property Anchors; + property BiDiMode; + property BorderWidth; + property DragKind; + property BorderStyle; + property Color; + property Ctl3D; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property HideSelection; + property HideScrollBars; + property Title; + property ImeMode; + property ImeName; + property Constraints; + property ParentBiDiMode; + property LangOptions; + property Lines; + property MaxLength; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PlainText; + property PopupMenu; + property ReadOnly; + property ScrollBars; + property SelectionBar; + property ShowHint; + property StreamFormat; + property StreamMode; + property TabOrder; + property TabStop; + property UndoLimit; + property Visible; + property WantTabs; + property WantReturns; + property WordSelection; + property WordWrap; + property OnChange; + property OnDblClick; + property OnDragDrop; + property OnDragOver; +{$IFDEF Delphi5} + property OnContextPopup; +{$ENDIF} + property OnEndDock; + property OnStartDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnProtectChange; { obsolete } + property OnProtectChangeEx; + property OnResizeRequest; + property OnSaveClipboard; + property OnSelectionChange; + property OnStartDrag; + property OnTextNotFound; + property OnCloseFindDialog; + property OnURLClick; + end; + +var + RichEditVersion: TRichEditVersion; + +implementation + +uses Printers, ComStrs, OleConst, OleDlg, OleCtnrs; + +const + RTFConversionFormat: TRichConversionFormat = ( + ConversionClass: TConversion; + Extension: 'rtf'; + PlainText: False; + Next: nil); + TextConversionFormat: TRichConversionFormat = ( + ConversionClass: TConversion; + Extension: 'txt'; + PlainText: True; + Next: @RTFConversionFormat); + MSFTEDIT_CLASS = 'RichEdit50W'; + +var + ConversionFormatList: PRichConversionFormat = @TextConversionFormat; + +const + RichEdit10ModuleName = 'RICHED32.DLL'; + RichEdit20ModuleName = 'RICHED20.DLL'; + RichEdit41ModuleName = 'Msftedit.DLL'; + +// for support RichEdit 3.0 + EM_SETTYPOGRAPHYOPTIONS = WM_USER + 202; + EM_GETTYPOGRAPHYOPTIONS = WM_USER + 203; + TO_ADVANCEDTYPOGRAPHY = 1; + TO_SIMPLELINEBREAK = 2; + FT_DOWN = 1; + +type + PENLink = ^TENLink; + PENOleOpFailed = ^TENOleOpFailed; +{$IFDEF Delphi12} + TFindTextEx = TFindTextExW; +{$ELSE} + TFindTextEx = TFindTextExA; +{$ENDIF} + + TTextRangeA = record + chrg: TCharRange; + lpstrText: PAnsiChar; + end; + TTextRangeW = record + chrg: TCharRange; + lpstrText: PWideChar; + end; +{$IFDEF Delphi12} + TTextRange = TTextRangeW; +{$ELSE} + TTextRange = TTextRangeA; +{$ENDIF} + +function ResStr(const Ident: string): string; +begin + Result := Ident; +end; + +{ TRxTextAttributes } + +const + AttrFlags: array[TRxAttributeType] of Word = (0, SCF_SELECTION, + SCF_WORD or SCF_SELECTION); + +constructor TRxTextAttributes.Create(AOwner: TRxCustomRichEdit; + AttributeType: TRxAttributeType); +begin + inherited Create; + RichEdit := AOwner; + FType := AttributeType; +end; + +procedure TRxTextAttributes.InitFormat(var Format: TCharFormat2); +begin + FillChar(Format, SizeOf(Format), 0); + if RichEditVersion >= 2 then Format.cbSize := SizeOf(Format) + else Format.cbSize := SizeOf(TCharFormat); +end; + +function TRxTextAttributes.GetConsistentAttributes: TRxConsistentAttributes; +var + Format: TCharFormat2; +begin + Result := []; + if RichEdit.HandleAllocated and (FType <> atDefaultText) then begin + InitFormat(Format); + SendMessage(RichEdit.Handle, EM_GETCHARFORMAT, + AttrFlags[FType], LPARAM(@Format)); + with Format do begin + if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold); + if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor); + if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace); + if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic); + if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize); + if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut); + if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline); + if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected); + if (dwMask and CFM_OFFSET) <> 0 then Include(Result, caOffset); + if (dwMask and CFM_HIDDEN) <> 0 then Include(result, caHidden); + if RichEditVersion >= 2 then begin + if (dwMask and CFM_LINK) <> 0 then Include(Result, caLink); + if (dwMask and CFM_BACKCOLOR) <> 0 then Include(Result, caBackColor); + if (dwMask and CFM_DISABLED) <> 0 then Include(Result, caDisabled); + if (dwMask and CFM_WEIGHT) <> 0 then Include(Result, caWeight); + if (dwMask and CFM_SUBSCRIPT) <> 0 then Include(Result, caSubscript); + if (dwMask and CFM_REVAUTHOR) <> 0 then Include(Result, caRevAuthor); + end; + end; + end; +end; + +procedure TRxTextAttributes.GetAttributes(var Format: TCharFormat2); +begin + InitFormat(Format); + if RichEdit.HandleAllocated then + SendMessage(RichEdit.Handle, EM_GETCHARFORMAT, AttrFlags[FType], + LPARAM(@Format)); +end; + +procedure TRxTextAttributes.SetAttributes(var Format: TCharFormat2); +begin + if RichEdit.HandleAllocated then + SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, AttrFlags[FType], + LPARAM(@Format)); +end; + +function TRxTextAttributes.GetCharset: TFontCharset; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + Result := Format.bCharset; +end; + +procedure TRxTextAttributes.SetCharset(Value: TFontCharset); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do + begin + dwMask := CFM_CHARSET; + bCharSet := Value; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetProtected: Boolean; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + with Format do + Result := (dwEffects and CFE_PROTECTED) <> 0; +end; + +procedure TRxTextAttributes.SetProtected(Value: Boolean); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := CFM_PROTECTED; + if Value then dwEffects := CFE_PROTECTED; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetLink: Boolean; +var + Format: TCharFormat2; +begin + Result := False; + if RichEditVersion < 2 then Exit; + GetAttributes(Format); + with Format do Result := (dwEffects and CFE_LINK) <> 0; +end; + +procedure TRxTextAttributes.SetLink(Value: Boolean); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_LINK; + if Value then dwEffects := CFE_LINK; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetRevAuthorIndex: Byte; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + Result := Format.bRevAuthor; +end; + +procedure TRxTextAttributes.SetRevAuthorIndex(Value: Byte); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_REVAUTHOR; + bRevAuthor := Value; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetHidden: Boolean; +var + Format: TCharFormat2; +begin + Result := False; + if RichEditVersion < 2 then Exit; + GetAttributes(Format); + Result := Format.dwEffects and CFE_HIDDEN <> 0; +end; + +procedure TRxTextAttributes.SetHidden(Value: Boolean); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_HIDDEN; + if Value then dwEffects := CFE_HIDDEN; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetDisabled: Boolean; +var + Format: TCharFormat2; +begin + Result := False; + if RichEditVersion < 2 then Exit; + GetAttributes(Format); + Result := Format.dwEffects and CFE_DISABLED <> 0; +end; + +procedure TRxTextAttributes.SetDisabled(Value: Boolean); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_DISABLED; + if Value then dwEffects := CFE_DISABLED; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetColor: TColor; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + with Format do + if (dwEffects and CFE_AUTOCOLOR) <> 0 then Result := clWindowText + else Result := crTextColor; +end; + +procedure TRxTextAttributes.SetColor(Value: TColor); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := CFM_COLOR; + if (Value = clWindowText) or (Value = clDefault) then + dwEffects := CFE_AUTOCOLOR + else crTextColor := ColorToRGB(Value); + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetBackColor: TColor; +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then begin + Result := clWindow; + Exit; + end; + GetAttributes(Format); + with Format do + if (dwEffects and CFE_AUTOBACKCOLOR) <> 0 then Result := clWindow + else Result := crBackColor; +end; + +procedure TRxTextAttributes.SetBackColor(Value: TColor); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_BACKCOLOR; + if (Value = clWindow) or (Value = clDefault) then + dwEffects := CFE_AUTOBACKCOLOR + else crBackColor := ColorToRGB(Value); + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetName: TFontName; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + Result := Format.szFaceName; +end; + +procedure TRxTextAttributes.SetName(Value: TFontName); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := CFM_FACE; + StrPLCopy(szFaceName, Value, SizeOf(szFaceName)); + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetStyle: TFontStyles; +var + Format: TCharFormat2; +begin + Result := []; + GetAttributes(Format); + with Format do begin + if (dwEffects and CFE_BOLD) <> 0 then Include(Result, fsBold); + if (dwEffects and CFE_ITALIC) <> 0 then Include(Result, fsItalic); + if (dwEffects and CFE_UNDERLINE) <> 0 then Include(Result, fsUnderline); + if (dwEffects and CFE_STRIKEOUT) <> 0 then Include(Result, fsStrikeOut); + end; +end; + +procedure TRxTextAttributes.SetStyle(Value: TFontStyles); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT; + if fsBold in Value then dwEffects := dwEffects or CFE_BOLD; + if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC; + if fsUnderline in Value then dwEffects := dwEffects or CFE_UNDERLINE; + if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetUnderlineType: TUnderlineType; +var + Format: TCharFormat2; +begin + Result := utNone; + if RichEditVersion < 2 then Exit; + GetAttributes(Format); + with Format do begin + if (dwEffects and CFE_UNDERLINE <> 0) and + (dwMask and CFM_UNDERLINETYPE = CFM_UNDERLINETYPE) then + Result := TUnderlineType(bUnderlineType); + end; +end; + +procedure TRxTextAttributes.SetUnderlineType(Value: TUnderlineType); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := CFM_UNDERLINETYPE or CFM_UNDERLINE; + bUnderlineType := Ord(Value); + if Value <> utNone then dwEffects := dwEffects or CFE_UNDERLINE; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetOffset: Integer; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + Result := Format.yOffset div 20; +end; + +procedure TRxTextAttributes.SetOffset(Value: Integer); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := DWORD(CFM_OFFSET); + yOffset := Value * 20; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetSize: Integer; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + Result := Format.yHeight div 20; +end; + +procedure TRxTextAttributes.SetSize(Value: Integer); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + dwMask := DWORD(CFM_SIZE); + yHeight := Value * 20; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetHeight: Integer; +begin + Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72); +end; + +procedure TRxTextAttributes.SetHeight(Value: Integer); +begin + Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels); +end; + +function TRxTextAttributes.GetPitch: TFontPitch; +var + Format: TCharFormat2; +begin + GetAttributes(Format); + case (Format.bPitchAndFamily and $03) of + DEFAULT_PITCH: Result := fpDefault; + VARIABLE_PITCH: Result := fpVariable; + FIXED_PITCH: Result := fpFixed; + else Result := fpDefault; + end; +end; + +procedure TRxTextAttributes.SetPitch(Value: TFontPitch); +var + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + case Value of + fpVariable: bPitchAndFamily := VARIABLE_PITCH; + fpFixed: bPitchAndFamily := FIXED_PITCH; + else bPitchAndFamily := DEFAULT_PITCH; + end; + end; + SetAttributes(Format); +end; + +function TRxTextAttributes.GetSubscriptStyle: TSubscriptStyle; +var + Format: TCharFormat2; +begin + Result := ssNone; + if RichEditVersion < 2 then Exit; + GetAttributes(Format); + with Format do begin + if (dwEffects and CFE_SUBSCRIPT) <> 0 then + Result := ssSubscript + else if (dwEffects and CFE_SUPERSCRIPT) <> 0 then + Result := ssSuperscript; + end; +end; + +procedure TRxTextAttributes.SetSubscriptStyle(Value: TSubscriptStyle); +var + Format: TCharFormat2; +begin + if RichEditVersion < 2 then Exit; + InitFormat(Format); + with Format do begin + dwMask := DWORD(CFM_SUBSCRIPT); + case Value of + ssSubscript: dwEffects := CFE_SUBSCRIPT; + ssSuperscript: dwEffects := CFE_SUPERSCRIPT; + end; + end; + SetAttributes(Format); +end; + +procedure TRxTextAttributes.AssignFont(Font: TFont); +var + LogFont: TLogFont; + Format: TCharFormat2; +begin + InitFormat(Format); + with Format do begin + case Font.Pitch of + fpVariable: bPitchAndFamily := VARIABLE_PITCH; + fpFixed: bPitchAndFamily := FIXED_PITCH; + else bPitchAndFamily := DEFAULT_PITCH; + end; + dwMask := dwMask or CFM_SIZE or CFM_BOLD or CFM_ITALIC or + CFM_UNDERLINE or CFM_STRIKEOUT or CFM_FACE or CFM_COLOR; + yHeight := Font.Size * 20; + if fsBold in Font.Style then dwEffects := dwEffects or CFE_BOLD; + if fsItalic in Font.Style then dwEffects := dwEffects or CFE_ITALIC; + if fsUnderline in Font.Style then dwEffects := dwEffects or CFE_UNDERLINE; + if fsStrikeOut in Font.Style then dwEffects := dwEffects or CFE_STRIKEOUT; + StrPLCopy(szFaceName, Font.Name, SizeOf(szFaceName)); + if (Font.Color = clWindowText) or (Font.Color = clDefault) then + dwEffects := dwEffects or CFE_AUTOCOLOR + else crTextColor := ColorToRGB(Font.Color); + dwMask := dwMask or CFM_CHARSET; + bCharSet := Font.Charset; + if GetObject(Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then begin + dwMask := dwMask or DWORD(CFM_WEIGHT); + wWeight := Word(LogFont.lfWeight); + end; + end; + SetAttributes(Format); +end; + +procedure TRxTextAttributes.Assign(Source: TPersistent); +var + Format: TCharFormat2; +begin + if Source is TFont then AssignFont(TFont(Source)) + else if Source is TTextAttributes then begin + Name := TTextAttributes(Source).Name; + Charset := TTextAttributes(Source).Charset; + Style := TTextAttributes(Source).Style; + Pitch := TTextAttributes(Source).Pitch; + Color := TTextAttributes(Source).Color; + end + else if Source is TRxTextAttributes then begin + TRxTextAttributes(Source).GetAttributes(Format); + SetAttributes(Format); + end + else inherited Assign(Source); +end; + +procedure TRxTextAttributes.AssignTo(Dest: TPersistent); +begin + if Dest is TFont then begin + TFont(Dest).Color := Color; + TFont(Dest).Name := Name; + TFont(Dest).Charset := Charset; + TFont(Dest).Style := Style; + TFont(Dest).Size := Size; + TFont(Dest).Pitch := Pitch; + end + else if Dest is TTextAttributes then begin + TTextAttributes(Dest).Color := Color; + TTextAttributes(Dest).Name := Name; + TTextAttributes(Dest).Charset := Charset; + TTextAttributes(Dest).Style := Style; + TTextAttributes(Dest).Pitch := Pitch; + end + else inherited AssignTo(Dest); +end; + +{ TRxParaAttributes } + +constructor TRxParaAttributes.Create(AOwner: TRxCustomRichEdit); +begin + inherited Create; + RichEdit := AOwner; +end; + +procedure TRxParaAttributes.InitPara(var Paragraph: TParaFormat2); +begin + FillChar(Paragraph, SizeOf(Paragraph), 0); + if RichEditVersion >= 2 then + Paragraph.cbSize := SizeOf(Paragraph) + else + Paragraph.cbSize := SizeOf(TParaFormat); +end; + +procedure TRxParaAttributes.GetAttributes(var Paragraph: TParaFormat2); +begin + InitPara(Paragraph); + if RichEdit.HandleAllocated then + SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph)); +end; + +procedure TRxParaAttributes.SetAttributes(var Paragraph: TParaFormat2); +begin + RichEdit.HandleNeeded; { we REALLY need the handle for BiDi } + if RichEdit.HandleAllocated then begin + if RichEdit.UseRightToLeftAlignment then + if Paragraph.wAlignment = PFA_LEFT then + Paragraph.wAlignment := PFA_RIGHT + else if Paragraph.wAlignment = PFA_RIGHT then + Paragraph.wAlignment := PFA_LEFT; + SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph)); + end; +end; + +function TRxParaAttributes.GetAlignment: TParaAlignment; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := TParaAlignment(Paragraph.wAlignment - 1); +end; + +procedure TRxParaAttributes.SetAlignment(Value: TParaAlignment); +var + Paragraph: TParaFormat2; +begin + InitPara(Paragraph); + with Paragraph do + begin + dwMask := PFM_ALIGNMENT; + wAlignment := Ord(Value) + 1; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetNumbering: TRxNumbering; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := TRxNumbering(Paragraph.wNumbering); + if RichEditVersion = 1 then + if Result <> nsNone then Result := nsBullet; +end; + +procedure TRxParaAttributes.SetNumbering(Value: TRxNumbering); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion = 1 then + if Value <> nsNone then Value := TRxNumbering(PFN_BULLET); + case Value of + nsNone: LeftIndent := 0; + else if LeftIndent < 10 then LeftIndent := 10; + end; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_NUMBERING; + wNumbering := Ord(Value); + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetNumberingStyle: TRxNumberingStyle; +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then + Result := nsSimple + else begin + GetAttributes(Paragraph); + Result := TRxNumberingStyle(Paragraph.wNumberingStyle); + end; +end; + +procedure TRxParaAttributes.SetNumberingStyle(Value: TRxNumberingStyle); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_NUMBERINGSTYLE; + wNumberingStyle := Ord(Value); + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetNumberingTab: Word; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.wNumberingTab div 20; +end; + +procedure TRxParaAttributes.SetNumberingTab(Value: Word); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_NUMBERINGTAB; + wNumberingTab := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetFirstIndent: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dxStartIndent div 20; +end; + +procedure TRxParaAttributes.SetFirstIndent(Value: Longint); +var + Paragraph: TParaFormat2; +begin + InitPara(Paragraph); + with Paragraph do + begin + dwMask := PFM_STARTINDENT; + dxStartIndent := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetHeadingStyle: THeadingStyle; +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 3 then Result := 0 + else begin + GetAttributes(Paragraph); + Result := Paragraph.sStyle; + end; +end; + +procedure TRxParaAttributes.SetHeadingStyle(Value: THeadingStyle); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 3 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_STYLE; + sStyle := Value; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetLeftIndent: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dxOffset div 20; +end; + +procedure TRxParaAttributes.SetLeftIndent(Value: Longint); +var + Paragraph: TParaFormat2; +begin + InitPara(Paragraph); + with Paragraph do + begin + dwMask := PFM_OFFSET; + dxOffset := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetRightIndent: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dxRightIndent div 20; +end; + +procedure TRxParaAttributes.SetRightIndent(Value: Longint); +var + Paragraph: TParaFormat2; +begin + InitPara(Paragraph); + with Paragraph do + begin + dwMask := PFM_RIGHTINDENT; + dxRightIndent := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetSpaceAfter: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dySpaceAfter div 20; +end; + +procedure TRxParaAttributes.SetSpaceAfter(Value: Longint); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_SPACEAFTER; + dySpaceAfter := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetSpaceBefore: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dySpaceBefore div 20; +end; + +procedure TRxParaAttributes.SetSpaceBefore(Value: Longint); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_SPACEBEFORE; + dySpaceBefore := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetLineSpacing: Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.dyLineSpacing div 20; +end; + +procedure TRxParaAttributes.SetLineSpacing(Value: Longint); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + GetAttributes(Paragraph); + with Paragraph do begin + dwMask := PFM_LINESPACING; + dyLineSpacing := Value * 20; + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetLineSpacingRule: TLineSpacingRule; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := TLineSpacingRule(Paragraph.bLineSpacingRule); +end; + +procedure TRxParaAttributes.SetLineSpacingRule(Value: TLineSpacingRule); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + GetAttributes(Paragraph); + with Paragraph do begin + dwMask := PFM_LINESPACING; + bLineSpacingRule := Ord(Value); + end; + SetAttributes(Paragraph); +end; + +function TRxParaAttributes.GetTab(Index: Byte): Longint; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.rgxTabs[Index] div 20; +end; + +procedure TRxParaAttributes.SetTab(Index: Byte; Value: Longint); +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + with Paragraph do + begin + rgxTabs[Index] := Value * 20; + dwMask := PFM_TABSTOPS; + if cTabCount < Index then cTabCount := Index; + SetAttributes(Paragraph); + end; +end; + +function TRxParaAttributes.GetTabCount: Integer; +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + Result := Paragraph.cTabCount; +end; + +procedure TRxParaAttributes.SetTabCount(Value: Integer); +var + Paragraph: TParaFormat2; +begin + GetAttributes(Paragraph); + with Paragraph do + begin + dwMask := PFM_TABSTOPS; + cTabCount := Value; + SetAttributes(Paragraph); + end; +end; + +function TRxParaAttributes.GetTableStyle: TParaTableStyle; +var + Paragraph: TParaFormat2; +begin + Result := tsNone; + if RichEditVersion < 2 then Exit; + GetAttributes(Paragraph); + with Paragraph do begin + if (wReserved and PFE_TABLEROW) <> 0 then + Result := tsTableRow + else if (wReserved and PFE_TABLECELLEND) <> 0 then + Result := tsTableCellEnd + else if (wReserved and PFE_TABLECELL) <> 0 then + Result := tsTableCell; + end; +end; + +procedure TRxParaAttributes.SetTableStyle(Value: TParaTableStyle); +var + Paragraph: TParaFormat2; +begin + if RichEditVersion < 2 then Exit; + InitPara(Paragraph); + with Paragraph do begin + dwMask := PFM_TABLE; + case Value of + tsTableRow: wReserved := PFE_TABLEROW; + tsTableCellEnd: wReserved := PFE_TABLECELLEND; + tsTableCell: wReserved := PFE_TABLECELL; + end; + end; + SetAttributes(Paragraph); +end; + +procedure TRxParaAttributes.AssignTo(Dest: TPersistent); +var + I: Integer; +begin + if Dest is TParaAttributes then begin + with TParaAttributes(Dest) do begin +// if Self.Alignment = paJustify then Alignment := taLeftJustify +// else + Alignment := TAlignment(Self.Alignment); + FirstIndent := Self.FirstIndent; + LeftIndent := Self.LeftIndent; + RightIndent := Self.RightIndent; + if Self.Numbering <> nsNone then + Numbering := TNumberingStyle(nsBullet) + else Numbering := TNumberingStyle(nsNone); + for I := 0 to MAX_TAB_STOPS - 1 do + Tab[I] := Self.Tab[I]; + end; + end + else inherited AssignTo(Dest); +end; + +procedure TRxParaAttributes.Assign(Source: TPersistent); +var + I: Integer; + Paragraph: TParaFormat2; +begin + if Source is TParaAttributes then begin + Alignment := TParaAlignment(TParaAttributes(Source).Alignment); + FirstIndent := TParaAttributes(Source).FirstIndent; + LeftIndent := TParaAttributes(Source).LeftIndent; + RightIndent := TParaAttributes(Source).RightIndent; + Numbering := TRxNumbering(TParaAttributes(Source).Numbering); + for I := 0 to MAX_TAB_STOPS - 1 do + Tab[I] := TParaAttributes(Source).Tab[I]; + end + else if Source is TRxParaAttributes then begin + TRxParaAttributes(Source).GetAttributes(Paragraph); + SetAttributes(Paragraph); + end + else inherited Assign(Source); +end; + +{ OLE utility routines } + +function WStrLen(Str: PWideChar): Integer; +begin + Result := 0; + while Str[Result] <> #0 do Inc(Result); +end; + +procedure ReleaseObject(var Obj); +begin + if IUnknown(Obj) <> nil then begin + IUnknown(Obj) := nil; + end; +end; + +procedure CreateStorage(var Storage: IStorage); +var + LockBytes: ILockBytes; +begin + OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes)); + try + OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE + or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Storage)); + finally + ReleaseObject(LockBytes); + end; +end; + +procedure DestroyMetaPict(MetaPict: HGlobal); +begin + if MetaPict <> 0 then begin + DeleteMetaFile(PMetaFilePict(GlobalLock(MetaPict))^.hMF); + GlobalUnlock(MetaPict); + GlobalFree(MetaPict); + end; +end; + +function OleSetDrawAspect(OleObject: IOleObject; Iconic: Boolean; + IconMetaPict: HGlobal; var DrawAspect: Longint): HResult; +var + OleCache: IOleCache; + EnumStatData: IEnumStatData; + OldAspect, AdviseFlags, Connection: Longint; + TempMetaPict: HGlobal; + FormatEtc: TFormatEtc; + Medium: TStgMedium; + ClassID: TCLSID; + StatData: TStatData; +begin + Result := S_OK; + OldAspect := DrawAspect; + if Iconic then begin + DrawAspect := DVASPECT_ICON; + AdviseFlags := ADVF_NODATA; + end + else begin + DrawAspect := DVASPECT_CONTENT; + AdviseFlags := ADVF_PRIMEFIRST; + end; + if (DrawAspect <> OldAspect) or (DrawAspect = DVASPECT_ICON) then begin + Result := OleObject.QueryInterface(IOleCache, OleCache); + if Succeeded(Result) then + try + if DrawAspect <> OldAspect then begin + { Setup new cache with the new aspect } + FillChar(FormatEtc, SizeOf(FormatEtc), 0); + FormatEtc.dwAspect := DrawAspect; + FormatEtc.lIndex := -1; + Result := OleCache.Cache(FormatEtc, AdviseFlags, Connection); + end; + if Succeeded(Result) and (DrawAspect = DVASPECT_ICON) then begin + TempMetaPict := 0; + if IconMetaPict = 0 then begin + if Succeeded(OleObject.GetUserClassID(ClassID)) then begin + TempMetaPict := OleGetIconOfClass(ClassID, nil, True); + IconMetaPict := TempMetaPict; + end; + end; + try + FormatEtc.cfFormat := CF_METAFILEPICT; + FormatEtc.ptd := nil; + FormatEtc.dwAspect := DVASPECT_ICON; + FormatEtc.lIndex := -1; + FormatEtc.tymed := TYMED_MFPICT; + Medium.tymed := TYMED_MFPICT; + Medium.hMetaFilePict := IconMetaPict; + Medium.unkForRelease := nil; + Result := OleCache.SetData(FormatEtc, Medium, False); + finally + DestroyMetaPict(TempMetaPict); + end; + end; + if Succeeded(Result) and (DrawAspect <> OldAspect) then begin + { remove any existing caches that are set up for the old display aspect } + OleCache.EnumCache(EnumStatData); + if EnumStatData <> nil then + try + while EnumStatData.Next(1, StatData, nil) = 0 do + if StatData.formatetc.dwAspect = OldAspect then + OleCache.Uncache(StatData.dwConnection); + finally + ReleaseObject(EnumStatData); + end; + end; + finally + ReleaseObject(OleCache); + end; + if Succeeded(Result) and (DrawAspect <> DVASPECT_ICON) then + OleObject.Update; + end; +end; + +function GetIconMetaPict(OleObject: IOleObject; DrawAspect: Longint): HGlobal; +var + DataObject: IDataObject; + FormatEtc: TFormatEtc; + Medium: TStgMedium; + ClassID: TCLSID; +begin + Result := 0; + if DrawAspect = DVASPECT_ICON then begin + OleObject.QueryInterface(IDataObject, DataObject); + if DataObject <> nil then begin + FormatEtc.cfFormat := CF_METAFILEPICT; + FormatEtc.ptd := nil; + FormatEtc.dwAspect := DVASPECT_ICON; + FormatEtc.lIndex := -1; + FormatEtc.tymed := TYMED_MFPICT; + if Succeeded(DataObject.GetData(FormatEtc, Medium)) then + Result := Medium.hMetaFilePict; + ReleaseObject(DataObject); + end; + end; + if Result = 0 then begin + OleCheck(OleObject.GetUserClassID(ClassID)); + Result := OleGetIconOfClass(ClassID, nil, True); + end; +end; + +{ Return the first piece of a moniker } + +function OleStdGetFirstMoniker(Moniker: IMoniker): IMoniker; +var + Mksys: Longint; + EnumMoniker: IEnumMoniker; +begin + Result := nil; + if Moniker <> nil then begin + if (Moniker.IsSystemMoniker(Mksys) = 0) and + (Mksys = MKSYS_GENERICCOMPOSITE) then + begin + if Moniker.Enum(True, EnumMoniker) <> 0 then Exit; + EnumMoniker.Next(1, Result, nil); + ReleaseObject(EnumMoniker); + end + else begin + Result := Moniker; + end; + end; +end; + +{ Return length of file moniker piece of the given moniker } + +function OleStdGetLenFilePrefixOfMoniker(Moniker: IMoniker): Integer; +var + MkFirst: IMoniker; + BindCtx: IBindCtx; + Mksys: Longint; + P: PWideChar; +begin + Result := 0; + if Moniker <> nil then begin + MkFirst := OleStdGetFirstMoniker(Moniker); + if MkFirst <> nil then begin + if (MkFirst.IsSystemMoniker(Mksys) = 0) and + (Mksys = MKSYS_FILEMONIKER) then + begin + if CreateBindCtx(0, BindCtx) = 0 then begin + if (MkFirst.GetDisplayName(BindCtx, nil, P) = 0) and (P <> nil) then + begin + Result := WStrLen(P); + CoTaskMemFree(P); + end; + ReleaseObject(BindCtx); + end; + end; + ReleaseObject(MkFirst); + end; + end; +end; + +function CoAllocCStr(const S: string): PChar; +begin + Result := StrCopy(CoTaskMemAlloc(Length(S) + 1), PChar(S)); +end; + +function WStrToString(P: PWideChar): string; +begin + Result := ''; + if P <> nil then begin + Result := WideCharToString(P); + CoTaskMemFree(P); + end; +end; + +function GetFullNameStr(OleObject: IOleObject): string; +var + P: PWideChar; +begin + OleObject.GetUserType(USERCLASSTYPE_FULL, P); + Result := WStrToString(P); +end; + +function GetShortNameStr(OleObject: IOleObject): string; +var + P: PWideChar; +begin + OleObject.GetUserType(USERCLASSTYPE_SHORT, P); + Result := WStrToString(P); +end; + +function GetDisplayNameStr(OleLink: IOleLink): string; +var + P: PWideChar; +begin + OleLink.GetSourceDisplayName(P); + Result := WStrToString(P); +end; + +function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm; +begin + if Form.OleFormObject = nil then TOleForm.Create(Form); + Result := Form.OleFormObject as IVCLFrameForm; +end; + +function IsFormMDIChild(Form: TCustomForm): Boolean; +begin + Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild); +end; + +{ Clipboard formats } + +var + CFEmbeddedObject: Integer; + CFLinkSource: Integer; + CFRtf: Integer; + CFRtfNoObjs: Integer; + +const + CF_EMBEDDEDOBJECT = 'Embedded Object'; + CF_LINKSOURCE = 'Link Source'; + +{************************************************************************} + +{ OLE Extensions to the Rich Text Editor } +{ Converted from RICHOLE.H } + +{ Structure passed to GetObject and InsertObject } + +type + _ReObject = record + cbStruct: DWORD; { Size of structure } + cp: ULONG; { Character position of object } + clsid: TCLSID; { Class ID of object } + poleobj: IOleObject; { OLE object interface } + pstg: IStorage; { Associated storage interface } + polesite: IOleClientSite; { Associated client site interface } + sizel: TSize; { Size of object (may be 0,0) } + dvAspect: Longint; { Display aspect to use } + dwFlags: DWORD; { Object status flags } + dwUser: DWORD; { Dword for user's use } + end; + TReObject = _ReObject; + +const + +{ Flags to specify which interfaces should be returned in the structure above } + + REO_GETOBJ_NO_INTERFACES = $00000000; + REO_GETOBJ_POLEOBJ = $00000001; + REO_GETOBJ_PSTG = $00000002; + REO_GETOBJ_POLESITE = $00000004; + REO_GETOBJ_ALL_INTERFACES = $00000007; + +{ Place object at selection } + + REO_CP_SELECTION = ULONG(-1); + +{ Use character position to specify object instead of index } + + REO_IOB_SELECTION = ULONG(-1); + REO_IOB_USE_CP = ULONG(-2); + +{ Object flags } + + REO_NULL = $00000000; { No flags } + REO_READWRITEMASK = $0000003F; { Mask out RO bits } + REO_DONTNEEDPALETTE = $00000020; { Object doesn't need palette } + REO_BLANK = $00000010; { Object is blank } + REO_DYNAMICSIZE = $00000008; { Object defines size always } + REO_INVERTEDSELECT = $00000004; { Object drawn all inverted if sel } + REO_BELOWBASELINE = $00000002; { Object sits below the baseline } + REO_RESIZABLE = $00000001; { Object may be resized } + REO_LINK = $80000000; { Object is a link (RO) } + REO_STATIC = $40000000; { Object is static (RO) } + REO_SELECTED = $08000000; { Object selected (RO) } + REO_OPEN = $04000000; { Object open in its server (RO) } + REO_INPLACEACTIVE = $02000000; { Object in place active (RO) } + REO_HILITED = $01000000; { Object is to be hilited (RO) } + REO_LINKAVAILABLE = $00800000; { Link believed available (RO) } + REO_GETMETAFILE = $00400000; { Object requires metafile (RO) } + +{ Flags for IRichEditOle.GetClipboardData, } +{ IRichEditOleCallback.GetClipboardData and } +{ IRichEditOleCallback.QueryAcceptData } + + RECO_PASTE = $00000000; { paste from clipboard } + RECO_DROP = $00000001; { drop } + RECO_COPY = $00000002; { copy to the clipboard } + RECO_CUT = $00000003; { cut to the clipboard } + RECO_DRAG = $00000004; { drag } + +{ RichEdit GUIDs } + +{ IID_IRichEditOle: TGUID = ( + D1:$00020D00;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); + IID_IRichEditOleCallback: TGUID = ( + D1:$00020D03;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));} + +type + +{ + * IRichEditOle + * + * Purpose: + * Interface used by the client of RichEdit to perform OLE-related + * operations. + * + * The methods herein may just want to be regular Windows messages. +} + + IRichEditOle = interface(IUnknown) + ['{00020d00-0000-0000-c000-000000000046}'] + function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall; + function GetObjectCount: HResult; stdcall; + function GetLinkCount: HResult; stdcall; + function GetObject(iob: Longint; out reobject: TReObject; + dwFlags: DWORD): HResult; stdcall; + function InsertObject(var reobject: TReObject): HResult; stdcall; + function ConvertObject(iob: Longint; rclsidNew: TIID; + lpstrUserTypeNew: LPCSTR): HResult; stdcall; + function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall; + function SetHostNames(lpstrContainerApp: LPCSTR; + lpstrContainerObj: LPCSTR): HResult; stdcall; + function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall; + function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall; + function HandsOffStorage(iob: Longint): HResult; stdcall; + function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall; + function InPlaceDeactivate: HResult; stdcall; + function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; + function GetClipboardData(var chrg: TCharRange; reco: DWORD; + out dataobj: IDataObject): HResult; stdcall; + function ImportDataObject(dataobj: IDataObject; cf: TClipFormat; + hMetaPict: HGLOBAL): HResult; stdcall; + end; + +{ + * IRichEditOleCallback + * + * Purpose: + * Interface used by the RichEdit to get OLE-related stuff from the + * application using RichEdit. +} + + IRichEditOleCallback = interface(IUnknown) + ['{00020d03-0000-0000-c000-000000000046}'] + function GetNewStorage(out stg: IStorage): HResult; stdcall; + function GetInPlaceContext(out Frame: IOleInPlaceFrame; + out Doc: IOleInPlaceUIWindow; + lpFrameInfo: POleInPlaceFrameInfo): HResult; stdcall; + function ShowContainerUI(fShow: BOOL): HResult; stdcall; + function QueryInsertObject(const clsid: TCLSID; const stg: IStorage; + cp: Longint): HResult; stdcall; + function DeleteObject(const oleobj: IOleObject): HResult; stdcall; + function QueryAcceptData(const dataobj: IDataObject; + var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; + hMetaPict: HGLOBAL): HResult; stdcall; + function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; + function GetClipboardData(const chrg: TCharRange; reco: DWORD; + out dataobj: IDataObject): HResult; stdcall; + function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD; + var dwEffect: DWORD): HResult; stdcall; + function GetContextMenu(seltype: Word; const oleobj: IOleObject; + const chrg: TCharRange; out menu: HMENU): HResult; stdcall; + end; + +{************************************************************************} + +{ TRichEditOleCallback } + +type + TRichEditOleCallback = class(TObject, IUnknown, IRichEditOleCallback) + private + FDocForm: IVCLFrameForm; + FFrameForm: IVCLFrameForm; + FAccelTable: HAccel; + FAccelCount: Integer; + FAutoScroll: Boolean; + procedure CreateAccelTable; + procedure DestroyAccelTable; + procedure AssignFrame; + private + FRefCount: Longint; + FRichEdit: TRxCustomRichEdit; + public + constructor Create(RichEdit: TRxCustomRichEdit); + destructor Destroy; override; + function QueryInterface(const iid: TGUID; out Obj): HResult; stdcall; + function _AddRef: Longint; stdcall; + function _Release: Longint; stdcall; + function GetNewStorage(out stg: IStorage): HResult; stdcall; + function GetInPlaceContext(out Frame: IOleInPlaceFrame; + out Doc: IOleInPlaceUIWindow; + lpFrameInfo: POleInPlaceFrameInfo): HResult; stdcall; + function GetClipboardData(const chrg: TCharRange; reco: DWORD; + out dataobj: IDataObject): HResult; stdcall; + function GetContextMenu(seltype: Word; const oleobj: IOleObject; + const chrg: TCharRange; out menu: HMENU): HResult; stdcall; + function ShowContainerUI(fShow: BOOL): HResult; stdcall; + function QueryInsertObject(const clsid: TCLSID; const stg: IStorage; + cp: Longint): HResult; stdcall; + function DeleteObject(const oleobj: IOleObject): HResult; stdcall; + function QueryAcceptData(const dataobj: IDataObject; var cfFormat: TClipFormat; + reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HResult; stdcall; + function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; + function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD; + var dwEffect: DWORD): HResult; stdcall; + end; + +constructor TRichEditOleCallback.Create(RichEdit: TRxCustomRichEdit); +begin + inherited Create; + FRichEdit := RichEdit; +end; + +destructor TRichEditOleCallback.Destroy; +begin + DestroyAccelTable; + FFrameForm := nil; + FDocForm := nil; + inherited Destroy; +end; + +function TRichEditOleCallback.QueryInterface(const iid: TGUID; out Obj): HResult; +begin + if GetInterface(iid, Obj) then Result := S_OK + else Result := E_NOINTERFACE; +end; + +function TRichEditOleCallback._AddRef: Longint; +begin + Inc(FRefCount); + Result := FRefCount; +end; + +function TRichEditOleCallback._Release: Longint; +begin + Dec(FRefCount); + Result := FRefCount; +end; + +procedure TRichEditOleCallback.CreateAccelTable; +var + Menu: TMainMenu; +begin + if (FAccelTable = 0) and Assigned(FFrameForm) then begin + Menu := FFrameForm.Form.Menu; + if Menu <> nil then + Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]); + end; +end; + +procedure TRichEditOleCallback.DestroyAccelTable; +begin + if FAccelTable <> 0 then begin + DestroyAcceleratorTable(FAccelTable); + FAccelTable := 0; + FAccelCount := 0; + end; +end; + +procedure TRichEditOleCallback.AssignFrame; +begin + if (GetParentForm(FRichEdit) <> nil) and not Assigned(FFrameForm) and + FRichEdit.AllowInPlace then + begin + FDocForm := GetVCLFrameForm(ValidParentForm(FRichEdit)); + FFrameForm := FDocForm; + if IsFormMDIChild(FDocForm.Form) then + FFrameForm := GetVCLFrameForm(Application.MainForm); + end; +end; + +function TRichEditOleCallback.GetNewStorage( + out stg: IStorage): HResult; +begin + try + CreateStorage(stg); + Result := S_OK; + except + Result:= E_OUTOFMEMORY; + end; +end; + +function TRichEditOleCallback.GetInPlaceContext( + out Frame: IOleInPlaceFrame; + out Doc: IOleInPlaceUIWindow; + lpFrameInfo: POleInPlaceFrameInfo): HResult; +begin + AssignFrame; + if Assigned(FFrameForm) and FRichEdit.AllowInPlace then begin + Frame := FFrameForm; + Doc := FDocForm; + CreateAccelTable; + with lpFrameInfo^ do begin + fMDIApp := False; + FFrameForm.GetWindow(hWndFrame); + hAccel := FAccelTable; + cAccelEntries := FAccelCount; + end; + Result := S_OK; + end + else Result := E_NOTIMPL; +end; + +function TRichEditOleCallback.QueryInsertObject(const clsid: TCLSID; const stg: IStorage; + cp: Longint): HResult; +begin + Result := NOERROR; +end; + +function TRichEditOleCallback.DeleteObject(const oleobj: IOleObject): HResult; +begin + if Assigned(oleobj) then oleobj.Close(OLECLOSE_NOSAVE); + Result := NOERROR; +end; + +function TRichEditOleCallback.QueryAcceptData(const dataobj: IDataObject; + var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; + hMetaPict: HGLOBAL): HResult; +begin + Result := S_OK; +end; + +function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HResult; +begin + Result := NOERROR; +end; + +function TRichEditOleCallback.GetClipboardData(const chrg: TCharRange; reco: DWORD; + out dataobj: IDataObject): HResult; +begin + Result := E_NOTIMPL; +end; + +function TRichEditOleCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD; + var dwEffect: DWORD): HResult; +begin + Result := E_NOTIMPL; +end; + +function TRichEditOleCallback.GetContextMenu(seltype: Word; + const oleobj: IOleObject; const chrg: TCharRange; + out menu: HMENU): HResult; +begin + Result := E_NOTIMPL; +end; + +function TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HResult; +begin + if not fShow then AssignFrame; + if Assigned(FFrameForm) then begin + if fShow then begin + FFrameForm.SetMenu(0, 0, 0); + FFrameForm.ClearBorderSpace; + FRichEdit.SetUIActive(False); + DestroyAccelTable; + TForm(FFrameForm.Form).AutoScroll := FAutoScroll; + FFrameForm := nil; + FDocForm := nil; + end + else begin + FAutoScroll := TForm(FFrameForm.Form).AutoScroll; + TForm(FFrameForm.Form).AutoScroll := False; + FRichEdit.SetUIActive(True); + end; + Result := S_OK; + end + else Result := E_NOTIMPL; +end; + +{ TOleUIObjInfo - helper interface for Object Properties dialog } + +type + TOleUIObjInfo = class(TInterfacedObject, IOleUIObjInfo) + private + FRichEdit: TRxCustomRichEdit; + FReObject: TReObject; + public + constructor Create(RichEdit: TRxCustomRichEdit; ReObject: TReObject); + function GetObjectInfo(dwObject: Longint; + var dwObjSize: Longint; var lpszLabel: PChar; + var lpszType: PChar; var lpszShortType: PChar; + var lpszLocation: PChar): HResult; stdcall; + function GetConvertInfo(dwObject: Longint; var ClassID: TCLSID; + var wFormat: Word; var ConvertDefaultClassID: TCLSID; + var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult; stdcall; + function ConvertObject(dwObject: Longint; + const clsidNew: TCLSID): HResult; stdcall; + function GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal; + var dvAspect: Longint; var nCurrentScale: Integer): HResult; stdcall; + function SetViewInfo(dwObject: Longint; hMetaPict: HGlobal; + dvAspect: Longint; nCurrentScale: Integer; + bRelativeToOrig: BOOL): HResult; stdcall; + end; + +constructor TOleUIObjInfo.Create(RichEdit: TRxCustomRichEdit; + ReObject: TReObject); +begin + inherited Create; + FRichEdit := RichEdit; + FReObject := ReObject; +end; + +function TOleUIObjInfo.GetObjectInfo(dwObject: Longint; + var dwObjSize: Longint; var lpszLabel: PChar; + var lpszType: PChar; var lpszShortType: PChar; + var lpszLocation: PChar): HResult; +begin + if @dwObjSize <> nil then + dwObjSize := -1 { Unknown size }; + if @lpszLabel <> nil then + lpszLabel := CoAllocCStr(GetFullNameStr(FReObject.poleobj)); + if @lpszType <> nil then + lpszType := CoAllocCStr(GetFullNameStr(FReObject.poleobj)); + if @lpszShortType <> nil then + lpszShortType := CoAllocCStr(GetShortNameStr(FReObject.poleobj)); + if (@lpszLocation <> nil) then begin + if Trim(FRichEdit.Title) <> '' then + lpszLocation := CoAllocCStr(Format('%s - %s', + [FRichEdit.Title, Application.Title])) + else + lpszLocation := CoAllocCStr(Application.Title); + end; + Result := S_OK; +end; + +function TOleUIObjInfo.GetConvertInfo(dwObject: Longint; var ClassID: TCLSID; + var wFormat: Word; var ConvertDefaultClassID: TCLSID; + var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult; +begin + FReObject.poleobj.GetUserClassID(ClassID); + Result := S_OK; +end; + +function TOleUIObjInfo.ConvertObject(dwObject: Longint; + const clsidNew: TCLSID): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleUIObjInfo.GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal; + var dvAspect: Longint; var nCurrentScale: Integer): HResult; +begin + if @hMetaPict <> nil then + hMetaPict := GetIconMetaPict(FReObject.poleobj, FReObject.dvAspect); + if @dvAspect <> nil then dvAspect := FReObject.dvAspect; + if @nCurrentScale <> nil then nCurrentScale := 0; + Result := S_OK; +end; + +function TOleUIObjInfo.SetViewInfo(dwObject: Longint; hMetaPict: HGlobal; + dvAspect: Longint; nCurrentScale: Integer; + bRelativeToOrig: BOOL): HResult; +var + Iconic: Boolean; +begin + if Assigned(FRichEdit.FRichEditOle) then begin + case dvAspect of + DVASPECT_CONTENT: + Iconic := False; + DVASPECT_ICON: + Iconic := True; + else + Iconic := FReObject.dvAspect = DVASPECT_ICON; + end; + IRichEditOle(FRichEdit.FRichEditOle).InPlaceDeactivate; + Result := OleSetDrawAspect(FReObject.poleobj, Iconic, hMetaPict, + FReObject.dvAspect); + if Succeeded(Result) then + IRichEditOle(FRichEdit.FRichEditOle).SetDvaspect( + Longint(REO_IOB_SELECTION), FReObject.dvAspect); + end + else Result := E_NOTIMPL; +end; + +{ TOleUILinkInfo - helper interface for Object Properties dialog } + +type + TOleUILinkInfo = class(TInterfacedObject, IOleUILinkInfo) + private + FReObject: TReObject; + FRichEdit: TRxCustomRichEdit; + FOleLink: IOleLink; + public + constructor Create(RichEdit: TRxCustomRichEdit; ReObject: TReObject); + function GetNextLink(dwLink: Longint): Longint; stdcall; + function SetLinkUpdateOptions(dwLink: Longint; + dwUpdateOpt: Longint): HResult; stdcall; + function GetLinkUpdateOptions(dwLink: Longint; + var dwUpdateOpt: Longint): HResult; stdcall; + function SetLinkSource(dwLink: Longint; pszDisplayName: PChar; + lenFileName: Longint; var chEaten: Longint; + fValidateSource: BOOL): HResult; stdcall; + function GetLinkSource(dwLink: Longint; var pszDisplayName: PChar; + var lenFileName: Longint; var pszFullLinkType: PChar; + var pszShortLinkType: PChar; var fSourceAvailable: BOOL; + var fIsSelected: BOOL): HResult; stdcall; + function OpenLinkSource(dwLink: Longint): HResult; stdcall; + function UpdateLink(dwLink: Longint; fErrorMessage: BOOL; + fErrorAction: BOOL): HResult; stdcall; + function CancelLink(dwLink: Longint): HResult; stdcall; + function GetLastUpdate(dwLink: Longint; + var LastUpdate: TFileTime): HResult; stdcall; + end; + +procedure LinkError(const Ident: string); +begin + Application.MessageBox(PChar(Ident), PChar(SLinkProperties), + MB_OK or MB_ICONSTOP); +end; + +constructor TOleUILinkInfo.Create(RichEdit: TRxCustomRichEdit; + ReObject: TReObject); +begin + inherited Create; + FReObject := ReObject; + FRichEdit := RichEdit; + OleCheck(FReObject.poleobj.QueryInterface(IOleLink, FOleLink)); +end; + +function TOleUILinkInfo.GetNextLink(dwLink: Longint): Longint; +begin + if dwLink = 0 then Result := Longint(FRichEdit) + else Result := 0; +end; + +function TOleUILinkInfo.SetLinkUpdateOptions(dwLink: Longint; + dwUpdateOpt: Longint): HResult; +begin + Result := FOleLink.SetUpdateOptions(dwUpdateOpt); + if Succeeded(Result) then FRichEdit.Modified := True; +end; + +function TOleUILinkInfo.GetLinkUpdateOptions(dwLink: Longint; + var dwUpdateOpt: Longint): HResult; +begin + Result := FOleLink.GetUpdateOptions(dwUpdateOpt); +end; + +function TOleUILinkInfo.SetLinkSource(dwLink: Longint; pszDisplayName: PChar; + lenFileName: Longint; var chEaten: Longint; + fValidateSource: BOOL): HResult; +var + DisplayName: string; + Buffer: array[0..255] of WideChar; +begin + Result := E_FAIL; + if fValidateSource then begin + DisplayName := pszDisplayName; + if Succeeded(FOleLink.SetSourceDisplayName(StringToWideChar(DisplayName, + Buffer, SizeOf(Buffer) div 2))) then + begin + chEaten := Length(DisplayName); + try + OleCheck(FReObject.poleobj.Update); + except + Application.HandleException(FRichEdit); + end; + Result := S_OK; + end; + end + else LinkError(SInvalidLinkSource); +end; + +function TOleUILinkInfo.GetLinkSource(dwLink: Longint; var pszDisplayName: PChar; + var lenFileName: Longint; var pszFullLinkType: PChar; + var pszShortLinkType: PChar; var fSourceAvailable: BOOL; + var fIsSelected: BOOL): HResult; +var + Moniker: IMoniker; +begin + if @pszDisplayName <> nil then + pszDisplayName := CoAllocCStr(GetDisplayNameStr(FOleLink)); + if @lenFileName <> nil then begin + lenFileName := 0; + FOleLink.GetSourceMoniker(Moniker); + if Moniker <> nil then begin + lenFileName := OleStdGetLenFilePrefixOfMoniker(Moniker); + ReleaseObject(Moniker); + end; + end; + if @pszFullLinkType <> nil then + pszFullLinkType := CoAllocCStr(GetFullNameStr(FReObject.poleobj)); + if @pszShortLinkType <> nil then + pszShortLinkType := CoAllocCStr(GetShortNameStr(FReObject.poleobj)); + Result := S_OK; +end; + +function TOleUILinkInfo.OpenLinkSource(dwLink: Longint): HResult; +begin + try + OleCheck(FReObject.poleobj.DoVerb(OLEIVERB_SHOW, nil, FReObject.polesite, + 0, FRichEdit.Handle, FRichEdit.ClientRect)); + except + Application.HandleException(FRichEdit); + end; + Result := S_OK; +end; + +function TOleUILinkInfo.UpdateLink(dwLink: Longint; fErrorMessage: BOOL; + fErrorAction: BOOL): HResult; +begin + try + OleCheck(FReObject.poleobj.Update); + except + Application.HandleException(FRichEdit); + end; + Result := S_OK; +end; + +function TOleUILinkInfo.CancelLink(dwLink: Longint): HResult; +begin + LinkError(SCannotBreakLink); + Result := E_NOTIMPL; +end; + +function TOleUILinkInfo.GetLastUpdate(dwLink: Longint; + var LastUpdate: TFileTime): HResult; +begin + Result := S_OK; +end; + +{ Get RichEdit OLE interface } + +function GetRichEditOle(Wnd: HWnd; var RichEditOle): Boolean; +begin + Result := SendMessage(Wnd, EM_GETOLEINTERFACE, 0, Longint(@RichEditOle)) <> 0; +end; + +{ TRichEditStrings } + +const + ReadError = $0001; + WriteError = $0002; + NoError = $0000; + +type + TRichEditStrings = class(TStrings) + private + RichEdit: TRxCustomRichEdit; + FFormat: TRichStreamFormat; + FMode: TRichStreamModes; + FConverter: TConversion; + procedure EnableChange(const Value: Boolean); + protected + function Get(Index: Integer): string; override; + function GetCount: Integer; override; + procedure Put(Index: Integer; const S: string); override; + procedure SetUpdateState(Updating: Boolean); override; + procedure SetTextStr(const Value: string); override; + public + destructor Destroy; override; + procedure Clear; override; + procedure AddStrings(Strings: TStrings); override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: string); override; + procedure LoadFromFile(const FileName: string); override; + procedure LoadFromStream(Stream: TStream); override; + procedure SaveToFile(const FileName: string); override; + procedure SaveToStream(Stream: TStream); override; + property Format: TRichStreamFormat read FFormat write FFormat; + property Mode: TRichStreamModes read FMode write FMode; + end; + +destructor TRichEditStrings.Destroy; +begin + FConverter.Free; + inherited Destroy; +end; + +procedure TRichEditStrings.AddStrings(Strings: TStrings); +var + SelChange: TNotifyEvent; +begin + SelChange := RichEdit.OnSelectionChange; + RichEdit.OnSelectionChange := nil; + try + inherited AddStrings(Strings); + finally + RichEdit.OnSelectionChange := SelChange; + end; +end; + +function TRichEditStrings.GetCount: Integer; +begin + with RichEdit do begin + Result := SendMessage(Handle, EM_GETLINECOUNT, 0, 0); + if GetLineLength(GetLineIndex(Result - 1)) = 0 then Dec(Result); + end; +end; + +function TRichEditStrings.Get(Index: Integer): string; +var + Text: array[0..4095] of Char; + L: Integer; +begin + Word((@Text)^) := SizeOf(Text); + L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text)); + if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2) + else if (RichEditVersion >= 2) and (Text[L - 1] = #13) then Dec(L); + SetString(Result, Text, L); +end; + +procedure TRichEditStrings.Put(Index: Integer; const S: string); +var + Selection: TCharRange; +begin + if Index >= 0 then + begin + Selection.cpMin := RichEdit.GetLineIndex(Index); + if Selection.cpMin <> -1 then begin + Selection.cpMax := Selection.cpMin + + RichEdit.GetLineLength(Selection.cpMin); + SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); + RichEdit.FLinesUpdating := True; + try + SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S))); + finally + RichEdit.FLinesUpdating := False; + end; + end; + end; +end; + +procedure TRichEditStrings.Insert(Index: Integer; const S: string); +var + L: Integer; + Selection: TCharRange; + Fmt: PChar; + Str: string; +begin + if Index >= 0 then begin + Selection.cpMin := RichEdit.GetLineIndex(Index); + if Selection.cpMin >= 0 then begin + if RichEditVersion = 1 then Fmt := '%s'#13#10 + else Fmt := '%s'#13; + end + else begin + Selection.cpMin := RichEdit.GetLineIndex(Index - 1); + if Selection.cpMin < 0 then Exit; + L := RichEdit.GetLineLength(Selection.cpMin); + if L = 0 then Exit; + Inc(Selection.cpMin, L); + if RichEditVersion = 1 then Fmt := #13#10'%s' + else Fmt := #13'%s'; + end; + Selection.cpMax := Selection.cpMin; + SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); + Str := SysUtils.Format(Fmt, [S]); + RichEdit.FLinesUpdating := True; + try + SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(Str))); + finally + RichEdit.FLinesUpdating := False; + end; + if RichEditVersion = 1 then + if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then + raise EOutOfResources.Create(ResStr(sRichEditInsertError)); + end; +end; + +procedure TRichEditStrings.Delete(Index: Integer); +const + Empty: PChar = ''; +var + Selection: TCharRange; +begin + if Index < 0 then Exit; + Selection.cpMin := RichEdit.GetLineIndex(Index); + if Selection.cpMin <> -1 then begin + Selection.cpMax := RichEdit.GetLineIndex(Index + 1); + if Selection.cpMax = -1 then + Selection.cpMax := Selection.cpMin + + RichEdit.GetLineLength(Selection.cpMin); + SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection)); + RichEdit.FLinesUpdating := True; + try + SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty)); + finally + RichEdit.FLinesUpdating := False; + end; + end; +end; + +procedure TRichEditStrings.Clear; +begin + RichEdit.Clear; +end; + +procedure TRichEditStrings.SetUpdateState(Updating: Boolean); +begin + if RichEdit.Showing then + SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0); + if not Updating then begin + RichEdit.Refresh; + RichEdit.Perform(CM_TEXTCHANGED, 0, 0); + end; +end; + +procedure TRichEditStrings.EnableChange(const Value: Boolean); +var + EventMask: Longint; +begin + with RichEdit do begin + EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0); + if Value then + EventMask := EventMask or ENM_CHANGE + else + EventMask := EventMask and not ENM_CHANGE; + SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask); + end; +end; + +procedure TRichEditStrings.SetTextStr(const Value: string); +begin + EnableChange(False); + try + inherited SetTextStr(Value); + finally + EnableChange(True); + end; +end; + +{$IFDEF Delphi12} +function AdjustLineBreaks(Dest: PByte; Source: TBytes; Start, Len: Integer): Integer; +var + P: PByte; + I: Integer; +begin + I := Start; // Position in Source + P := Dest; + while I < (Len - 1) do + begin + if (Source[I] = 10) and (Source[I + 1] = 0) then + begin + // Convert #10 to #13#10 + P^ := 13; + Inc(P); + P^ := 0; + Inc(P); + P^ := 10; + Inc(P); + P^ := 0; + Inc(P); + end + else + begin + P^ := Source[I]; + Inc(P); + P^ := Source[I + 1]; + Inc(P); + if (Source[I] = 13) and (Source[I + 1] = 0) then + begin + // Convert #13 to #13#10 + P^ := 10; + Inc(P); + P^ := 0; + Inc(P); + // Skip #10 if preceeded by #13 + if (Source[I + 2] = 10) and (Source[I + 3] = 0) then + Inc(I, 2); + end; + end; + Inc(I, 2); + end; + if I = Len - 1 then + begin + P^ := Source[I]; + Inc(P); + end; + Result := Integer(P) - Integer(Dest); +end; +{$ELSE} +function AdjustLineBreaks(Dest, Source: PAnsiChar): Integer; assembler; +asm + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,EDX + MOV EDX,EAX + CLD +@@1: LODSB +@@2: OR AL,AL + JE @@4 + CMP AL,0AH + JE @@3 + STOSB + CMP AL,0DH + JNE @@1 + MOV AL,0AH + STOSB + LODSB + CMP AL,0AH + JE @@1 + JMP @@2 +@@3: MOV EAX,0A0DH + STOSW + JMP @@1 +@@4: STOSB + LEA EAX,[EDI-1] + SUB EAX,EDX + POP EDI + POP ESI +end; +{$ENDIF} + +{$IFDEF Delphi12} +function StreamSave(dwCookie: Longint; pbBuff: PByte; + cb: Longint; var pcb: Longint): Longint; stdcall; +var + StreamInfo: TRichEditStreamInfo; + Buffer: TBytes; +begin + Result := NoError; + StreamInfo := PRichEditStreamInfo(dwCookie)^; + try + pcb := 0; + if StreamInfo.Converter <> nil then + begin + SetLength(Buffer, cb); + Move(pbBuff^, Buffer[0], cb); + pcb := StreamInfo.Converter.ConvertWriteStream(StreamInfo.Stream, Buffer, Length(Buffer)); + // Length(Buffer) may be different from 'cb' if we converted the char set + if (pcb <> cb) and (pcb = Length(Buffer)) then + pcb := cb; // Fake the number of bytes written + end; + except + Result := WriteError; + end; +end; +{$ELSE} +function StreamSave(dwCookie: Longint; pbBuff: PByte; + cb: Longint; var pcb: Longint): Longint; stdcall; +var + StreamInfo: PRichEditStreamInfo; +begin + Result := NoError; + StreamInfo := PRichEditStreamInfo(Pointer(dwCookie)); + try + pcb := 0; + if StreamInfo^.Converter <> nil then +{$IFDEF Delphi12} + pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, TBytes(pbBuff), cb); +{$ELSE} + pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, PChar(pbBuff), cb); +{$ENDIF} + except + Result := WriteError; + end; +end; +{$ENDIF} + +{$IFDEF Delphi12} +function StreamLoad(dwCookie: Longint; pbBuff: PByte; + cb: Longint; var pcb: Longint): Longint; stdcall; +var + Buffer: TBytes; + StreamInfo: PRichEditStreamInfo; +begin + Result := NoError; + StreamInfo := PRichEditStreamInfo(Pointer(dwCookie)); + SetLength(Buffer, cb + 1); + cb := cb div 2; + if (cb mod 2) > 0 then + cb := cb -1 ; + pcb := 0; + try + if StreamInfo^.Converter <> nil then + begin + pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, TBytes(Buffer), cb); + end; + if pcb > 0 then + begin + Buffer[pcb] := 0; + if Buffer[pcb - 1] = 13 then Buffer[pcb - 1] := 0; + pcb := AdjustLineBreaks(pbBuff, Buffer, 0, pcb); + end; + except + Result := ReadError; + end; +end; +{$ELSE} +function StreamLoad(dwCookie: Longint; pbBuff: PByte; + cb: Longint; var pcb: Longint): Longint; stdcall; +var + Buffer, pBuff: PChar; + StreamInfo: PRichEditStreamInfo; +begin + Result := NoError; + StreamInfo := PRichEditStreamInfo(Pointer(dwCookie)); + Buffer := StrAlloc(cb + 1); + try + cb := cb div 2; + pcb := 0; + pBuff := Buffer + cb; + try + if StreamInfo^.Converter <> nil then + pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, Pchar(pBuff), cb); + if pcb > 0 then + begin + pBuff[pcb] := #0; + if pBuff[pcb - 1] = #13 then pBuff[pcb - 1] := #0; + pcb := AdjustLineBreaks(Buffer, pBuff); + Move(Buffer^, pbBuff^, pcb); + end; + except + Result := ReadError; + end; + finally + StrDispose(Buffer); + end; +end; +{$ENDIF} + +procedure TRichEditStrings.LoadFromStream(Stream: TStream); +var + EditStream: TEditStream; + Position: Longint; + TextType: Longint; + StreamInfo: TRichEditStreamInfo; + Converter: TConversion; +begin + StreamInfo.Stream := Stream; + if FConverter <> nil then Converter := FConverter + else Converter := RichEdit.DefaultConverter.Create; + StreamInfo.Converter := Converter; +{$IFDEF Delphi12} + StreamInfo.PlainText := True; + StreamInfo.Encoding := nil; +{$ENDIF} + try + with EditStream do + begin + dwCookie := Longint(Pointer(@StreamInfo)); + pfnCallBack := @StreamLoad; + dwError := 0; + end; + Position := Stream.Position; + case FFormat of + sfDefault: + if RichEdit.PlainText then TextType := SF_TEXT + else TextType := SF_RTF; + sfRichText: TextType := SF_RTF; + else {sfPlainText} TextType := SF_TEXT; + end; + if TextType = SF_RTF then begin + if smPlainRtf in Mode then TextType := TextType or SFF_PLAINRTF; + end; + if TextType = SF_TEXT then begin + if (smUnicode in Mode) and (RichEditVersion > 1) then + TextType := TextType or SF_UNICODE; + end; + if smSelection in Mode then TextType := TextType or SFF_SELECTION; + SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream)); + if (EditStream.dwError <> 0) then begin + Stream.Position := Position; + if (TextType and SF_RTF = SF_RTF) then TextType := SF_TEXT + else TextType := SF_RTF; + SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream)); + if EditStream.dwError <> 0 then + raise EOutOfResources.Create(ResStr(sRichEditLoadFail)); + end; + RichEdit.SetSelection(0, 0, True); + finally + if FConverter = nil then Converter.Free; + end; +end; + +procedure TRichEditStrings.SaveToStream(Stream: TStream); +var + EditStream: TEditStream; + TextType: Longint; + StreamInfo: TRichEditStreamInfo; + Converter: TConversion; +begin + if FConverter <> nil then Converter := FConverter + else Converter := RichEdit.DefaultConverter.Create; + StreamInfo.Stream := Stream; + StreamInfo.Converter := Converter; +{$IFDEF Delphi12} + StreamInfo.PlainText := True; + StreamInfo.Encoding := nil; +{$ENDIF} + + try + with EditStream do + begin + dwCookie := Longint(Pointer(@StreamInfo)); + pfnCallBack := @StreamSave; + dwError := 0; + end; + case FFormat of + sfDefault: + if RichEdit.PlainText then TextType := SF_TEXT + else TextType := SF_RTF; + sfRichText: TextType := SF_RTF; + else {sfPlainText} TextType := SF_TEXT; + end; + if TextType = SF_RTF then begin + if smNoObjects in Mode then TextType := SF_RTFNOOBJS; + if smPlainRtf in Mode then TextType := TextType or SFF_PLAINRTF; + end + else if TextType = SF_TEXT then begin + if (smUnicode in Mode) and (RichEditVersion > 1) then + TextType := TextType or SF_UNICODE; + end; + if smSelection in Mode then TextType := TextType or SFF_SELECTION; + SendMessage(RichEdit.Handle, EM_STREAMOUT, TextType, Longint(@EditStream)); + if EditStream.dwError <> 0 then + raise EOutOfResources.Create(ResStr(sRichEditSaveFail)); + finally + if FConverter = nil then Converter.Free; + end; +end; + +procedure TRichEditStrings.LoadFromFile(const FileName: string); +var + Ext: string; + Convert: PRichConversionFormat; + SaveFormat: TRichStreamFormat; +begin + Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename)); + System.Delete(Ext, 1, 1); + Convert := ConversionFormatList; + while Convert <> nil do + with Convert^ do + if Extension <> Ext then Convert := Next + else Break; + if (FConverter = nil) and (Convert <> nil) then + FConverter := Convert^.ConversionClass.Create; + try + SaveFormat := Format; + try + if Convert <> nil then begin + if Convert^.PlainText then FFormat := sfPlainText + else FFormat := sfRichText; + end; + inherited LoadFromFile(FileName); + finally + FFormat := SaveFormat; + end; + except + FConverter.Free; + FConverter := nil; + raise; + end; +end; + +procedure TRichEditStrings.SaveToFile(const FileName: string); +var + Ext: string; + Convert: PRichConversionFormat; + SaveFormat: TRichStreamFormat; +begin + Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename)); + System.Delete(Ext, 1, 1); + Convert := ConversionFormatList; + while Convert <> nil do + with Convert^ do + if Extension <> Ext then Convert := Next + else Break; + if (FConverter = nil) and (Convert <> nil) then + FConverter := Convert^.ConversionClass.Create; + try + SaveFormat := Format; + try + if Convert <> nil then begin + if Convert^.PlainText then FFormat := sfPlainText + else FFormat := sfRichText; + end; + inherited SaveToFile(FileName); + finally + FFormat := SaveFormat; + end; + except + FConverter.Free; + FConverter := nil; + raise; + end; +end; + +{ TOEMConversion } + +{$IFDEF Delphi12} +function TOEMConversion.ConvertReadStream(Stream: TStream; Buffer: TBytes; + BufSize: Integer): Integer; +{$ELSE} +function TOEMConversion.ConvertReadStream(Stream: TStream; Buffer: PChar; + BufSize: Integer): Integer; +{$ENDIF} +var + Mem: TMemoryStream; +begin + Mem := TMemoryStream.Create; + try + Mem.SetSize(BufSize); +{$IFDEF Delphi12} + Result := inherited ConvertReadStream(Stream, TBytes(Mem.Memory), BufSize); +{$ELSE} + Result := inherited ConvertReadStream(Stream, PChar(Mem.Memory), BufSize); +{$ENDIF} + + OemToCharBuffA(PAnsiChar(Mem.Memory), PAnsiChar(Buffer), Result); + finally + Mem.Free; + end; +end; + +{$IFDEF Delphi12} +function TOEMConversion.ConvertWriteStream(Stream: TStream; Buffer: TBytes; + BufSize: Integer): Integer; +{$ELSE} +function TOEMConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; + BufSize: Integer): Integer; +{$ENDIF} +var + Mem: TMemoryStream; +begin + Mem := TMemoryStream.Create; + try + Mem.SetSize(BufSize); + CharToOemBuffA(PAnsiChar(Buffer), PAnsiChar(Mem.Memory), BufSize); +{$IFDEF Delphi12} + Result := inherited ConvertWriteStream(Stream, TBytes(Mem.Memory), BufSize); +{$ELSE} + Result := inherited ConvertWriteStream(Stream, PChar(Mem.Memory), BufSize); +{$ENDIF} + finally + Mem.Free; + end; +end; + +{ TRxCustomRichEdit } + +constructor TRxCustomRichEdit.Create(AOwner: TComponent); +var + DC: HDC; +begin + inherited Create(AOwner); + ControlStyle := ControlStyle - [csSetCaption]; + FSelAttributes := TRxTextAttributes.Create(Self, atSelected); + FDefAttributes := TRxTextAttributes.Create(Self, atDefaultText); + FWordAttributes := TRxTextAttributes.Create(Self, atWord); + FParagraph := TRxParaAttributes.Create(Self); + FRichEditStrings := TRichEditStrings.Create; + TRichEditStrings(FRichEditStrings).RichEdit := Self; + TabStop := True; + Width := 185; + Height := 89; + AutoSize := False; + DoubleBuffered := False; + FAllowObjects := True; + FAllowInPlace := True; + FAutoVerbMenu := True; + FHideSelection := True; + FHideScrollBars := True; + ScrollBars := ssBoth; + FSelectionBar := True; + FLangOptions := [rlAutoFont]; + DC := GetDC(0); + FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY); + ReleaseDC(0, DC); + DefaultConverter := TConversion; + FOldParaAlignment := TParaAlignment(Alignment); + FUndoLimit := 100; + FAutoURLDetect := True; + FWordSelection := True; + with FClickRange do begin + cpMin := -1; + cpMax := -1; + end; + FCallback := TRichEditOleCallback.Create(Self); + Perform(CM_PARENTBIDIMODECHANGED, 0, 0); +end; + +destructor TRxCustomRichEdit.Destroy; +begin + FLastFind := nil; + FSelAttributes.Free; + FDefAttributes.Free; + FWordAttributes.Free; + FParagraph.Free; + FRichEditStrings.Free; + FMemStream.Free; + FPopupVerbMenu.Free; + FFindDialog.Free; + FReplaceDialog.Free; + inherited Destroy; + { be sure that callback object is destroyed after inherited Destroy } + TRichEditOleCallback(FCallback).Free; +end; + +procedure TRxCustomRichEdit.Clear; +begin + CloseObjects; + inherited Clear; + Modified := False; +end; + +procedure TRxCustomRichEdit.CreateParams(var Params: TCreateParams); +const + HideScrollBars: array[Boolean] of DWORD = (ES_DISABLENOSCROLL, 0); + HideSelections: array[Boolean] of DWORD = (ES_NOHIDESEL, 0); + WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL); + SelectionBars: array[Boolean] of DWORD = (0, ES_SELECTIONBAR); +begin + inherited CreateParams(Params); + case RichEditVersion of + 1: CreateSubClass(Params, RICHEDIT_CLASS10A); + 4: CreateSubClass(Params, MSFTEDIT_CLASS); + else CreateSubClass(Params, RICHEDIT_CLASS); + end; + with Params do begin + Style := (Style and not (WS_HSCROLL or WS_VSCROLL)) or ES_SAVESEL or + (WS_CLIPSIBLINGS or WS_CLIPCHILDREN); + { NOTE: WS_CLIPCHILDREN and WS_CLIPSIBLINGS are essential otherwise } + { once the object is inserted you see some painting problems. } + Style := Style and not (WS_HSCROLL or WS_VSCROLL); + if ScrollBars in [ssVertical, ssBoth] then + Style := Style or WS_VSCROLL; + if (ScrollBars in [ssHorizontal, ssBoth]) and not WordWrap then + Style := Style or WS_HSCROLL; + Style := Style or HideScrollBars[FHideScrollBars] or + SelectionBars[FSelectionBar] or HideSelections[FHideSelection] and + not WordWraps[WordWrap]; + WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); + end; +end; + +procedure TRxCustomRichEdit.CreateWnd; +var + StreamFmt: TRichStreamFormat; + Mode: TRichStreamModes; + DesignMode: Boolean; + Mask: Longint; +begin + StreamFmt := TRichEditStrings(Lines).Format; + Mode := TRichEditStrings(Lines).Mode; + inherited CreateWnd; + if (SysLocale.FarEast) and not (SysLocale.PriLangID = LANG_JAPANESE) then + Font.Charset := GetDefFontCharSet; + Mask := ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED; + if RichEditVersion >= 2 then Mask := Mask or ENM_LINK; + SendMessage(Handle, EM_SETEVENTMASK, 0, Mask); + SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color)); + DoSetMaxLength(MaxLength); + SetWordSelection(FWordSelection); + if RichEditVersion >= 2 then begin + SendMessage(Handle, EM_AUTOURLDETECT, Longint(FAutoURLDetect), 0); + SendMessage(Handle, EM_SETTYPOGRAPHYOPTIONS, TO_ADVANCEDTYPOGRAPHY, TO_ADVANCEDTYPOGRAPHY); + FUndoLimit := SendMessage(Handle, EM_SETUNDOLIMIT, FUndoLimit, 0); + UpdateTextModes(PlainText); + SetLangOptions(FLangOptions); + end; + if FAllowObjects then begin + SendMessage(Handle, EM_SETOLECALLBACK, 0, + LPARAM(TRichEditOleCallback(FCallback) as IRichEditOleCallback)); + GetRichEditOle(Handle, FRichEditOle); + UpdateHostNames; + end; + if FMemStream <> nil then begin + FMemStream.ReadBuffer(DesignMode, SizeOf(DesignMode)); + if DesignMode then begin + TRichEditStrings(Lines).Format := sfPlainText; + TRichEditStrings(Lines).Mode := []; + end; + try + Lines.LoadFromStream(FMemStream); + FMemStream.Free; + FMemStream := nil; + finally + TRichEditStrings(Lines).Format := StreamFmt; + TRichEditStrings(Lines).Mode := Mode; + end; + end; + if RichEditVersion < 2 then + SendMessage(Handle, WM_SETFONT, 0, 0); + Modified := FModified; +end; + +procedure TRxCustomRichEdit.DestroyWnd; +var + StreamFmt: TRichStreamFormat; + Mode: TRichStreamModes; + DesignMode: Boolean; +begin + FModified := Modified; + FMemStream := TMemoryStream.Create; + StreamFmt := TRichEditStrings(Lines).Format; + Mode := TRichEditStrings(Lines).Mode; + DesignMode := (csDesigning in ComponentState); + FMemStream.WriteBuffer(DesignMode, SizeOf(DesignMode)); + if DesignMode then begin + TRichEditStrings(Lines).Format := sfPlainText; + TRichEditStrings(Lines).Mode := []; + end; + try + Lines.SaveToStream(FMemStream); + FMemStream.Position := 0; + finally + TRichEditStrings(Lines).Format := StreamFmt; + TRichEditStrings(Lines).Mode := Mode; + end; + inherited DestroyWnd; +end; + +procedure TRxCustomRichEdit.SetAllowObjects(Value: Boolean); +begin + if FAllowObjects <> Value then begin + FAllowObjects := Value; + RecreateWnd; + end; +end; + +procedure TRxCustomRichEdit.UpdateHostNames; +var + AppName: string; +begin + if HandleAllocated and Assigned(FRichEditOle) then begin + AppName := Application.Title; + if Trim(AppName) = '' then + AppName := ExtractFileName(Application.ExeName); + if Trim(Title) = '' then + IRichEditOle(FRichEditOle).SetHostNames(PAnsiChar(AnsiString(AppName)), PAnsiChar(AnsiString(AppName))) + else + IRichEditOle(FRichEditOle).SetHostNames(PAnsiChar(AnsiString(AppName)), PAnsiChar(AnsiString(Title))); + end; +end; + +procedure TRxCustomRichEdit.SetTitle(const Value: string); +begin + if FTitle <> Value then begin + FTitle := Value; + UpdateHostNames; + end; +end; + +function TRxCustomRichEdit.GetPopupMenu: TPopupMenu; +var + EnumOleVerb: IEnumOleVerb; + OleVerb: TOleVerb; + Item: TMenuItem; + ReObject: TReObject; +begin + FPopupVerbMenu.Free; + FPopupVerbMenu := nil; + Result := inherited GetPopupMenu; + if FAutoVerbMenu and (SelectionType = [stObject]) and + Assigned(FRichEditOle) then + begin + FillChar(ReObject, SizeOf(ReObject), 0); + ReObject.cbStruct := SizeOf(ReObject); + if Succeeded(IRichEditOle(FRichEditOle).GetObject( + Longint(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ)) then + try + if Assigned(ReObject.poleobj) and + (ReObject.dwFlags and REO_INPLACEACTIVE = 0) then + begin + FPopupVerbMenu := TPopupMenu.Create(Self); + if ReObject.poleobj.EnumVerbs(EnumOleVerb) = 0 then + try + while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and + (OleVerb.lVerb >= 0) and + (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do + begin + Item := TMenuItem.Create(FPopupVerbMenu); + Item.Caption := WideCharToString(OleVerb.lpszVerbName); + Item.Tag := OleVerb.lVerb; + Item.Default := (OleVerb.lVerb = OLEIVERB_PRIMARY); + Item.OnClick := PopupVerbClick; + FPopupVerbMenu.Items.Add(Item); + end; + finally + ReleaseObject(EnumOleVerb); + end; + if (Result <> nil) and (Result.Items.Count > 0) then begin + Item := TMenuItem.Create(FPopupVerbMenu); + Item.Caption := '-'; + Result.Items.Add(Item); + Item := TMenuItem.Create(FPopupVerbMenu); + Item.Caption := Format(ResStr(SPropDlgCaption), + [GetFullNameStr(ReObject.poleobj)]); + Item.OnClick := ObjectPropsClick; + Result.Items.Add(Item); + if FPopupVerbMenu.Items.Count > 0 then begin + FPopupVerbMenu.Items.Caption := GetFullNameStr(ReObject.poleobj); + Result.Items.Add(FPopupVerbMenu.Items); + end; + end + else if FPopupVerbMenu.Items.Count > 0 then begin + Item := TMenuItem.Create(FPopupVerbMenu); + Item.Caption := Format(ResStr(SPropDlgCaption), + [GetFullNameStr(ReObject.poleobj)]); + Item.OnClick := ObjectPropsClick; + FPopupVerbMenu.Items.Insert(0, Item); + Result := FPopupVerbMenu; + end; + end; + finally + ReleaseObject(ReObject.poleobj); + end; + end; +end; + +procedure TRxCustomRichEdit.PopupVerbClick(Sender: TObject); +var + ReObject: TReObject; +begin + if Assigned(FRichEditOle) then begin + FillChar(ReObject, SizeOf(ReObject), 0); + ReObject.cbStruct := SizeOf(ReObject); + if Succeeded(IRichEditOle(FRichEditOle).GetObject( + Longint(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ or + REO_GETOBJ_POLESITE)) then + try + if ReObject.dwFlags and REO_INPLACEACTIVE = 0 then + OleCheck(ReObject.poleobj.DoVerb((Sender as TMenuItem).Tag, nil, + ReObject.polesite, 0, Handle, ClientRect)); + finally + ReleaseObject(ReObject.polesite); + ReleaseObject(ReObject.poleobj); + end; + end; +end; + +procedure TRxCustomRichEdit.ObjectPropsClick(Sender: TObject); +begin + ObjectPropertiesDialog; +end; + +procedure TRxCustomRichEdit.WMSetFont(var Message: TWMSetFont); +begin + FDefAttributes.Assign(Font); +end; + +procedure TRxCustomRichEdit.CMFontChanged(var Message: TMessage); +begin + inherited; + FDefAttributes.Assign(Font); +end; + +procedure TRxCustomRichEdit.CreateWindowHandle(const Params: TCreateParams); +var + Bounds: TRect; +begin + Bounds := BoundsRect; + inherited CreateWindowHandle(Params); + if HandleAllocated then BoundsRect := Bounds; +end; + +procedure TRxCustomRichEdit.DoSetMaxLength(Value: Integer); +begin + { The rich edit control's default maximum amount of text is 32K } + { Let's set it at 16M by default } + if Value = 0 then Value := $FFFFFF; + SendMessage(Handle, EM_EXLIMITTEXT, 0, Value); +end; + +function TRxCustomRichEdit.GetCaretPos: TPoint; +var + CharRange: TCharRange; +begin + SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); + Result.X := CharRange.cpMax; + Result.Y := LineFromChar(Result.X); + Dec(Result.X, GetLineIndex(-1)); +end; + +function TRxCustomRichEdit.GetSelLength: Integer; +begin + with GetSelection do + Result := cpMax - cpMin; +end; + +function TRxCustomRichEdit.GetSelStart: Integer; +begin + Result := GetSelection.cpMin; +end; + +function TRxCustomRichEdit.GetSelText: string; +begin + with GetSelection do + Result := GetTextRange(cpMin, cpMax); +end; + +function TRxCustomRichEdit.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; +var + S: string; +begin + S := SelText; + Result := Length(S); + if BufSize < Length(S) then Result := BufSize; + StrPLCopy(Buffer, S, Result); +end; + +procedure TRxCustomRichEdit.CMBiDiModeChanged(var Message: TMessage); +var + AParagraph: TParaFormat2; +begin + HandleNeeded; { we REALLY need the handle for BiDi } + inherited; + Paragraph.GetAttributes(AParagraph); + AParagraph.dwMask := PFM_ALIGNMENT; + AParagraph.wAlignment := Ord(Alignment) + 1; + Paragraph.SetAttributes(AParagraph); +end; + +procedure TRxCustomRichEdit.SetHideScrollBars(Value: Boolean); +begin + if HideScrollBars <> Value then begin + FHideScrollBars := Value; + RecreateWnd; + end; +end; + +procedure TRxCustomRichEdit.SetSelectionBar(Value: Boolean); +begin + if FSelectionBar <> Value then begin + FSelectionBar := Value; + RecreateWnd; + end; +end; + +procedure TRxCustomRichEdit.SetHideSelection(Value: Boolean); +begin + if HideSelection <> Value then begin + FHideSelection := Value; + SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LPARAM(True)); + end; +end; + +function TRxCustomRichEdit.GetAutoURLDetect: Boolean; +begin + Result := FAutoURLDetect; + if HandleAllocated and not (csDesigning in ComponentState) then begin + if RichEditVersion >= 2 then + Result := Boolean(SendMessage(Handle, EM_GETAUTOURLDETECT, 0, 0)); + end; +end; + +procedure TRxCustomRichEdit.SetAutoURLDetect(Value: Boolean); +begin + if Value <> FAutoURLDetect then begin + FAutoURLDetect := Value; + if HandleAllocated and (RichEditVersion >= 2) then + SendMessage(Handle, EM_AUTOURLDETECT, Longint(FAutoURLDetect), 0); + end; +end; + +function TRxCustomRichEdit.GetWordSelection: Boolean; +begin + Result := FWordSelection; + if HandleAllocated then + Result := (SendMessage(Handle, EM_GETOPTIONS, 0, 0) and + ECO_AUTOWORDSELECTION) <> 0; +end; + +procedure TRxCustomRichEdit.SetWordSelection(Value: Boolean); +var + Options: LPARAM; +begin + FWordSelection := Value; + if HandleAllocated then begin + Options := SendMessage(Handle, EM_GETOPTIONS, 0, 0); + if Value then Options := Options or ECO_AUTOWORDSELECTION + else Options := Options and not ECO_AUTOWORDSELECTION; + SendMessage(Handle, EM_SETOPTIONS, ECOOP_SET, Options); + end; +end; + +const + RichLangOptions: array[TRichLangOption] of DWORD = (IMF_AUTOKEYBOARD, + IMF_AUTOFONT, IMF_IMECANCELCOMPLETE, IMF_IMEALWAYSSENDNOTIFY); + +function TRxCustomRichEdit.GetLangOptions: TRichLangOptions; +var + Flags: Longint; + I: TRichLangOption; +begin + Result := FLangOptions; + if HandleAllocated and not (csDesigning in ComponentState) and + (RichEditVersion >= 2) then + begin + Result := []; + Flags := SendMessage(Handle, EM_GETLANGOPTIONS, 0, 0); + for I := Low(TRichLangOption) to High(TRichLangOption) do + if Flags and RichLangOptions[I] <> 0 then Include(Result, I); + end; +end; + +procedure TRxCustomRichEdit.SetLangOptions(Value: TRichLangOptions); +var + Flags: DWORD; + I: TRichLangOption; +begin + FLangOptions := Value; + if HandleAllocated and (RichEditVersion >= 2) then begin + Flags := 0; + for I := Low(TRichLangOption) to High(TRichLangOption) do + if I in Value then Flags := Flags or RichLangOptions[I]; + SendMessage(Handle, EM_SETLANGOPTIONS, 0, LPARAM(Flags)); + end; +end; + +procedure TRxCustomRichEdit.SetSelAttributes(Value: TRxTextAttributes); +begin + FSelAttributes.Assign(Value); +end; + +function TRxCustomRichEdit.GetCanRedo: Boolean; +begin + Result := False; + if HandleAllocated and (RichEditVersion >= 2) then + Result := SendMessage(Handle, EM_CANREDO, 0, 0) <> 0; +end; + +function TRxCustomRichEdit.GetCanPaste: Boolean; +begin + Result := False; + if HandleAllocated then + Result := SendMessage(Handle, EM_CANPASTE, 0, 0) <> 0; +end; + +function TRxCustomRichEdit.GetRedoName: TUndoName; +begin + Result := unUnknown; + if (RichEditVersion >= 2) and HandleAllocated then + Result := TUndoName(SendMessage(Handle, EM_GETREDONAME, 0, 0)); +end; + +function TRxCustomRichEdit.GetUndoName: TUndoName; +begin + Result := unUnknown; + if (RichEditVersion >= 2) and HandleAllocated then + Result := TUndoName(SendMessage(Handle, EM_GETUNDONAME, 0, 0)); +end; + +function TRxCustomRichEdit.GetSelectionType: TRichSelectionType; +const + SelTypes: array[TRichSelection] of Integer = ( + SEL_TEXT, SEL_OBJECT, SEL_MULTICHAR, SEL_MULTIOBJECT); +var + Selection: Integer; + I: TRichSelection; +begin + Result := []; + if HandleAllocated then begin + Selection := SendMessage(Handle, EM_SELECTIONTYPE, 0, 0); + for I := Low(TRichSelection) to High(TRichSelection) do + if SelTypes[I] and Selection <> 0 then Include(Result, I); + end; +end; + +function TRxCustomRichEdit.GetSelection: TCharRange; +begin + SendMessage(Handle, EM_EXGETSEL, 0, Longint(@Result)); +end; + +procedure TRxCustomRichEdit.SetSelection(StartPos, EndPos: Longint; + ScrollCaret: Boolean); +var + CharRange: TCharRange; +begin + with CharRange do begin + cpMin := StartPos; + cpMax := EndPos; + end; + SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange)); + if ScrollCaret then SendMessage(Handle, EM_SCROLLCARET, 0, 0); +end; + +procedure TRxCustomRichEdit.SetSelLength(Value: Integer); +begin + with GetSelection do SetSelection(cpMin, cpMin + Value, True); +end; + +procedure TRxCustomRichEdit.SetSelStart(Value: Integer); +begin + SetSelection(Value, Value, False); +end; + +function TRxCustomRichEdit.GetCharPos(CharIndex: Integer): TPoint; +var + Res: Longint; +begin + FillChar(Result, SizeOf(Result), 0); + if HandleAllocated then begin + if RichEditVersion = 2 then begin + Res := SendMessage(Handle, Messages.EM_POSFROMCHAR, CharIndex, 0); + Result.X := LoWord(Res); + Result.Y := HiWord(Res); + end + else { RichEdit 1.0 and 3.0 } + SendMessage(Handle, Messages.EM_POSFROMCHAR, WPARAM(@Result), CharIndex); + end; +end; + +function TRxCustomRichEdit.GetTextRange(StartPos, EndPos: Longint): string; +var + TextRange: TTextRange; +begin + SetLength(Result, EndPos - StartPos + 1); + TextRange.chrg.cpMin := StartPos; + TextRange.chrg.cpMax := EndPos; + TextRange.lpstrText := PChar(Result); + SetLength(Result, SendMessage(Handle, EM_GETTEXTRANGE, 0, Longint(@TextRange))); +end; + +function TRxCustomRichEdit.WordAtCursor: string; +var + Range: TCharRange; +begin + Result := ''; + if HandleAllocated then begin + Range.cpMax := SelStart; + if Range.cpMax = 0 then Range.cpMin := 0 + else if SendMessage(Handle, EM_FINDWORDBREAK, WB_ISDELIMITER, Range.cpMax) <> 0 then + Range.cpMin := SendMessage(Handle, EM_FINDWORDBREAK, WB_MOVEWORDLEFT, Range.cpMax) + else + Range.cpMin := SendMessage(Handle, EM_FINDWORDBREAK, WB_LEFT, Range.cpMax); + while SendMessage(Handle, EM_FINDWORDBREAK, WB_ISDELIMITER, Range.cpMin) <> 0 do + Inc(Range.cpMin); + Range.cpMax := SendMessage(Handle, EM_FINDWORDBREAK, WB_RIGHTBREAK, Range.cpMax); + Result := Trim(GetTextRange(Range.cpMin, Range.cpMax)); + end; +end; + +function TRxCustomRichEdit.LineFromChar(CharIndex: Integer): Integer; +begin + Result := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, CharIndex); +end; + +function TRxCustomRichEdit.GetLineIndex(LineNo: Integer): Integer; +begin + Result := SendMessage(Handle, EM_LINEINDEX, LineNo, 0); +end; + +function TRxCustomRichEdit.GetLineLength(CharIndex: Integer): Integer; +begin + Result := SendMessage(Handle, EM_LINELENGTH, CharIndex, 0); +end; + +procedure TRxCustomRichEdit.SetUndoLimit(Value: Integer); +begin + if (Value <> FUndoLimit) then begin + FUndoLimit := Value; + if (RichEditVersion >= 2) and HandleAllocated then + FUndoLimit := SendMessage(Handle, EM_SETUNDOLIMIT, Value, 0); + end; +end; + +procedure TRxCustomRichEdit.SetDefAttributes(Value: TRxTextAttributes); +begin + FDefAttributes.Assign(Value); +end; + +procedure TRxCustomRichEdit.SetWordAttributes(Value: TRxTextAttributes); +begin + FWordAttributes.Assign(Value); +end; + +function TRxCustomRichEdit.GetStreamFormat: TRichStreamFormat; +begin + Result := TRichEditStrings(Lines).Format; +end; + +function TRxCustomRichEdit.GetStreamMode: TRichStreamModes; +begin + Result := TRichEditStrings(Lines).Mode; +end; + +procedure TRxCustomRichEdit.SetStreamFormat(Value: TRichStreamFormat); +begin + TRichEditStrings(Lines).Format := Value; +end; + +procedure TRxCustomRichEdit.SetStreamMode(Value: TRichStreamModes); +begin + TRichEditStrings(Lines).Mode := Value; +end; + +procedure TRxCustomRichEdit.SetPlainText(Value: Boolean); +var + MemStream: TStream; + StreamFmt: TRichStreamFormat; + Mode: TRichStreamModes; +begin + if PlainText <> Value then begin + if HandleAllocated and (RichEditVersion >= 2) then begin + MemStream := TMemoryStream.Create; + try + StreamFmt := TRichEditStrings(Lines).Format; + Mode := TRichEditStrings(Lines).Mode; + try + if (csDesigning in ComponentState) or Value then + TRichEditStrings(Lines).Format := sfPlainText + else TRichEditStrings(Lines).Format := sfRichText; + TRichEditStrings(Lines).Mode := []; + Lines.SaveToStream(MemStream); + MemStream.Position := 0; + TRichEditStrings(Lines).EnableChange(False); + try + SendMessage(Handle, WM_SETTEXT, 0, 0); + UpdateTextModes(Value); + FPlainText := Value; + finally + TRichEditStrings(Lines).EnableChange(True); + end; + Lines.LoadFromStream(MemStream); + finally + TRichEditStrings(Lines).Format := StreamFmt; + TRichEditStrings(Lines).Mode := Mode; + end; + finally + MemStream.Free; + end; + end; + FPlainText := Value; + end; +end; + +procedure TRxCustomRichEdit.UpdateTextModes(Plain: Boolean); +const + TextModes: array[Boolean] of DWORD = (TM_RICHTEXT, TM_PLAINTEXT); + UndoModes: array[Boolean] of DWORD = (TM_SINGLELEVELUNDO, TM_MULTILEVELUNDO); +begin + if (RichEditVersion >= 2) and HandleAllocated then begin + SendMessage(Handle, EM_SETTEXTMODE, TextModes[Plain] or + UndoModes[FUndoLimit > 1], 0); + end; +end; + +procedure TRxCustomRichEdit.CMColorChanged(var Message: TMessage); +begin + inherited; + SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color)) +end; + +procedure TRxCustomRichEdit.EMReplaceSel(var Message: TMessage); +var + CharRange: TCharRange; +begin + Perform(EM_EXGETSEL, 0, Longint(@CharRange)); + with CharRange do + cpMax := cpMin + Integer(StrLen(PChar(Message.lParam))); + if (FUndoLimit > 1) and (RichEditVersion >= 2) and not FLinesUpdating then + Message.wParam := 1; { allow Undo } + inherited; + if not FLinesUpdating then begin + Perform(EM_EXSETSEL, 0, Longint(@CharRange)); + Perform(EM_SCROLLCARET, 0, 0); + end; +end; + +procedure TRxCustomRichEdit.SetRichEditStrings(Value: TStrings); +begin + FRichEditStrings.Assign(Value); +end; + +procedure TRxCustomRichEdit.CloseObjects; +var + I: Integer; + ReObject: TReObject; +begin + if Assigned(FRichEditOle) then begin + FillChar(ReObject, SizeOf(ReObject), 0); + ReObject.cbStruct := SizeOf(ReObject); + with IRichEditOle(FRichEditOle) do begin + for I := GetObjectCount - 1 downto 0 do + if Succeeded(GetObject(I, ReObject, REO_GETOBJ_POLEOBJ)) then begin + if ReObject.dwFlags and REO_INPLACEACTIVE <> 0 then + IRichEditOle(FRichEditOle).InPlaceDeactivate; + ReObject.poleobj.Close(OLECLOSE_NOSAVE); + ReleaseObject(ReObject.poleobj); + end; + end; + end; +end; + +function TRxCustomRichEdit.PasteSpecialDialog: Boolean; + + procedure SetPasteEntry(var Entry: TOleUIPasteEntry; Format: TClipFormat; + tymed: DWORD; const FormatName, ResultText: string; Flags: DWORD); + begin + with Entry do begin + fmtetc.cfFormat := Format; + fmtetc.dwAspect := DVASPECT_CONTENT; + fmtetc.lIndex := -1; + fmtetc.tymed := tymed; + if FormatName <> '' then lpstrFormatName := PChar(FormatName) + else lpstrFormatName := '%s'; + if ResultText <> '' then lpstrResultText := PChar(ResultText) + else lpstrResultText := '%s'; + dwFlags := Flags; + end; + end; + +const + PasteFormatCount = 6; +var + Data: TOleUIPasteSpecial; + PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry; + Format: Integer; + OleClientSite: IOleClientSite; + Storage: IStorage; + OleObject: IOleObject; + ReObject: TReObject; + Selection: TCharRange; +begin + Result := False; + if not CanPaste or not Assigned(FRichEditOle) then Exit; + FillChar(Data, SizeOf(Data), 0); + FillChar(PasteFormats, SizeOf(PasteFormats), 0); + with Data do begin + cbStruct := SizeOf(Data); + hWndOwner := Handle; + arrPasteEntries := @PasteFormats; + cPasteEntries := PasteFormatCount; + arrLinkTypes := @CFLinkSource; + cLinkTypes := 1; + dwFlags := PSF_SELECTPASTE; + end; + SetPasteEntry(PasteFormats[0], CFEmbeddedObject, TYMED_ISTORAGE, '', '', + OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON); + SetPasteEntry(PasteFormats[1], CFLinkSource, TYMED_ISTREAM, '', '', + OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON); + SetPasteEntry(PasteFormats[2], CFRtf, TYMED_ISTORAGE, + CF_RTF, CF_RTF, OLEUIPASTE_PASTE); + SetPasteEntry(PasteFormats[3], CFRtfNoObjs, TYMED_ISTORAGE, + CF_RTFNOOBJS, CF_RTFNOOBJS, OLEUIPASTE_PASTE); + SetPasteEntry(PasteFormats[4], CF_TEXT, TYMED_HGLOBAL, + 'Unformatted text', 'text without any formatting', OLEUIPASTE_PASTE); + SetPasteEntry(PasteFormats[5], CF_BITMAP, TYMED_GDI, + 'Windows Bitmap', 'bitmap image', OLEUIPASTE_PASTE); + try + if OleUIPasteSpecial(Data) = OLEUI_OK then begin + Result := True; + if Data.nSelectedIndex in [0, 1] then begin + { CFEmbeddedObject, CFLinkSource } + FillChar(ReObject, SizeOf(TReObject), 0); + IRichEditOle(FRichEditOle).GetClientSite(OleClientSite); + Storage := nil; + try + CreateStorage(Storage); + case Data.nSelectedIndex of + 0: OleCheck(OleCreateFromData(Data.lpSrcDataObj, IOleObject, + OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject)); + 1: OleCheck(OleCreateLinkFromData(Data.lpSrcDataObj, IOleObject, + OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject)); + end; + try + with ReObject do begin + cbStruct := SizeOf(TReObject); + cp := REO_CP_SELECTION; + poleobj := OleObject; + OleObject.GetUserClassID(clsid); + pstg := Storage; + polesite := OleClientSite; + dvAspect := DVASPECT_CONTENT; + dwFlags := REO_RESIZABLE; + OleCheck(OleSetDrawAspect(OleObject, + Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0, + Data.hMetaPict, dvAspect)); + end; + SendMessage(Handle, EM_EXGETSEL, 0, Longint(@Selection)); + Selection.cpMax := Selection.cpMin + 1; + OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject)); + SendMessage(Handle, EM_EXSETSEL, 0, Longint(@Selection)); + IRichEditOle(FRichEditOle).SetDvaspect( + Longint(REO_IOB_SELECTION), ReObject.dvAspect); + finally + ReleaseObject(OleObject); + end; + finally + ReleaseObject(OleClientSite); + ReleaseObject(Storage); + end; + end + else begin + Format := PasteFormats[Data.nSelectedIndex].fmtetc.cfFormat; + OleCheck(IRichEditOle(FRichEditOle).ImportDataObject( + Data.lpSrcDataObj, Format, Data.hMetaPict)); + end; + SendMessage(Handle, EM_SCROLLCARET, 0, 0); + end; + finally + DestroyMetaPict(Data.hMetaPict); + ReleaseObject(Data.lpSrcDataObj); + end; +end; + +function TRxCustomRichEdit.InsertObjectDialog: Boolean; +var + Data: TOleUIInsertObject; + NameBuffer: array[0..255] of Char; + OleClientSite: IOleClientSite; + Storage: IStorage; + OleObject: IOleObject; + ReObject: TReObject; + IsNewObject: Boolean; + Selection: TCharRange; +begin + FillChar(Data, SizeOf(Data), 0); + FillChar(NameBuffer, SizeOf(NameBuffer), 0); + FillChar(ReObject, SizeOf(TReObject), 0); + if Assigned(FRichEditOle) then begin + IRichEditOle(FRichEditOle).GetClientSite(OleClientSite); + Storage := nil; + try + CreateStorage(Storage); + with Data do begin + cbStruct := SizeOf(Data); + dwFlags := IOF_SELECTCREATENEW or IOF_VERIFYSERVERSEXIST or + IOF_CREATENEWOBJECT or IOF_CREATEFILEOBJECT or IOF_CREATELINKOBJECT; + hWndOwner := Handle; + lpszFile := NameBuffer; + cchFile := SizeOf(NameBuffer); + iid := IOleObject; + oleRender := OLERENDER_DRAW; + lpIOleClientSite := OleClientSite; + lpIStorage := Storage; + ppvObj := @OleObject; + end; + try + Result := OleUIInsertObject(Data) = OLEUI_OK; + if Result then + try + IsNewObject := Data.dwFlags and IOF_SELECTCREATENEW = IOF_SELECTCREATENEW; + with ReObject do begin + cbStruct := SizeOf(TReObject); + cp := REO_CP_SELECTION; + clsid := Data.clsid; + poleobj := OleObject; + pstg := Storage; + polesite := OleClientSite; + dvAspect := DVASPECT_CONTENT; + dwFlags := REO_RESIZABLE; + if IsNewObject then dwFlags := dwFlags or REO_BLANK; + OleCheck(OleSetDrawAspect(OleObject, + Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0, + Data.hMetaPict, dvAspect)); + end; + SendMessage(Handle, EM_EXGETSEL, 0, Longint(@Selection)); + Selection.cpMax := Selection.cpMin + 1; + OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject)); + SendMessage(Handle, EM_EXSETSEL, 0, Longint(@Selection)); + SendMessage(Handle, EM_SCROLLCARET, 0, 0); + IRichEditOle(FRichEditOle).SetDvaspect( + Longint(REO_IOB_SELECTION), ReObject.dvAspect); + if IsNewObject then OleObject.DoVerb(OLEIVERB_SHOW, nil, + OleClientSite, 0, Handle, ClientRect); + finally + ReleaseObject(OleObject); + end; + finally + DestroyMetaPict(Data.hMetaPict); + end; + finally + ReleaseObject(OleClientSite); + ReleaseObject(Storage); + end; + end + else Result := False; +end; + +function TRxCustomRichEdit.ObjectPropertiesDialog: Boolean; +var + ObjectProps: TOleUIObjectProps; + PropSheet: TPropSheetHeader; + GeneralProps: TOleUIGnrlProps; + ViewProps: TOleUIViewProps; + LinkProps: TOleUILinkProps; + DialogCaption: string; + ReObject: TReObject; +begin + Result := False; + if not Assigned(FRichEditOle) or (SelectionType <> [stObject]) then Exit; + FillChar(ObjectProps, SizeOf(ObjectProps), 0); + FillChar(PropSheet, SizeOf(PropSheet), 0); + FillChar(GeneralProps, SizeOf(GeneralProps), 0); + FillChar(ViewProps, SizeOf(ViewProps), 0); + FillChar(LinkProps, SizeOf(LinkProps), 0); + FillChar(ReObject, SizeOf(ReObject), 0); + ReObject.cbStruct := SizeOf(ReObject); + if Succeeded(IRichEditOle(FRichEditOle).GetObject(Longint(REO_IOB_SELECTION), + ReObject, REO_GETOBJ_POLEOBJ or REO_GETOBJ_POLESITE)) then + if ReObject.dwFlags and REO_INPLACEACTIVE = 0 then begin + ObjectProps.cbStruct := SizeOf(ObjectProps); + ObjectProps.dwFlags := OPF_DISABLECONVERT; + ObjectProps.lpPS := @PropSheet; + ObjectProps.lpObjInfo := TOleUIObjInfo.Create(Self, ReObject); + if (ReObject.dwFlags and REO_LINK) <> 0 then begin + ObjectProps.dwFlags := ObjectProps.dwFlags or OPF_OBJECTISLINK; + ObjectProps.lpLinkInfo := TOleUILinkInfo.Create(Self, ReObject); + end; + ObjectProps.lpGP := @GeneralProps; + ObjectProps.lpVP := @ViewProps; + ObjectProps.lpLP := @LinkProps; + PropSheet.dwSize := SizeOf(PropSheet); + PropSheet.hWndParent := Handle; + PropSheet.hInstance := MainInstance; + DialogCaption := Format(ResStr(SPropDlgCaption), + [GetFullNameStr(ReObject.poleobj)]); + PropSheet.pszCaption := PChar(DialogCaption); + GeneralProps.cbStruct := SizeOf(GeneralProps); + ViewProps.cbStruct := SizeOf(ViewProps); + ViewProps.dwFlags := VPF_DISABLESCALE; + LinkProps.cbStruct := SizeOf(LinkProps); + LinkProps.dwFlags := ELF_DISABLECANCELLINK; + Result := OleUIObjectProperties(ObjectProps) = OLEUI_OK; + end; +end; + +procedure TRxCustomRichEdit.Print(const Caption: string); +var + Range: TFormatRange; + LastChar, MaxLen, LogX, LogY, OldMap: Integer; + SaveRect: TRect; + TextLenEx: TGetTextLengthEx; +begin + FillChar(Range, SizeOf(TFormatRange), 0); + with Printer, Range do begin + Title := Caption; + BeginDoc; + hdc := Handle; + hdcTarget := hdc; + LogX := GetDeviceCaps(Handle, LOGPIXELSX); + LogY := GetDeviceCaps(Handle, LOGPIXELSY); + if IsRectEmpty(PageRect) then begin + rc.right := PageWidth * 1440 div LogX; + rc.bottom := PageHeight * 1440 div LogY; + end + else begin + rc.left := PageRect.Left * 1440 div LogX; + rc.top := PageRect.Top * 1440 div LogY; + rc.right := PageRect.Right * 1440 div LogX; + rc.bottom := PageRect.Bottom * 1440 div LogY; + end; + rcPage := rc; + SaveRect := rc; + LastChar := 0; + if RichEditVersion >= 2 then begin + with TextLenEx do begin + flags := GTL_DEFAULT; + codepage := CP_ACP; + end; + MaxLen := Perform(EM_GETTEXTLENGTHEX, WParam(@TextLenEx), 0); + end + else MaxLen := GetTextLen; + chrg.cpMax := -1; + { ensure printer DC is in text map mode } + OldMap := SetMapMode(hdc, MM_TEXT); + SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); { flush buffer } + try + repeat + rc := SaveRect; + chrg.cpMin := LastChar; + LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range)); + if (LastChar < MaxLen) and (LastChar <> -1) then NewPage; + until (LastChar >= MaxLen) or (LastChar = -1); + EndDoc; + finally + SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); { flush buffer } + SetMapMode(hdc, OldMap); { restore previous map mode } + end; + end; +end; + +var + Painting: Boolean = False; + +procedure TRxCustomRichEdit.WMPaint(var Message: TWMPaint); +var + R, R1: TRect; +begin + if RichEditVersion >= 2 then + inherited + else begin + if GetUpdateRect(Handle, R, True) then + begin + with ClientRect do R1 := Rect(Right - 3, Top, Right, Bottom); + if IntersectRect(R, R, R1) then InvalidateRect(Handle, @R1, True); + end; + if Painting then + Invalidate + else begin + Painting := True; + try + inherited; + finally + Painting := False; + end; + end; + end; +end; + +procedure TRxCustomRichEdit.WMDestroy(var Msg: TWMDestroy); +begin + CloseObjects; + ReleaseObject(FRichEditOle); + inherited; +end; + +procedure TRxCustomRichEdit.WMMouseMove(var Message: TMessage); +begin + inherited; +end; + +procedure TRxCustomRichEdit.WMSetCursor(var Message: TWMSetCursor); +begin + inherited; +end; + +{$IFDEF Delphi5} +procedure TRxCustomRichEdit.WMRButtonUp(var Message: TMessage); +begin + { RichEd20 does not pass the WM_RBUTTONUP message to defwndproc, } + { so we get no WM_CONTEXTMENU message. Simulate message here. } +// if Win32MajorVersion < 5 then + Perform(WM_CONTEXTMENU, Handle, LParam(PointToSmallPoint( + ClientToScreen(SmallPointToPoint(TWMMouse(Message).Pos))))); + inherited; +end; +{$ENDIF} + +procedure TRxCustomRichEdit.CNNotify(var Message: TWMNotify); +var + AMsg: TMessage; +begin + with Message do + case NMHdr^.code of + EN_SELCHANGE: SelectionChange; + EN_REQUESTRESIZE: RequestSize(PReqSize(NMHdr)^.rc); + EN_SAVECLIPBOARD: + with PENSaveClipboard(NMHdr)^ do + if not SaveClipboard(cObjectCount, cch) then Result := 1; + EN_PROTECTED: + with PENProtected(NMHdr)^ do begin + AMsg.Msg := Msg; + AMsg.WParam := WParam; + AMsg.LParam := LParam; + AMsg.Result := 0; + if not ProtectChange(AMsg, chrg.cpMin, chrg.cpMax) then + Result := 1; + end; + EN_LINK: + with PENLink(NMHdr)^ do begin + case Msg of + WM_RBUTTONDOWN: + begin + FClickRange := chrg; + FClickBtn := mbRight; + end; + WM_RBUTTONUP: + begin + if (FClickBtn = mbRight) and (FClickRange.cpMin = chrg.cpMin) and + (FClickRange.cpMax = chrg.cpMax) then + URLClick(GetTextRange(chrg.cpMin, chrg.cpMax), mbRight); + with FClickRange do begin + cpMin := -1; + cpMax := -1; + end; + end; + WM_LBUTTONDOWN: + begin + FClickRange := chrg; + FClickBtn := mbLeft; + end; + WM_LBUTTONUP: + begin + if (FClickBtn = mbLeft) and (FClickRange.cpMin = chrg.cpMin) and + (FClickRange.cpMax = chrg.cpMax) then + URLClick(GetTextRange(chrg.cpMin, chrg.cpMax), mbLeft); + with FClickRange do begin + cpMin := -1; + cpMax := -1; + end; + end; + end; + end; + EN_STOPNOUNDO: + begin + { cannot allocate enough memory to maintain the undo state } + end; + end; +end; + +function TRxCustomRichEdit.SaveClipboard(NumObj, NumChars: Integer): Boolean; +begin + Result := True; + if Assigned(OnSaveClipboard) then + OnSaveClipboard(Self, NumObj, NumChars, Result); +end; + +function TRxCustomRichEdit.ProtectChange(const Message: TMessage; StartPos, + EndPos: Integer): Boolean; +begin + Result := False; + if Assigned(OnProtectChangeEx) then + OnProtectChangeEx(Self, Message, StartPos, EndPos, Result) + else if Assigned(OnProtectChange) then + OnProtectChange(Self, StartPos, EndPos, Result); +end; + +procedure TRxCustomRichEdit.SelectionChange; +begin + if Assigned(OnSelectionChange) then OnSelectionChange(Self); +end; + +procedure TRxCustomRichEdit.RequestSize(const Rect: TRect); +begin + if Assigned(OnResizeRequest) then OnResizeRequest(Self, Rect); +end; + +procedure TRxCustomRichEdit.URLClick(const URLText: string; Button: TMouseButton); +begin + if Assigned(OnURLClick) then OnURLClick(Self, URLText, Button); +end; + +function TRxCustomRichEdit.FindText(const SearchStr: string; + StartPos, Length: Integer; Options: TRichSearchTypes): Integer; +var + Find: TFindTextEx; + Flags: Integer; +begin + with Find.chrg do begin + cpMin := StartPos; + cpMax := cpMin + Abs(Length); + end; + if RichEditVersion >= 2 then begin + if not (stBackward in Options) then Flags := FT_DOWN + else Flags := 0; + end + else begin + Options := Options - [stBackward]; + Flags := 0; + end; + if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD; + if stMatchCase in Options then Flags := Flags or FT_MATCHCASE; + Find.lpstrText := PChar(SearchStr); + Result := SendMessage(Handle, EM_FINDTEXTEX, Flags, Longint(@Find)); + if (Result >= 0) and (stSetSelection in Options) then begin + SendMessage(Handle, EM_EXSETSEL, 0, Longint(@Find.chrgText)); + SendMessage(Handle, EM_SCROLLCARET, 0, 0); + end; +end; + +procedure TRxCustomRichEdit.ClearUndo; +begin + SendMessage(Handle, EM_EMPTYUNDOBUFFER, 0, 0); +end; + +procedure TRxCustomRichEdit.Redo; +begin + SendMessage(Handle, EM_REDO, 0, 0); +end; + +procedure TRxCustomRichEdit.StopGroupTyping; +begin + if (RichEditVersion >= 2) and HandleAllocated then + SendMessage(Handle, EM_STOPGROUPTYPING, 0, 0); +end; + +procedure TRxCustomRichEdit.SetUIActive(Active: Boolean); +var + Form: TCustomForm; +begin + try + Form := GetParentForm(Self); + if Form <> nil then + if Active then begin + if (Form.ActiveOleControl <> nil) and + (Form.ActiveOleControl <> Self) then + Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0); + Form.ActiveOleControl := Self; + if AllowInPlace and CanFocus then SetFocus; + end + else begin + if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil; + if (Form.ActiveControl = Self) and AllowInPlace then begin + Windows.SetFocus(Handle); + SelectionChange; + end; + end; + except + Application.HandleException(Self); + end; +end; + +procedure TRxCustomRichEdit.CMDocWindowActivate(var Message: TMessage); +begin + if Assigned(FCallback) then + with TRichEditOleCallback(FCallback) do + if Assigned(FDocForm) and IsFormMDIChild(FDocForm.Form) then begin + if Message.WParam = 0 then begin + FFrameForm.SetMenu(0, 0, 0); + FFrameForm.ClearBorderSpace; + end; + end; +end; + +procedure TRxCustomRichEdit.CMUIDeactivate(var Message: TMessage); +begin + if (GetParentForm(Self) <> nil) and Assigned(FRichEditOle) and + (GetParentForm(Self).ActiveOleControl = Self) then + {IRichEditOle(FRichEditOle).InPlaceDeactivate}; +end; + +{ Find & Replace Dialogs } + +procedure TRxCustomRichEdit.SetupFindDialog(Dialog: TFindDialog; + const SearchStr, ReplaceStr: string); +begin + with Dialog do begin + if SearchStr <> '' then FindText := SearchStr; + if RichEditVersion = 1 then + Options := Options + [frHideUpDown, frDown]; + OnFind := FindDialogFind; + OnClose := FindDialogClose; + end; + if Dialog is TReplaceDialog then + with TReplaceDialog(Dialog) do begin + if ReplaceStr <> '' then ReplaceText := ReplaceStr; + OnReplace := ReplaceDialogReplace; + end; +end; + +function TRxCustomRichEdit.FindDialog(const SearchStr: string): TFindDialog; +begin + if FFindDialog = nil then begin + FFindDialog := TFindDialog.Create(Self); + if FReplaceDialog <> nil then + FFindDialog.FindText := FReplaceDialog.FindText; + end; + Result := FFindDialog; + SetupFindDialog(FFindDialog, SearchStr, ''); + FFindDialog.Execute; +end; + +function TRxCustomRichEdit.ReplaceDialog(const SearchStr, + ReplaceStr: string): TReplaceDialog; +begin + if FReplaceDialog = nil then begin + FReplaceDialog := TReplaceDialog.Create(Self); + if FFindDialog <> nil then + FReplaceDialog.FindText := FFindDialog.FindText; + end; + Result := FReplaceDialog; + SetupFindDialog(FReplaceDialog, SearchStr, ReplaceStr); + FReplaceDialog.Execute; +end; + +function TRxCustomRichEdit.GetCanFindNext: Boolean; +begin + Result := HandleAllocated and (FLastFind <> nil) and + (FLastFind.FindText <> ''); +end; + +function TRxCustomRichEdit.FindNext: Boolean; +begin + if CanFindNext then Result := FindEditText(FLastFind, False, True) + else Result := False; +end; + +procedure TRxCustomRichEdit.AdjustFindDialogPosition(Dialog: TFindDialog); +var + TextRect, R: TRect; +begin + if Dialog.Handle = 0 then Exit; + with TextRect do begin + TopLeft := ClientToScreen(GetCharPos(SelStart)); + BottomRight := ClientToScreen(GetCharPos(SelStart + SelLength)); + Inc(Bottom, 20); + end; + with Dialog do begin + GetWindowRect(Handle, R); + if PtInRect(R, TextRect.TopLeft) or PtInRect(R, TextRect.BottomRight) then + begin + if TextRect.Top > R.Bottom - R.Top + 20 then + OffsetRect(R, 0, TextRect.Top - R.Bottom - 20) + else begin + if TextRect.Top + R.Bottom - R.Top < GetSystemMetrics(SM_CYSCREEN) then + OffsetRect(R, 0, 40 + TextRect.Top - R.Top); + end; + Position := R.TopLeft; + end; + end; +end; + +function TRxCustomRichEdit.FindEditText(Dialog: TFindDialog; AdjustPos, Events: Boolean): Boolean; +var + Length, StartPos: Integer; + SrchOptions: TRichSearchTypes; + + function Max(A, B: Longint): Longint; + begin + if A > B then Result := A + else Result := B; + end; + + function Min(A, B: Longint): Longint; + begin + if A < B then Result := A + else Result := B; + end; + +begin + with TFindDialog(Dialog) do begin + SrchOptions := [stSetSelection]; + if frDown in Options then begin + StartPos := Max(SelStart, SelStart + SelLength); + Length := System.Length(Text) - StartPos + 1; + end + else begin + SrchOptions := SrchOptions + [stBackward]; + StartPos := Min(SelStart, SelStart + SelLength); + Length := StartPos + 1; + end; + if frMatchCase in Options then + SrchOptions := SrchOptions + [stMatchCase]; + if frWholeWord in Options then + SrchOptions := SrchOptions + [stWholeWord]; + Result := Self.FindText(FindText, StartPos, Length, SrchOptions) >= 0; + if FindText <> '' then FLastFind := Dialog; + if Result then begin + if AdjustPos then AdjustFindDialogPosition(Dialog); + end + else if Events then TextNotFound(Dialog); + end; +end; + +procedure TRxCustomRichEdit.TextNotFound(Dialog: TFindDialog); +begin + with Dialog do + if Assigned(FOnTextNotFound) then FOnTextNotFound(Self, FindText); +end; + +procedure TRxCustomRichEdit.FindDialogFind(Sender: TObject); +begin + FindEditText(TFindDialog(Sender), True, True); +end; + +procedure TRxCustomRichEdit.ReplaceDialogReplace(Sender: TObject); +var + Cnt: Integer; + SaveSelChange: TNotifyEvent; +begin + with TReplaceDialog(Sender) do begin + if (frReplaceAll in Options) then begin + Cnt := 0; + SaveSelChange := FOnSelChange; + TRichEditStrings(Lines).EnableChange(False); + try + FOnSelChange := nil; + while FindEditText(TFindDialog(Sender), False, False) do begin + SelText := ReplaceText; + Inc(Cnt); + end; + if Cnt = 0 then TextNotFound(TFindDialog(Sender)) + else AdjustFindDialogPosition(TFindDialog(Sender)); + finally + TRichEditStrings(Lines).EnableChange(True); + FOnSelChange := SaveSelChange; + if Cnt > 0 then begin + Change; + SelectionChange; + end; + end; + end + else if (frReplace in Options) then begin + if FindEditText(TFindDialog(Sender), True, True) then + SelText := ReplaceText; + end; + end; +end; + +procedure TRxCustomRichEdit.FindDialogClose(Sender: TObject); +begin + CloseFindDialog(Sender as TFindDialog); +end; + +procedure TRxCustomRichEdit.CloseFindDialog(Dialog: TFindDialog); +begin + if Assigned(FOnCloseFindDialog) then FOnCloseFindDialog(Self, Dialog); +end; + +{ Conversion formats } + +procedure AppendConversionFormat(const Ext: string; Plain: Boolean; + AClass: TConversionClass); +var + NewRec: PRichConversionFormat; +begin + New(NewRec); + with NewRec^ do begin + Extension := AnsiLowerCaseFileName(Ext); + PlainText := Plain; + ConversionClass := AClass; + Next := ConversionFormatList; + end; + ConversionFormatList := NewRec; +end; + +class procedure TRxCustomRichEdit.RegisterConversionFormat(const AExtension: string; + APlainText: Boolean; AConversionClass: TConversionClass); +begin + AppendConversionFormat(AExtension, APlainText, AConversionClass); +end; + +{ Initialization part } + +var + OldError: Longint; + FLibHandle: THandle; + Ver: TOsVersionInfo; + +initialization + RichEditVersion := 1; + OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX); + try + FLibHandle := LoadLibrary(RichEdit41ModuleName); + if (FLibHandle > 0) and (FLibHandle < HINSTANCE_ERROR) then FLibHandle := 0; + if FLibHandle = 0 then + begin + FLibHandle := LoadLibrary(RichEdit20ModuleName); + if FLibHandle = 0 then begin + FLibHandle := LoadLibrary(RichEdit10ModuleName); + if (FLibHandle > 0) and (FLibHandle < HINSTANCE_ERROR) then FLibHandle := 0; + end + else begin + RichEditVersion := 2; + Ver.dwOSVersionInfoSize := SizeOf(Ver); + GetVersionEx(Ver); + with Ver do begin + if (dwPlatformId = VER_PLATFORM_WIN32_NT) and + (dwMajorVersion >= 5) then + RichEditVersion := 3; + end; + end; + end else + RichEditVersion := 4; + finally + SetErrorMode(OldError); + end; + CFEmbeddedObject := RegisterClipboardFormat(CF_EMBEDDEDOBJECT); + CFLinkSource := RegisterClipboardFormat(CF_LINKSOURCE); + CFRtf := RegisterClipboardFormat(CF_RTF); + CFRtfNoObjs := RegisterClipboardFormat(CF_RTFNOOBJS); +finalization + if FLibHandle <> 0 then FreeLibrary(FLibHandle); +end. + + + +// diff --git a/official/4.8.11/Source/frxRichEditor.dfm b/official/4.8.11/Source/frxRichEditor.dfm new file mode 100644 index 0000000..85dc971 Binary files /dev/null and b/official/4.8.11/Source/frxRichEditor.dfm differ diff --git a/official/4.8.11/Source/frxRichEditor.pas b/official/4.8.11/Source/frxRichEditor.pas new file mode 100644 index 0000000..179628a --- /dev/null +++ b/official/4.8.11/Source/frxRichEditor.pas @@ -0,0 +1,488 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ RichEdit design editor } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRichEditor; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Menus, ExtCtrls, Buttons, frxClass, frxRich, frxCustomEditors, + frxCtrls, frxRichEdit, ImgList, frxDock, ToolWin, ComCtrls, frxUnicodeCtrls +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxRichEditor = class(TfrxViewEditor) + public + function Edit: Boolean; override; + function HasEditor: Boolean; override; + procedure GetMenuItems; override; + function Execute(Tag: Integer; Checked: Boolean): Boolean; override; + end; + + TfrxRichEditorForm = class(TForm) + OpenDialog: TOpenDialog; + SaveDialog: TSaveDialog; + SpeedBar: TToolBar; + Ruler: TPanel; + FontDialog1: TFontDialog; + FirstInd: TLabel; + LeftInd: TLabel; + RulerLine: TBevel; + RightInd: TLabel; + BoldB: TToolButton; + ItalicB: TToolButton; + LeftAlignB: TToolButton; + CenterAlignB: TToolButton; + RightAlignB: TToolButton; + UnderlineB: TToolButton; + BulletsB: TToolButton; + TTB: TToolButton; + CancelB: TToolButton; + OkB: TToolButton; + ExprB: TToolButton; + FontNameCB: TfrxFontComboBox; + FontSizeCB: TfrxComboBox; + OpenB: TToolButton; + SaveB: TToolButton; + UndoB: TToolButton; + Sep1: TToolButton; + Sep2: TToolButton; + Sep3: TfrxTBPanel; + Sep4: TToolButton; + Sep5: TToolButton; + BlockAlignB: TToolButton; + + procedure SelectionChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FileOpen(Sender: TObject); + procedure FileSaveAs(Sender: TObject); + procedure EditUndo(Sender: TObject); + procedure SelectFont(Sender: TObject); + procedure RulerResize(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormPaint(Sender: TObject); + procedure BoldBClick(Sender: TObject); + procedure AlignButtonClick(Sender: TObject); + procedure FontNameCBChange(Sender: TObject); + procedure BulletsBClick(Sender: TObject); + procedure RulerItemMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure RulerItemMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure FirstIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure LeftIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure RightIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure CancelBClick(Sender: TObject); + procedure OkBClick(Sender: TObject); + procedure ExprBClick(Sender: TObject); + procedure FontSizeCBChange(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + private + { Private declarations } + FDragging: Boolean; + FDragOfs: Integer; + FRichView: TfrxRichView; + FUpdating: Boolean; + RichEdit1: TRxUnicodeRichEdit; + function CurrText: TrxTextAttributes; + procedure SetupRuler; + procedure SetEditRect; + public + { Public declarations } + property RichView: TfrxRichView read FRichView write FRichView; + end; + + +implementation + +{$R *.DFM} + +uses frxDsgnIntf, frxRes; + + +const + RulerAdj = 4/3; + GutterWid = 6; + + +{ TfrxRichEditor } + +function TfrxRichEditor.HasEditor: Boolean; +begin + Result := True; +end; + +function TfrxRichEditor.Edit: Boolean; +begin + with TfrxRichEditorForm.Create(Designer) do + begin + RichView := TfrxRichView(Component); + Result := ShowModal = mrOk; + Free; + end; +end; + +function TfrxRichEditor.Execute(Tag: Integer; Checked: Boolean): Boolean; +var + i: Integer; + c: TfrxComponent; + v: TfrxRichView; +begin + Result := inherited Execute(Tag, Checked); + + for i := 0 to Designer.SelectedObjects.Count - 1 do + begin + c := Designer.SelectedObjects[i]; + if (c is TfrxRichView) and not (rfDontModify in c.Restrictions) then + begin + v := TfrxRichView(c); + case Tag of + 1: v.AllowExpressions := Checked; + 2: if Checked then + v.StretchMode := smActualHeight else + v.StretchMode := smDontStretch; + 3: if Checked then + v.StretchMode := smMaxHeight else + v.StretchMode := smDontStretch; + end; + + Result := True; + end; + end; +end; + +procedure TfrxRichEditor.GetMenuItems; +var + v: TfrxRichView; +begin + v := TfrxRichView(Component); + + AddItem(frxResources.Get('mvExpr'), 1, v.AllowExpressions); + AddItem('-', -1); + AddItem(frxResources.Get('mvStretch'), 2, v.StretchMode = smActualHeight); + AddItem(frxResources.Get('mvStretchToMax'), 3, v.StretchMode = smMaxHeight); + + inherited; +end; + + +{ TfrxRichEditorForm } + +procedure TfrxRichEditorForm.SelectionChange(Sender: TObject); +begin + with RichEdit1.Paragraph do + try + FUpdating := True; + FirstInd.Left := Trunc(FirstIndent * RulerAdj) - 4 + GutterWid; + LeftInd.Left := Trunc((LeftIndent + FirstIndent) * RulerAdj) - 4 + GutterWid; + RightInd.Left := Ruler.ClientWidth - 6 - Trunc((RightIndent + GutterWid) * RulerAdj); + BoldB.Down := fsBold in RichEdit1.SelAttributes.Style; + ItalicB.Down := fsItalic in RichEdit1.SelAttributes.Style; + UnderlineB.Down := fsUnderline in RichEdit1.SelAttributes.Style; + BulletsB.Down := Boolean(Numbering); + FontSizeCB.Text := IntToStr(RichEdit1.SelAttributes.Size); + FontNameCB.Text := RichEdit1.SelAttributes.Name; + case Alignment of + paLeftJustify: LeftAlignB.Down := True; + paCenter: CenterAlignB.Down := True; + paRightJustify: RightAlignB.Down := True; + paJustify: BlockAlignB.Down := True; + end; + finally + FUpdating := False; + end; +end; + +function TfrxRichEditorForm.CurrText: TrxTextAttributes; +begin + Result := RichEdit1.SelAttributes; +end; + +procedure TfrxRichEditorForm.SetupRuler; +var + I: Integer; + S: String; +begin + SetLength(S, 201); + I := 1; + while I < 200 do + begin + S[I] := #9; + S[I+1] := '|'; + Inc(I, 2); + end; + Ruler.Caption := S; +end; + +procedure TfrxRichEditorForm.SetEditRect; +var + R: TRect; +begin + with RichEdit1 do + begin + R := Rect(GutterWid, 0, ClientWidth - GutterWid, ClientHeight); + SendMessage(Handle, EM_SETRECT, 0, Longint(@R)); + end; +end; + +{ Event Handlers } + +procedure TfrxRichEditorForm.FormResize(Sender: TObject); +begin + SetEditRect; + SelectionChange(Sender); +end; + +procedure TfrxRichEditorForm.FormPaint(Sender: TObject); +begin + SetEditRect; +end; + +procedure TfrxRichEditorForm.FileOpen(Sender: TObject); +begin + OpenDialog.Filter := frxResources.Get('ftRichFile') + ' (*.rtf)|*.rtf'; + if OpenDialog.Execute then + begin + RichEdit1.Lines.LoadFromFile(OpenDialog.FileName); + RichEdit1.SetFocus; + SelectionChange(Self); + end; +end; + +procedure TfrxRichEditorForm.FileSaveAs(Sender: TObject); +begin + SaveDialog.Filter := frxResources.Get('ftRichFile') + ' (*.rtf)|*.rtf|' + + frxResources.Get('ftTextFile') + ' (*.txt)|*.txt'; + if SaveDialog.Execute then + RichEdit1.Lines.SaveToFile(ChangeFileExt(SaveDialog.FileName, '.rtf')); +end; + +procedure TfrxRichEditorForm.EditUndo(Sender: TObject); +begin + with RichEdit1 do + if HandleAllocated then SendMessage(Handle, EM_UNDO, 0, 0); +end; + +procedure TfrxRichEditorForm.SelectFont(Sender: TObject); +begin + FontDialog1.Font.Assign(RichEdit1.SelAttributes); + if FontDialog1.Execute then + CurrText.Assign(FontDialog1.Font); + RichEdit1.SetFocus; +end; + +procedure TfrxRichEditorForm.RulerResize(Sender: TObject); +begin + RulerLine.Width := Ruler.ClientWidth - RulerLine.Left * 2; +end; + +procedure TfrxRichEditorForm.BoldBClick(Sender: TObject); +var + s: TFontStyles; +begin + if FUpdating then Exit; + s := []; + if BoldB.Down then s := s + [fsBold]; + if ItalicB.Down then s := s + [fsItalic]; + if UnderlineB.Down then s := s + [fsUnderline]; + CurrText.Style := s; +end; + +procedure TfrxRichEditorForm.AlignButtonClick(Sender: TObject); +begin + if FUpdating then Exit; + case TControl(Sender).Tag of + 0: RichEdit1.Paragraph.Alignment := paLeftJustify; + 1: RichEdit1.Paragraph.Alignment := paCenter; + 2: RichEdit1.Paragraph.Alignment := paRightJustify; + 3: RichEdit1.Paragraph.Alignment := paJustify; + end; +end; + +procedure TfrxRichEditorForm.FontNameCBChange(Sender: TObject); +begin + if FUpdating then Exit; + CurrText.Name := FontNameCB.Text; + RichEdit1.SetFocus; +end; + +procedure TfrxRichEditorForm.BulletsBClick(Sender: TObject); +begin + if FUpdating then Exit; + RichEdit1.Paragraph.Numbering := TrxNumbering(BulletsB.Down); +end; + +{ Ruler Indent Dragging } + +procedure TfrxRichEditorForm.RulerItemMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + FDragOfs := (TLabel(Sender).Width div 2); + TLabel(Sender).Left := TLabel(Sender).Left + X - FDragOfs; + FDragging := True; +end; + +procedure TfrxRichEditorForm.RulerItemMouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); +begin + if FDragging then + TLabel(Sender).Left := TLabel(Sender).Left + X - FDragOfs +end; + +procedure TfrxRichEditorForm.FirstIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + FDragging := False; + RichEdit1.Paragraph.FirstIndent := + Trunc((FirstInd.Left + FDragOfs - GutterWid) / RulerAdj); + LeftIndMouseUp(Sender, Button, Shift, X, Y); +end; + +procedure TfrxRichEditorForm.LeftIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + FDragging := False; + RichEdit1.Paragraph.LeftIndent := + Trunc((LeftInd.Left + FDragOfs - GutterWid) / RulerAdj) - RichEdit1.Paragraph.FirstIndent; + SelectionChange(Sender); +end; + +procedure TfrxRichEditorForm.RightIndMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + FDragging := False; + RichEdit1.Paragraph.RightIndent := + Trunc((Ruler.ClientWidth - RightInd.Left + FDragOfs - 2) / RulerAdj) - 2 * GutterWid; + SelectionChange(Sender); +end; + +procedure TfrxRichEditorForm.CancelBClick(Sender: TObject); +begin + ModalResult := mrCancel; +end; + +procedure TfrxRichEditorForm.OkBClick(Sender: TObject); +begin + ModalResult := mrOk; +end; + +procedure TfrxRichEditorForm.ExprBClick(Sender: TObject); +var + s, s1, s2: String; + + function BracketCount: Integer; + var + i: Integer; + begin + Result := 0; + for i := 1 to Length(s) do + if s[i] = '<' then + Inc(Result); + end; + +begin + s := TfrxCustomDesigner(Owner).InsertExpression(''); + if s <> '' then + begin + s1 := RichView.ExpressionDelimiters; + s2 := Copy(s1, Pos(',', s1) + 1, 255); + s1 := Copy(s1, 1, Pos(',', s1) - 1); + if (s[1] = '<') and (s[Length(s)] = '>') and (BracketCount = 1) then + s := Copy(s, 2, Length(s) - 2); + RichEdit1.SelText := s1 + s + s2; + RichEdit1.SelLength := Length(s1 + s + s2); + end; +end; + +procedure TfrxRichEditorForm.FontSizeCBChange(Sender: TObject); +begin + CurrText.Size := StrToInt(FontSizeCB.Text); + RichEdit1.SetFocus; +end; + +procedure TfrxRichEditorForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(4200); + OpenB.Hint := frxGet(4201); + SaveB.Hint := frxGet(4202); + UndoB.Hint := frxGet(4203); + TTB.Hint := frxGet(4204); + ExprB.Hint := frxGet(4205); + CancelB.Hint := frxGet(2); + OkB.Hint := frxGet(1); + BoldB.Hint := frxGet(4206); + ItalicB.Hint := frxGet(4207); + UnderlineB.Hint := frxGet(4208); + LeftAlignB.Hint := frxGet(4209); + CenterAlignB.Hint := frxGet(4210); + RightAlignB.Hint := frxGet(4211); + BlockAlignB.Hint := frxGet(4212); + BulletsB.Hint := frxGet(4213); + FontNameCB.Hint := frxGet(2322); + FontSizeCB.Hint := frxGet(2323); + + RichEdit1 := TRxUnicodeRichEdit.Create(Self); + RichEdit1.Parent := Self; + RichEdit1.Align := alClient; + RichEdit1.OnSelectionChange := SelectionChange; + + SpeedBar.Images := frxResources.MainButtonImages; + Icon := TForm(Owner).Icon; + OpenDialog.InitialDir := ExtractFilePath(ParamStr(0)); + SaveDialog.InitialDir := OpenDialog.InitialDir; + SetupRuler; + SelectionChange(Self); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxRichEditorForm.FormShow(Sender: TObject); +begin + frxAssignRich(RichView.RichEdit, RichEdit1); + RichEdit1.SetFocus; +end; + +procedure TfrxRichEditorForm.FormHide(Sender: TObject); +begin + if ModalResult = mrOk then + frxAssignRich(RichEdit1, RichView.RichEdit); +end; + + +procedure TfrxRichEditorForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +initialization + frxComponentEditors.Register(TfrxRichView, TfrxRichEditor); + + +end. + + +// diff --git a/official/4.8.11/Source/frxRichRTTI.pas b/official/4.8.11/Source/frxRichRTTI.pas new file mode 100644 index 0000000..354f9f4 --- /dev/null +++ b/official/4.8.11/Source/frxRichRTTI.pas @@ -0,0 +1,75 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Rich RTTI } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxRichRTTI; + +interface + +{$I frx.inc} + +implementation + +uses + Windows, Classes, SysUtils, Forms, fs_iinterpreter, fs_iformsrtti, frxRich, + frxRichEdit, frxClassRTTI +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TFunctions = class(TfsRTTIModule) + private + function GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; + public + constructor Create(AScript: TfsScript); override; + end; + + +{ TFunctions } + +constructor TFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddClass(TrxRichEdit, 'TWinControl'); + with AddClass(TfrxRichView, 'TfrxView') do + AddProperty('RichEdit', 'TrxRichEdit', GetProp, nil); + end; +end; + +function TFunctions.GetProp(Instance: TObject; ClassType: TClass; + const PropName: String): Variant; +begin + Result := 0; + + if ClassType = TfrxRichView then + begin + if PropName = 'RICHEDIT' then + Result := Integer(TfrxRichView(Instance).RichEdit) + end +end; + + +initialization + fsRTTIModules.Add(TFunctions); + +finalization + if fsRTTIModules <> nil then + fsRTTIModules.Remove(TFunctions); + +end. + + +// diff --git a/official/4.8.11/Source/frxSaveFRX.pas b/official/4.8.11/Source/frxSaveFRX.pas new file mode 100644 index 0000000..e3b1eab --- /dev/null +++ b/official/4.8.11/Source/frxSaveFRX.pas @@ -0,0 +1,1133 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Convert to .FRX } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxSaveFRX; + +interface + +{$I frx.inc} + +uses + Windows, Classes, Graphics, Printers, SysUtils, Controls, Forms, StdCtrls, + ComCtrls, + frxClass, frxXML, frxUnicodeUtils, frxVariables, frxUtils, frxEngine, +{$IFDEF Delphi6} + Variants, +{$ENDIF} + frxBarcode, frxChBox, frxRich, frxNetUtils, frxDesgn, frxDCtrl; + +type + TfrxSaveFRX = class(TfrxCustomSavePlugin) + private + Report: TfrxReport; + procedure ConvertReport(root: TfrxXmlItem); + procedure ConvertVariables(root: TfrxXmlItem); + procedure ConvertReportPage(Page: TfrxReportPage; root: TfrxXmlItem); + function ConvertBand(Band: TfrxBand; root: TfrxXmlItem): TfrxXmlItem; + procedure ConvertReportObject(Obj: TfrxView; root: TfrxXmlItem); + procedure ConvertMemo(Memo: TfrxCustomMemoView; root: TfrxXmlItem); + procedure ConvertPicture(Picture: TfrxPictureView; root: TfrxXmlItem); + procedure ConvertLine(Line: TfrxLineView; root: TfrxXmlItem); + procedure ConvertShape(Shape: TfrxShapeView; root: TfrxXmlItem); + procedure ConvertSubreport(Subreport: TfrxSubreport; root: TfrxXmlItem); + procedure ConvertBarcode(Barcode: TfrxBarcodeView; root: TfrxXmlItem); + procedure ConvertRich(Rich: TfrxRichView; root: TfrxXmlItem); + procedure ConvertCheckBox(CheckBox: TfrxCheckBoxView; root: TfrxXmlItem); + + procedure ConvertDialogPage(Page: TfrxDialogPage; root: TfrxXmlItem); + procedure ConvertDialogControl(Control: TfrxDialogControl; root: TfrxXmlItem); + procedure ConvertDialogButton(Button: TfrxButtonControl; root: TfrxXmlItem); + procedure ConvertDialogLabel(Lbl: TfrxLabelControl; root: TfrxXmlItem); + procedure ConvertDialogEdit(Edit: TfrxCustomEditControl; root: TfrxXmlItem); + procedure ConvertDialogCheckBox(CheckBox: TfrxCheckBoxControl; root: TfrxXmlItem); + procedure ConvertDialogRadioButton(RadioButton: TfrxRadioButtonControl; root: TfrxXmlItem); + procedure ConvertDialogListBox(ListBox: TfrxListBoxControl; root: TfrxXmlItem); + procedure ConvertDialogComboBox(ComboBox: TfrxComboBoxControl; root: TfrxXmlItem); + procedure ConvertDialogPanel(Panel: TfrxPanelControl; root: TfrxXmlItem); + procedure ConvertDialogGroupBox(GroupBox: TfrxGroupBoxControl; root: TfrxXmlItem); + procedure ConvertDialogDateEdit(DateEdit: TfrxDateEditControl; root: TfrxXmlItem); + procedure ConvertDialogImage(Image: TfrxImageControl; root: TfrxXmlItem); + procedure ConvertDialogCheckListBox(CheckListBox: TfrxCheckListBoxControl; root: TfrxXmlItem); + + procedure ConvertFrame(Frame: TfrxFrame; root: TfrxXmlItem); + procedure ConvertFrameLine(Line: TfrxFrameLine; Name: String; root: TfrxXmlItem); + procedure ConvertFont(Font: TFont; Name: String; root: TfrxXmlItem); + public + constructor Create; + procedure Save(Report: TfrxReport; const FileName: String); override; + end; + + +implementation + +function frxFloatToStr(d: Extended): String; +var + i: Integer; +begin + if Int(d) = d then + Result := FloatToStr(d) else + Result := Format('%2.2f', [d]); + + for i := 1 to Length(Result) do + begin + if Result[i] in [',', ' '] then + Result[i] := '.'; + end; +end; + +function frxColorToStr(Color: TColor): String; +var + l: LongInt; +begin + l := ColorToRGB(Color); + Result := IntToStr(l mod 256); + l := l div 256; + Result := Result + ', ' + IntToStr(l mod 256); + l := l div 256; + Result := Result + ', ' + IntToStr(l mod 256); +end; + +function frxStreamToBase64String(Stream: TStream): AnsiString; +var + Size: Integer; + p: AnsiString; +begin + Size := Stream.Size; + SetLength(p, Size); + + Stream.Position := 0; + Stream.Read(p[1], Size); + + Result := Base64Encode(p); +end; + +function frxLinesToStr(Lines: String): String; +begin + Result := Lines; + if Length(Lines) > 2 then + if (Lines[Length(Lines) - 1] = #13) and (Lines[Length(Lines)] = #10) then + Result := Copy(Result, 1, Length(Result) - 2); +end; + +constructor TfrxSaveFRX.Create; +begin + FileFilter := 'FastReport.Net file (*.frx)|*.frx'; +end; + +procedure TfrxSaveFRX.ConvertReport(root: TfrxXmlItem); +var + dictRoot: TfrxXmlItem; + version, script: String; + i: Integer; +begin + root.Name := 'Report'; + + script := StringReplace(Report.ScriptText.Text, #13#10, '', [rfReplaceAll]); + if script <> 'beginend.' then + begin + script := 'using System;' + #13#10 + + 'using System.Collections;' + #13#10 + + 'using System.Collections.Generic;' + #13#10 + + 'using System.ComponentModel;' + #13#10 + + 'using System.Windows.Forms;' + #13#10 + + 'using System.Drawing;' + #13#10 + + 'using System.Data;' + #13#10 + + 'using FastReport;' + #13#10 + + 'using FastReport.Data;' + #13#10 + + 'using FastReport.Dialog;' + #13#10 + + 'using FastReport.Barcode;' + #13#10 + + 'using FastReport.Table;' + #13#10 + + 'using FastReport.Utils;' + #13#10 + + '' + #13#10 + + 'namespace FastReport' + #13#10 + + '{' + #13#10 + + ' public class ReportScript' + #13#10 + + ' {' + #13#10 + + ' }' + #13#10 + + '}' + #13#10; + root.Prop['ScriptText'] := UTF8Encode(script + '/*' + Report.ScriptText.Text + '*/'); + end; + + root.Prop['ReportInfo.Name'] := UTF8Encode(Report.ReportOptions.Name); + root.Prop['ReportInfo.Author'] := UTF8Encode(Report.ReportOptions.Author); + root.Prop['ReportInfo.Description'] := UTF8Encode(Report.ReportOptions.Description.Text); + version := Report.ReportOptions.VersionMajor + '.' + + Report.ReportOptions.VersionMinor + '.' + + Report.ReportOptions.VersionRelease + '.' + + Report.ReportOptions.VersionBuild; + if version <> '...' then + root.Prop['ReportInfo.Version'] := UTF8Encode(version); + + dictRoot := root.Add; + dictRoot.Name := 'Dictionary'; + ConvertVariables(dictRoot); + + // prepare band tree + (Report.Engine as TfrxEngine).Initialize; + + for i := 0 to Report.PagesCount - 1 do + begin + if Report.Pages[i] is TfrxReportPage then + ConvertReportPage(Report.Pages[i] as TfrxReportPage, root) + else if Report.Pages[i] is TfrxDialogPage then + ConvertDialogPage(Report.Pages[i] as TfrxDialogPage, root) + end; + + (Report.Engine as TfrxEngine).Finalize; +end; + +procedure TfrxSaveFRX.ConvertVariables(root: TfrxXmlItem); +var + i: Integer; + v: TfrxVariable; + xi: TfrxXmlItem; +begin + for i := 0 to Report.Variables.Count - 1 do + begin + v := Report.Variables.Items[i]; + if (v.Name <> '') and (v.Name[1] <> ' ') then + begin + xi := root.Add; + xi.Name := 'Parameter'; + xi.Prop['Name'] := UTF8Encode(v.Name); + if v.Value <> null then + begin + if (TVarData(v.Value).VType = varString) or + (TVarData(v.Value).VType = varOleStr) + {$IFDEF Delphi12} or (TVarData(v.Value).VType = varUString){$ENDIF} then + if v.Value <> '' then + xi.Prop['Expression'] := UTF8Encode(v.Value); + end; + end; + end; +end; + + +{------------------------------------------------------------------------------} +procedure TfrxSaveFRX.ConvertReportPage(Page: TfrxReportPage; root: TfrxXmlItem); +var + i: Integer; + pageItem: TfrxXmlItem; + band: TfrxBand; + hasReportTitle: Boolean; + hasOverlay: Boolean; + h: Extended; +begin + pageItem := root.Add; + pageItem.Name := 'ReportPage'; + pageItem.Prop['Name'] := Page.Name; + if Page.Orientation = poLandscape then + pageItem.Prop['Landscape'] := 'true'; + pageItem.Prop['PaperWidth'] := frxFloatToStr(Page.PaperWidth); + pageItem.Prop['PaperHeight'] := frxFloatToStr(Page.PaperHeight); + pageItem.Prop['LeftMargin'] := frxFloatToStr(Page.LeftMargin); + pageItem.Prop['RightMargin'] := frxFloatToStr(Page.RightMargin); + pageItem.Prop['TopMargin'] := frxFloatToStr(Page.TopMargin); + pageItem.Prop['BottomMargin'] := frxFloatToStr(Page.BottomMargin); + pageItem.Prop['Columns.Count'] := IntToStr(Page.Columns); + pageItem.Prop['Columns.Width'] := frxFloatToStr(Page.ColumnWidth); + + if Page.PrintOnPreviousPage then + pageItem.Prop['PrintOnPreviousPage'] := 'true'; + if Page.MirrorMargins then + pageItem.Prop['MirrorMargins'] := 'true'; + if Page.OutlineText <> '' then + pageItem.Prop['OutlineExpression'] := UTF8Encode(Page.OutlineText); + if Page.TitleBeforeHeader then + pageItem.Prop['TitleBeforeHeader'] := 'true'; + if Page.Bin <> DMBIN_AUTO then + pageItem.Prop['FirstPageSource'] := IntToStr(Page.Bin); + if Page.BinOtherPages <> DMBIN_AUTO then + pageItem.Prop['OtherPagesSource'] := IntToStr(Page.BinOtherPages); + + hasReportTitle := false; + hasOverlay := false; + + for i := 0 to Page.Objects.Count - 1 do + begin + if TObject(Page.Objects[i]) is TfrxBand then + begin + band := TObject(Page.Objects[i]) as TfrxBand; + if (band is TfrxReportTitle) or (band is TfrxReportSummary) or + (band is TfrxPageHeader) or (band is TfrxPageFooter) or + (band is TfrxColumnHeader) or (band is TfrxColumnFooter) or + (band is TfrxOverlay) then + ConvertBand(band, pageItem); + + if band is TfrxReportTitle then + hasReportTitle := true; + if band is TfrxOverlay then + hasOverlay := true; + end; + end; + + band := nil; + if not hasReportTitle then + band := TfrxReportTitle.Create(nil) + else if not hasOverlay then + band := TfrxOverlay.Create(nil); + + if band <> nil then + begin + for i := 0 to Page.Objects.Count - 1 do + begin + if TObject(Page.Objects[i]) is TfrxView then + begin + band.Objects.Add(Page.Objects[i]); + with TObject(Page.Objects[i]) as TfrxView do + h := Top + Height; + if h > band.Height then + band.Height := h; + end; + end; + + band.Name := band.BaseName + '1'; + if band.Objects.Count <> 0 then + ConvertBand(band, pageItem); + end; + + if band <> nil then + begin + band.Objects.Clear; + band.Free; + end; + + for i := 0 to Page.FSubBands.Count - 1 do + begin + band := TObject(Page.FSubBands[i]) as TfrxBand; + ConvertBand(band, pageItem); + end; +end; + +function TfrxSaveFRX.ConvertBand(Band: TfrxBand; root: TfrxXmlItem): TfrxXmlItem; +var + i: Integer; + bandItem: TfrxXmlItem; + groupBand: TfrxGroupHeader; + dataBand: TfrxDataBand; +const + bands: array[0..BND_COUNT - 1] of String = + ('ReportTitleBand', 'ReportSummaryBand', 'PageHeaderBand', 'PageFooterBand', + 'DataHeaderBand', 'DataFooterBand', 'DataBand', 'DataBand', 'DataBand', + 'DataBand', 'DataBand', 'DataBand', 'GroupHeaderBand', 'GroupFooterBand', + 'ChildBand', 'ColumnHeaderBand', 'ColumnFooterBand', 'OverlayBand'); +begin + if Band.Vertical then + begin + Result := root; + Exit; + end; + + if (Band is TfrxDataBand) and (Band.FGroup <> nil) then + begin + groupBand := Band.FGroup as TfrxGroupHeader; + for i := 0 to groupBand.FSubBands.Count - 1 do + begin + root := ConvertBand(TfrxBand(groupBand.FSubBands[i]), root); + end; + end; + + bandItem := root.Add; + bandItem.Name := bands[Band.BandNumber]; + bandItem.Prop['Name'] := Band.Name; + bandItem.Prop['Height'] := frxFloatToStr(Band.Height); + + if Band.Stretched then + begin + bandItem.Prop['CanGrow'] := 'true'; + bandItem.Prop['CanShrink'] := 'true'; + end; + + if Band.AllowSplit then + bandItem.Prop['CanBreak'] := 'true'; + + if Band.KeepChild then + bandItem.Prop['KeepChild'] := 'true'; + + if Band.StartNewPage then + bandItem.Prop['StartNewPage'] := 'true'; + + if Band.OutlineText <> '' then + bandItem.Prop['OutlineExpression'] := UTF8Encode(Band.OutlineText); + + if Band is TfrxDataBand then + begin + dataBand := Band as TfrxDataBand; + + if dataBand.Columns > 1 then + begin + bandItem.Prop['Columns.Count'] := IntToStr(dataBand.Columns); + bandItem.Prop['Columns.Width'] := frxFloatToStr(dataBand.ColumnWidth); + end; + + if dataBand.DataSet <> nil then + bandItem.Prop['DataSource'] := UTF8Encode(dataBand.DataSet.Name); + + if dataBand.KeepTogether then + bandItem.Prop['KeepTogether'] := 'true'; + + if dataBand.PrintIfDetailEmpty then + bandItem.Prop['PrintIfDetailEmpty'] := 'true'; + + if Band.FHeader <> nil then + ConvertBand(Band.FHeader, bandItem); + + for i := 0 to Band.FSubBands.Count - 1 do + begin + ConvertBand(TfrxBand(Band.FSubBands[i]), bandItem); + end; + + if Band.FFooter <> nil then + ConvertBand(Band.FFooter, bandItem); + end; + + if Band is TfrxGroupHeader then + begin + groupBand := Band as TfrxGroupHeader; + + if groupBand.Condition <> '' then + bandItem.Prop['Condition'] := UTF8Encode(groupBand.Condition); + + if groupBand.KeepTogether then + bandItem.Prop['KeepTogether'] := 'true'; + + if groupBand.ReprintOnNewPage then + bandItem.Prop['RepeatOnEveryPage'] := 'true'; + + if groupBand.ResetPageNumbers then + bandItem.Prop['ResetPageNumber'] := 'true'; + + if Band.FFooter <> nil then + ConvertBand(Band.FFooter, bandItem); + end; + + if Band.Child <> nil then + ConvertBand(Band.Child, bandItem); + + for i := 0 to Band.Objects.Count - 1 do + begin + ConvertReportObject(TfrxView(Band.Objects[i]), bandItem); + end; + + Result := bandItem; +end; + +procedure TfrxSaveFRX.ConvertReportObject(Obj: TfrxView; root: TfrxXmlItem); +var + objItem: TfrxXmlItem; + objClass: String; +const + brushStyles: array [0..7] of String = ( + 'Solid', 'Clear', 'Horizontal', 'Vertical', 'ForwardDiagonal', + 'BackwardDiagonal', 'LargeGrid', 'OutlinedDiamond'); +begin + objItem := root.Add; + + objItem.Prop['Name'] := UTF8Encode(Obj.Name); + objItem.Prop['Left'] := frxFloatToStr(Obj.Left); + objItem.Prop['Top'] := frxFloatToStr(Obj.Top); + objItem.Prop['Width'] := frxFloatToStr(Obj.Width); + objItem.Prop['Height'] := frxFloatToStr(Obj.Height); + + if not Obj.Visible then + objItem.Prop['Visible'] := 'false'; + + if not Obj.Printable then + objItem.Prop['Printable'] := 'false'; + + if Obj.BrushStyle <> bsSolid then + begin + objItem.Prop['Fill'] := 'Hatch'; + objItem.Prop['Fill.Style'] := brushStyles[Integer(Obj.BrushStyle)]; + objItem.Prop['Fill.BackColor'] := frxColorToStr(Obj.Color); + end + else if Obj.Color <> clTransparent then + objItem.Prop['Fill.Color'] := frxColorToStr(Obj.Color); + + if Obj.Cursor = crHandPoint then + objItem.Prop['Cursor'] := 'Hand'; + + ConvertFrame(Obj.Frame, objItem); + + if Obj.ShiftMode = smDontShift then + objItem.Prop['ShiftMode'] := 'Never' + else if Obj.ShiftMode = smWhenOverlapped then + objItem.Prop['ShiftMode'] := 'WhenOverlapped'; + + if Obj.URL <> '' then + begin + if Pos('@', Obj.URL) = 1 then + begin + objItem.Prop['Hyperlink.Kind'] := 'PageNumber'; + objItem.Prop['Hyperlink.Value'] := UTF8Encode(Copy(Obj.URL, 2, 255)); + end + else if Pos('#', Obj.URL) = 1 then + begin + objItem.Prop['Hyperlink.Kind'] := 'Bookmark'; + objItem.Prop['Hyperlink.Value'] := UTF8Encode(Copy(Obj.URL, 2, 255)); + end + else + begin + objItem.Prop['Hyperlink.Value'] := UTF8Encode(Obj.URL); + end; + end; + + if (Obj.DataSetName <> '') and (Obj.DataField <> '') and + not (Obj is TfrxCustomMemoView) then + objItem.Prop['DataColumn'] := UTF8Encode(Obj.DataSetName + '.' + Obj.DataField); + + if Obj is TfrxCustomMemoView then + begin + objClass := 'TextObject'; + ConvertMemo(Obj as TfrxCustomMemoView, objItem); + end + else if Obj is TfrxPictureView then + begin + objClass := 'PictureObject'; + ConvertPicture(Obj as TfrxPictureView, objItem); + end + else if Obj is TfrxLineView then + begin + objClass := 'LineObject'; + ConvertLine(Obj as TfrxLineView, objItem); + end + else if Obj is TfrxShapeView then + begin + objClass := 'ShapeObject'; + ConvertShape(Obj as TfrxShapeView, objItem); + end + else if Obj is TfrxSubReport then + begin + objClass := 'SubreportObject'; + ConvertSubreport(Obj as TfrxSubreport, objItem); + end + else if Obj is TfrxBarcodeView then + begin + objClass := 'BarcodeObject'; + ConvertBarcode(Obj as TfrxBarcodeView, objItem); + end + else if Obj is TfrxRichView then + begin + objClass := 'RichObject'; + ConvertRich(Obj as TfrxRichView, objItem); + end + else if Obj is TfrxCheckBoxView then + begin + objClass := 'CheckBoxObject'; + ConvertCheckBox(Obj as TfrxCheckBoxView, objItem); + end; + + objItem.Name := objClass; +end; + +procedure TfrxSaveFRX.ConvertMemo(Memo: TfrxCustomMemoView; root: TfrxXmlItem); +var + hltItem: TfrxXmlItem; +const + haligns: array [0..3] of String = ( + 'Left', 'Right', 'Center', 'Justify'); + valigns: array [0..2] of String = ( + 'Top', 'Bottom', 'Center'); +begin + ConvertFont(Memo.Font, 'Font', root); + root.Prop['Text'] := UTF8Encode(memo.Text); + + if memo.StretchMode = smActualHeight then + begin + root.Prop['CanGrow'] := 'true'; + root.Prop['CanShrink'] := 'true'; + end + else if memo.StretchMode = smMaxHeight then + root.Prop['GrowToBottom'] := 'true'; + + if not memo.AllowExpressions then + root.Prop['AllowExpressions'] := 'false'; + + if memo.AutoWidth then + root.Prop['AutoWidth'] := 'true'; + + if not memo.Clipped then + root.Prop['Clip'] := 'false'; + + if memo.ExpressionDelimiters <> '[,]' then + root.Prop['Brackets'] := memo.ExpressionDelimiters; + + if memo.FlowTo <> nil then + root.Prop['BreakTo'] := UTF8Encode(memo.FlowTo.Name); + + root.Prop['Padding'] := IntToStr(Round(memo.GapX)) + ', ' + + IntToStr(Round(memo.GapY)) + ', ' + + IntToStr(Round(memo.GapX)) + ', ' + IntToStr(Round(memo.GapY)); + + root.Prop['HorzAlign'] := haligns[Integer(memo.HAlign)]; + root.Prop['VertAlign'] := valigns[Integer(memo.VAlign)]; + + if memo.HideZeros then + root.Prop['HideValue'] := '0'; + + if memo.LineSpacing <> 2 then + root.Prop['LineSpacing'] := frxFloatToStr(memo.LineSpacing); + + if memo.Rotation <> 0 then + root.Prop['Angle'] := IntToStr(memo.Rotation); + + if memo.RTLReading then + root.Prop['RightToLeft'] := 'true'; + + if memo.SuppressRepeated then + root.Prop['Duplicates'] := 'Hide'; + + if memo.Underlines then + root.Prop['Underlines'] := 'true'; + + if not memo.WordWrap then + root.Prop['WordWrap'] := 'false'; + + if memo.Font.Color <> clBlack then + root.Prop['TextFill.Color'] := frxColorToStr(memo.Font.Color); + + if memo.DisplayFormat.Kind = fkNumeric then + begin + if memo.DisplayFormat.FormatStr = '%2.2m' then + root.Prop['Format'] := 'Currency' + else + root.Prop['Format'] := 'Number'; + end + else if memo.DisplayFormat.Kind = fkDateTime then + begin + if Pos('h', memo.DisplayFormat.FormatStr) <> 0 then + root.Prop['Format'] := 'Time' + else + root.Prop['Format'] := 'Date'; + end + else if memo.DisplayFormat.Kind = fkBoolean then + root.Prop['Format'] := 'Boolean'; + + if memo.Highlight.Condition <> '' then + begin + hltItem := root.Add; + hltItem.Name := 'Highlight'; + hltItem := hltItem.Add; + hltItem.Name := 'Condition'; + hltItem.Prop['Expression'] := UTF8Encode(memo.Highlight.Condition); + ConvertFont(memo.Highlight.Font, 'Font', hltItem); + hltItem.Prop['Fill.Color'] := frxColorToStr(memo.Highlight.Color); + hltItem.Prop['TextFill.Color'] := frxColorToStr(memo.Highlight.Font.Color); + hltItem.Prop['ApplyFill'] := 'true'; + hltItem.Prop['ApplyFont'] := 'true'; + end; +end; + +procedure TfrxSaveFRX.ConvertPicture(Picture: TfrxPictureView; root: TfrxXmlItem); +var + s: TMemoryStream; +begin + if picture.AutoSize then + root.Prop['SizeMode'] := 'AutoSize' + else if picture.Center then + root.Prop['SizeMode'] := 'CenterImage' + else if picture.Stretched then + begin + if picture.KeepAspectRatio then + root.Prop['SizeMode'] := 'Zoom' + else + root.Prop['SizeMode'] := 'StretchImage' + end; + + if picture.FileLink <> '' then + root.Prop['ImageLocation'] := UTF8Encode(picture.FileLink) + else if (picture.Picture.Graphic <> nil) and not picture.Picture.Graphic.Empty then + begin + s := TMemoryStream.Create; + picture.Picture.Graphic.SaveToStream(s); + root.Prop['Image'] := frxStreamToBase64String(s); + s.Free; + end; +end; + +procedure TfrxSaveFRX.ConvertLine(Line: TfrxLineView; root: TfrxXmlItem); +begin + if line.Diagonal then + root.Prop['Diagonal'] := 'true'; + + if line.ArrowStart then + begin + root.Prop['StartCap.Style'] := 'Arrow'; + root.Prop['StartCap.Width'] := IntToStr(line.ArrowWidth); + root.Prop['StartCap.Height'] := IntToStr(line.ArrowLength); + end; + + if line.ArrowEnd then + begin + root.Prop['EndCap.Style'] := 'Arrow'; + root.Prop['EndCap.Width'] := IntToStr(line.ArrowWidth); + root.Prop['EndCap.Height'] := IntToStr(line.ArrowLength); + end; +end; + +procedure TfrxSaveFRX.ConvertShape(Shape: TfrxShapeView; root: TfrxXmlItem); +const + shapes: array [0..6] of String = ( + 'Rectangle', 'RoundRectangle', 'Ellipse', 'Triangle', + 'Diamond', 'Rectangle', 'Rectangle'); +begin + root.Prop['Shape'] := shapes[Integer(Shape.Shape)]; + if Shape.Shape = skRoundRectangle then + root.Prop['Curve'] := IntToStr(Shape.Curve); +end; + +procedure TfrxSaveFRX.ConvertSubreport(Subreport: TfrxSubreport; root: TfrxXmlItem); +begin + if Subreport.PrintOnParent then + root.Prop['PrintOnParent'] := 'true'; + root.Prop['ReportPage'] := Subreport.Page.Name; +end; + +procedure TfrxSaveFRX.ConvertBarcode(Barcode: TfrxBarcodeView; root: TfrxXmlItem); +const + barcodes: array [0..22] of String = ( + '2/5 Interleaved', '2/5 Industrial', '2/5 Matrix', 'Code39', + 'Code39 Extended', 'Code128', 'Code128', 'Code128', 'Code93', + 'Code93 Extended', 'MSI', 'PostNet', 'Codabar', 'EAN8', + 'EAN13', 'UPC-A', 'UPC-E0', 'UPC-E1', 'Supplement 2', + 'Supplement 5', 'Code128', 'Code128', 'Code128'); + +begin + root.Prop['Barcode'] := barcodes[Integer(Barcode.BarType)]; + if not Barcode.CalcCheckSum then + root.Prop['Barcode.CalcCheckSum'] := 'false'; + root.Prop['Barcode.WideBarRatio'] := frxFloatToStr(Barcode.WideBarRatio); + if Barcode.Rotation <> 0 then + root.Prop['Angle'] := IntToStr(Barcode.Rotation); + if not Barcode.ShowText then + root.Prop['ShowText'] := 'false'; + root.Prop['Text'] := UTF8Encode(Barcode.Text); + if Barcode.Expression <> '' then + root.Prop['Expression'] := UTF8Encode(Barcode.Expression); + root.Prop['Zoom'] := frxFloatToStr(Barcode.Zoom); +end; + +procedure TfrxSaveFRX.ConvertRich(Rich: TfrxRichView; root: TfrxXmlItem); +var + stm: TMemoryStream; + s: AnsiString; +begin + if rich.StretchMode = smActualHeight then + begin + root.Prop['CanGrow'] := 'true'; + root.Prop['CanShrink'] := 'true'; + end + else if rich.StretchMode = smMaxHeight then + root.Prop['GrowToBottom'] := 'true'; + + if not rich.AllowExpressions then + root.Prop['AllowExpressions'] := 'false'; + + if rich.ExpressionDelimiters <> '[,]' then + root.Prop['Brackets'] := rich.ExpressionDelimiters; + + if rich.FlowTo <> nil then + root.Prop['BreakTo'] := UTF8Encode(rich.FlowTo.Name); + + root.Prop['Padding'] := IntToStr(Round(rich.GapX)) + ', ' + + IntToStr(Round(rich.GapY)) + ', ' + IntToStr(Round(rich.GapX)) + ', ' + + IntToStr(Round(rich.GapY)); + + stm := TMemoryStream.Create; + rich.RichEdit.Lines.SaveToStream(stm); + SetLength(s, stm.Size); + stm.Position := 0; + stm.Read(s[1], stm.Size); + stm.Free; + + root.Prop['Text'] := UTF8Encode(s); +end; + +procedure TfrxSaveFRX.ConvertCheckBox(CheckBox: TfrxCheckBoxView; root: TfrxXmlItem); +const + checkStyles: array [0..3] of String = ( + 'Cross', 'Check', 'Cross', 'Plus'); + uncheckStyles: array [0..3] of String = ( + 'None', 'Cross', 'Cross', 'Minus'); +begin + root.Prop['CheckedSymbol'] := checkStyles[Integer(CheckBox.CheckStyle)]; + root.Prop['UncheckedSymbol'] := uncheckStyles[Integer(CheckBox.UncheckStyle)]; + if not CheckBox.Checked then + root.Prop['Checked'] := 'false'; + if CheckBox.CheckColor <> clBlack then + root.Prop['CheckColor'] := frxColorToStr(CheckBox.CheckColor); + if CheckBox.Expression <> '' then + root.Prop['Expression'] := UTF8Encode(CheckBox.Expression); +end; + + +{------------------------------------------------------------------------------} +procedure TfrxSaveFRX.ConvertDialogPage(Page: TfrxDialogPage; root: TfrxXmlItem); +var + i: Integer; + pageItem: TfrxXmlItem; +begin + pageItem := root.Add; + pageItem.Name := 'DialogPage'; + pageItem.Prop['Name'] := Page.Name; + pageItem.Prop['Width'] := frxFloatToStr(Page.Width); + pageItem.Prop['Height'] := frxFloatToStr(Page.Height); + + if Page.BorderStyle <> bsDialog then + pageItem.Prop['FormBorderStyle'] := 'Sizable'; + pageItem.Prop['Text'] := UTF8Encode(Page.Caption); + if Page.Color <> clBtnFace then + pageItem.Prop['BackColor'] := frxColorToStr(Page.Color); + ConvertFont(Page.Font, 'Font', pageItem); + + for i := 0 to Page.Objects.Count - 1 do + begin + if TObject(Page.Objects[i]) is TfrxDialogControl then + ConvertDialogControl(TfrxDialogControl(Page.Objects[i]), pageItem); + end; +end; + +procedure TfrxSaveFRX.ConvertDialogControl(Control: TfrxDialogControl; root: TfrxXmlItem); +var + objItem: TfrxXmlItem; + objClass: String; +begin + if (Control is TfrxBitBtnControl) or (Control is TfrxSpeedButtonControl) or + (Control is TfrxBevelControl) then Exit; + + objItem := root.Add; + + objItem.Prop['Name'] := UTF8Encode(Control.Name); + objItem.Prop['Left'] := frxFloatToStr(Control.Left); + objItem.Prop['Top'] := frxFloatToStr(Control.Top); + objItem.Prop['Width'] := frxFloatToStr(Control.Width); + objItem.Prop['Height'] := frxFloatToStr(Control.Height); + + ConvertFont(Control.Font, 'Font', objItem); + + if not Control.Visible then + objItem.Prop['Visible'] := 'false'; + + if not Control.Enabled then + objItem.Prop['Enabled'] := 'false'; + + if Control.Font.Color <> clWindowText then + objItem.Prop['ForeColor'] := frxColorToStr(Control.Font.Color); + + if Control.Color <> clBtnFace then + objItem.Prop['BackColor'] := frxColorToStr(Control.Color); + + if Control.Caption <> '' then + objItem.Prop['Text'] := UTF8Encode(Control.Caption); + + if Control is TfrxButtonControl then + begin + objClass := 'ButtonControl'; + ConvertDialogButton(Control as TfrxButtonControl, objItem); + end + else if Control is TfrxLabelControl then + begin + objClass := 'LabelControl'; + ConvertDialogLabel(Control as TfrxLabelControl, objItem); + end + else if Control is TfrxMaskEditControl then + begin + objClass := 'MaskedTextBoxControl'; + ConvertDialogEdit(Control as TfrxCustomEditControl, objItem); + end + else if Control is TfrxCustomEditControl then + begin + objClass := 'TextBoxControl'; + ConvertDialogEdit(Control as TfrxCustomEditControl, objItem); + end + else if Control is TfrxCheckBoxControl then + begin + objClass := 'CheckBoxControl'; + ConvertDialogCheckBox(Control as TfrxCheckBoxControl, objItem); + end + else if Control is TfrxRadioButtonControl then + begin + objClass := 'RadioButtonControl'; + ConvertDialogRadioButton(Control as TfrxRadioButtonControl, objItem); + end + else if Control is TfrxListBoxControl then + begin + objClass := 'ListBoxControl'; + ConvertDialogListBox(Control as TfrxListBoxControl, objItem); + end + else if Control is TfrxComboBoxControl then + begin + objClass := 'ComboBoxControl'; + ConvertDialogComboBox(Control as TfrxComboBoxControl, objItem); + end + else if Control is TfrxPanelControl then + begin + objClass := 'PanelControl'; + ConvertDialogPanel(Control as TfrxPanelControl, objItem); + end + else if Control is TfrxGroupBoxControl then + begin + objClass := 'GroupBoxControl'; + ConvertDialogGroupBox(Control as TfrxGroupBoxControl, objItem); + end + else if Control is TfrxDateEditControl then + begin + objClass := 'DateTimePickerControl'; + ConvertDialogDateEdit(Control as TfrxDateEditControl, objItem); + end + else if Control is TfrxImageControl then + begin + objClass := 'PictureBoxControl'; + ConvertDialogImage(Control as TfrxImageControl, objItem); + end + else if Control is TfrxCheckListBoxControl then + begin + objClass := 'CheckedListBoxControl'; + ConvertDialogCheckListBox(Control as TfrxCheckListBoxControl, objItem); + end; + + objItem.Name := objClass; +end; + +procedure TfrxSaveFRX.ConvertDialogButton(Button: TfrxButtonControl; root: TfrxXmlItem); +var + s: String; +begin + s := 'None'; + if Button.ModalResult = mrOk then + s := 'OK' + else if Button.ModalResult = mrCancel then + s := 'Cancel'; + root.Prop['DialogResult'] := s; +end; + +procedure TfrxSaveFRX.ConvertDialogLabel(Lbl: TfrxLabelControl; root: TfrxXmlItem); +const + align: array [0..2] of String = ( + 'TopLeft', 'TopRight', 'TopCenter'); +begin + root.Prop['TextAlign'] := align[Integer(Lbl.Alignment)]; + if not Lbl.AutoSize then + root.Prop['AutoSize'] := 'false'; +end; + +procedure TfrxSaveFRX.ConvertDialogEdit(Edit: TfrxCustomEditControl; root: TfrxXmlItem); +const + sbars: array [0..3] of String = ( + 'None', 'Horizontal', 'Vertical', 'Both'); +begin + if Edit is TfrxMemoControl then + begin + root.Prop['Multiline'] := 'true'; + if not TfrxMemoControl(Edit).WordWrap then + root.Prop['WordWrap'] := 'false'; + root.Prop['ScrollBars'] := sbars[Integer(TfrxMemoControl(Edit).ScrollBars)]; + end; + + if Edit is TfrxMaskEditControl then + root.Prop['Mask'] := UTF8Encode(TfrxMaskEditControl(Edit).EditMask); + + if Edit.MaxLength <> 0 then + root.Prop['MaxLength'] := IntToStr(Edit.MaxLength); + if Edit.PasswordChar <> #0 then + root.Prop['UseSystemPasswordChar'] := 'true'; + if Edit.ReadOnly then + root.Prop['ReadOnly'] := 'true'; + root.Prop['Text'] := UTF8Encode(Edit.Text); +end; + +procedure TfrxSaveFRX.ConvertDialogCheckBox(CheckBox: TfrxCheckBoxControl; root: TfrxXmlItem); +begin + if CheckBox.AllowGrayed then + root.Prop['ThreeState'] := 'true'; + if CheckBox.Checked then + root.Prop['Checked'] := 'true'; + if CheckBox.Alignment = taLeftJustify then + root.Prop['CheckAlign'] := 'MiddleRight'; +end; + +procedure TfrxSaveFRX.ConvertDialogRadioButton(RadioButton: TfrxRadioButtonControl; root: TfrxXmlItem); +begin + if RadioButton.Checked then + root.Prop['Checked'] := 'true'; + if RadioButton.Alignment = taLeftJustify then + root.Prop['CheckAlign'] := 'MiddleRight'; +end; + +procedure TfrxSaveFRX.ConvertDialogListBox(ListBox: TfrxListBoxControl; root: TfrxXmlItem); +begin + root.Prop['ItemsText'] := UTF8Encode(frxLinesToStr(ListBox.Items.Text)); +end; + +procedure TfrxSaveFRX.ConvertDialogComboBox(ComboBox: TfrxComboBoxControl; root: TfrxXmlItem); +begin + if ComboBox.Style = csDropDownList then + root.Prop['DropDownStyle'] := 'DropDownList'; + root.Prop['ItemsText'] := UTF8Encode(frxLinesToStr(ComboBox.Items.Text)); + if ComboBox.Text <> '' then + root.Prop['Text'] := UTF8Encode(ComboBox.Text); +end; + +procedure TfrxSaveFRX.ConvertDialogPanel(Panel: TfrxPanelControl; root: TfrxXmlItem); +var + i: Integer; +begin + for i := 0 to Panel.Objects.Count - 1 do + begin + if TObject(Panel.Objects[i]) is TfrxDialogControl then + ConvertDialogControl(TfrxDialogControl(Panel.Objects[i]), root); + end; +end; + +procedure TfrxSaveFRX.ConvertDialogGroupBox(GroupBox: TfrxGroupBoxControl; root: TfrxXmlItem); +var + i: Integer; +begin + for i := 0 to GroupBox.Objects.Count - 1 do + begin + if TObject(GroupBox.Objects[i]) is TfrxDialogControl then + ConvertDialogControl(TfrxDialogControl(GroupBox.Objects[i]), root); + end; +end; + +procedure TfrxSaveFRX.ConvertDialogDateEdit(DateEdit: TfrxDateEditControl; root: TfrxXmlItem); +begin + if DateEdit.Kind = dtkDate then + begin + if dateEdit.DateFormat = dfShort then + root.Prop['Format'] := 'Short'; + end + else + begin + root.Prop['Format'] := 'Time'; + end; + + root.Prop['Value'] := DateToStr(DateEdit.Date) + ' ' + TimeToStr(DateEdit.Time); +end; + +procedure TfrxSaveFRX.ConvertDialogImage(Image: TfrxImageControl; root: TfrxXmlItem); +var + s: TMemoryStream; +begin + if Image.AutoSize then + root.Prop['SizeMode'] := 'AutoSize' + else if Image.Center then + root.Prop['SizeMode'] := 'CenterImage' + else if Image.Stretch then + root.Prop['SizeMode'] := 'StretchImage'; + + if (Image.Picture.Graphic <> nil) and not Image.Picture.Graphic.Empty then + begin + s := TMemoryStream.Create; + Image.Picture.Graphic.SaveToStream(s); + root.Prop['Image'] := frxStreamToBase64String(s); + s.Free; + end; +end; + +procedure TfrxSaveFRX.ConvertDialogCheckListBox(CheckListBox: TfrxCheckListBoxControl; root: TfrxXmlItem); +begin + root.Prop['ItemsText'] := UTF8Encode(frxLinesToStr(CheckListBox.Items.Text)); + if CheckListBox.Sorted then + root.Prop['Sorted'] := 'true'; +end; + +{------------------------------------------------------------------------------} +procedure TfrxSaveFRX.ConvertFrame(Frame: TfrxFrame; root: TfrxXmlItem); +var + s: String; +begin + if Frame.DropShadow then + begin + root.Prop['Border.DropShadow'] := 'true'; + root.Prop['Border.ShadowWidth'] := frxFloatToStr(Frame.ShadowWidth); + root.Prop['Border.ShadowColor'] := frxColorToStr(Frame.ShadowColor); + end; + if Frame.Typ <> [] then + begin + s := ''; + if ftLeft in Frame.Typ then + s := s + 'Left, '; + if ftRight in Frame.Typ then + s := s + 'Right, '; + if ftTop in Frame.Typ then + s := s + 'Top, '; + if ftBottom in Frame.Typ then + s := s + 'Bottom, '; + if s[Length(s)] = ' ' then + s := Copy(s, 1, Length(s) - 2); + root.Prop['Border.Lines'] := s; + + ConvertFrameLine(Frame.LeftLine, 'Left', root); + ConvertFrameLine(Frame.RightLine, 'Right', root); + ConvertFrameLine(Frame.TopLine, 'Top', root); + ConvertFrameLine(Frame.BottomLine, 'Bottom', root); + end; +end; + +procedure TfrxSaveFRX.ConvertFrameLine(Line: TfrxFrameLine; Name: String; root: TfrxXmlItem); +const + styles: array [0..7] of String = ( + 'Solid', 'Dash', 'Dot', 'DashDot', 'DashDotDot', 'Double', 'Dot', 'Dot'); +begin + root.Prop['Border.' + Name + 'Line.Color'] := frxColorToStr(Line.Color); + root.Prop['Border.' + Name + 'Line.Style'] := styles[Integer(Line.Style)]; + root.Prop['Border.' + Name + 'Line.Width'] := frxFloatToStr(Line.Width); +end; + +procedure TfrxSaveFRX.ConvertFont(Font: TFont; Name: String; root: TfrxXmlItem); +var + s: String; +begin + if (Font.Name <> 'Arial') or (Font.Size <> 10) or (Font.Style <> []) then + begin + s := Font.Name + ', ' + IntToStr(Font.Size) + 'pt'; + if Font.Style <> [] then + begin + s := s + ', style='; + if fsBold in Font.Style then + s := s + 'Bold, '; + if fsItalic in Font.Style then + s := s + 'Italic, '; + if fsUnderline in Font.Style then + s := s + 'Underline, '; + if fsStrikeout in Font.Style then + s := s + 'Strikeout, '; + if s[Length(s)] = ' ' then + s := Copy(s, 1, Length(s) - 2); + end; + root.Prop[Name] := UTF8Encode(s); + end; +end; + +procedure TfrxSaveFRX.Save(Report: TfrxReport; const FileName: String); +var + doc: TfrxXMLDocument; +begin + Self.Report := Report; + doc := TfrxXMLDocument.Create(); + + ConvertReport(doc.Root); + + doc.AutoIndent := True; + doc.SaveToFile(FileName); + doc.Free; +end; + + +initialization + frxSavePlugin := TfrxSaveFRX.Create; + +end. + + +// diff --git a/official/4.8.11/Source/frxSearchDialog.dfm b/official/4.8.11/Source/frxSearchDialog.dfm new file mode 100644 index 0000000..b877c7e Binary files /dev/null and b/official/4.8.11/Source/frxSearchDialog.dfm differ diff --git a/official/4.8.11/Source/frxSearchDialog.pas b/official/4.8.11/Source/frxSearchDialog.pas new file mode 100644 index 0000000..5620540 --- /dev/null +++ b/official/4.8.11/Source/frxSearchDialog.pas @@ -0,0 +1,100 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Search dialog } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxSearchDialog; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls; + +type + TfrxSearchDialog = class(TForm) + ReplacePanel: TPanel; + ReplaceL: TLabel; + ReplaceE: TEdit; + Panel2: TPanel; + TextL: TLabel; + TextE: TEdit; + Panel3: TPanel; + OkB: TButton; + CancelB: TButton; + SearchL: TGroupBox; + CaseCB: TCheckBox; + TopCB: TCheckBox; + procedure FormCreate(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure FormActivate(Sender: TObject); + private + public + end; + + +implementation + +uses frxRes; + +{$R *.DFM} + +var + LastText: String; + +procedure TfrxSearchDialog.FormCreate(Sender: TObject); +begin + Caption := frxGet(300); + TextL.Caption := frxGet(301); + SearchL.Caption := frxGet(302); + ReplaceL.Caption := frxGet(303); + TopCB.Caption := frxGet(304); + CaseCB.Caption := frxGet(305); + OkB.Caption := frxGet(1); + CancelB.Caption := frxGet(2); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxSearchDialog.FormShow(Sender: TObject); +begin + TextE.Text := LastText; +end; + +procedure TfrxSearchDialog.FormHide(Sender: TObject); +begin + if ModalResult = mrOk then + LastText := TextE.Text; +end; + +procedure TfrxSearchDialog.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +procedure TfrxSearchDialog.FormActivate(Sender: TObject); +begin + TextE.SetFocus; + TextE.SelectAll; +end; + +end. + + + +// diff --git a/official/4.8.11/Source/frxStdWizard.dfm b/official/4.8.11/Source/frxStdWizard.dfm new file mode 100644 index 0000000..ed4335d Binary files /dev/null and b/official/4.8.11/Source/frxStdWizard.dfm differ diff --git a/official/4.8.11/Source/frxStdWizard.pas b/official/4.8.11/Source/frxStdWizard.pas new file mode 100644 index 0000000..8706e7e --- /dev/null +++ b/official/4.8.11/Source/frxStdWizard.pas @@ -0,0 +1,1097 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Standard Report wizard } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxStdWizard; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Buttons, ComCtrls, ExtCtrls, frxClass, frxDesgn; + +type + TfrxStdWizard = class(TfrxCustomWizard) + public + class function GetDescription: String; override; + function Execute: Boolean; override; + end; + + TfrxDotMatrixWizard = class(TfrxCustomWizard) + public + class function GetDescription: String; override; + function Execute: Boolean; override; + end; + + TfrxStdEmptyWizard = class(TfrxCustomWizard) + public + class function GetDescription: String; override; + function Execute: Boolean; override; + end; + + TfrxDMPEmptyWizard = class(TfrxCustomWizard) + public + class function GetDescription: String; override; + function Execute: Boolean; override; + end; + + TfrxStdWizardForm = class(TForm) + Pages: TPageControl; + FieldsTab: TTabSheet; + GroupsTab: TTabSheet; + LayoutTab: TTabSheet; + FieldsLB: TListBox; + AddFieldB: TSpeedButton; + AddAllFieldsB: TSpeedButton; + RemoveFieldB: TSpeedButton; + RemoveAllFieldsB: TSpeedButton; + SelectedFieldsLB: TListBox; + SelectedFieldsL: TLabel; + FieldUpB: TSpeedButton; + FieldDownB: TSpeedButton; + AvailableFieldsLB: TListBox; + AddGroupB: TSpeedButton; + RemoveGroupB: TSpeedButton; + GroupsLB: TListBox; + GroupsL: TLabel; + GroupUpB: TSpeedButton; + GroupDownB: TSpeedButton; + AvailableFieldsL: TLabel; + BackB: TButton; + NextB: TButton; + FinishB: TButton; + FitWidthCB: TCheckBox; + Step2L: TLabel; + Step3L: TLabel; + Step4L: TLabel; + StyleTab: TTabSheet; + Step5L: TLabel; + ScrollBox1: TScrollBox; + StylePB: TPaintBox; + StyleLB: TListBox; + OrientationL: TGroupBox; + LayoutL: TGroupBox; + PortraitImg: TImage; + LandscapeImg: TImage; + PortraitRB: TRadioButton; + LandscapeRB: TRadioButton; + TabularRB: TRadioButton; + ColumnarRB: TRadioButton; + DataTab: TTabSheet; + DatasetsCB: TComboBox; + Step1L: TLabel; + NewTableB: TButton; + NewQueryB: TButton; + ScrollBox2: TScrollBox; + LayoutPB: TPaintBox; + AvailableFieldsL1: TLabel; + procedure FormCreate(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure DatasetsCBClick(Sender: TObject); + procedure AddFieldBClick(Sender: TObject); + procedure AddAllFieldsBClick(Sender: TObject); + procedure RemoveFieldBClick(Sender: TObject); + procedure RemoveAllFieldsBClick(Sender: TObject); + procedure AddGroupBClick(Sender: TObject); + procedure RemoveGroupBClick(Sender: TObject); + procedure FieldUpBClick(Sender: TObject); + procedure FieldDownBClick(Sender: TObject); + procedure GroupUpBClick(Sender: TObject); + procedure GroupDownBClick(Sender: TObject); + procedure NextBClick(Sender: TObject); + procedure BackBClick(Sender: TObject); + procedure GroupsTabShow(Sender: TObject); + procedure StylePBPaint(Sender: TObject); + procedure PortraitRBClick(Sender: TObject); + procedure PagesChange(Sender: TObject); + procedure StyleLBClick(Sender: TObject); + procedure FinishBClick(Sender: TObject); + procedure NewTableBClick(Sender: TObject); + procedure NewQueryBClick(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure LayoutPBPaint(Sender: TObject); + procedure TabularRBClick(Sender: TObject); + private + FDesigner: TfrxDesignerForm; + FDotMatrix: Boolean; + FLayoutReport: TfrxReport; + FReport: TfrxReport; + FStyleReport: TfrxReport; + FStyleSheet: TfrxStyleSheet; + procedure DrawSample(PaintBox: TPaintBox; Report: TfrxReport); + procedure FillDatasets; + procedure FillFields; + procedure NewDBItem(const wizName: String); + procedure UpdateAvailableFields; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + + +implementation + +{$R *.DFM} +{$R *.RES} + +uses + frxEditReportData, frxDsgnIntf, frxRes, frxUtils, frxDMPClass, + IniFiles, Registry, Printers; + +const + StyleReport = +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +''; + + LayoutTabularReport = +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +''; + + LayoutColumnarReport = +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +'' + +''; + + + Style = +'' + +'' + +'' + +'' + +'' + +'' + +''; + + + +{ TfrxStdWizard } + +class function TfrxStdWizard.GetDescription: String; +begin + Result := frxResources.Get('wzStd'); +end; + +function TfrxStdWizard.Execute: Boolean; +begin + with TfrxStdWizardForm.Create(Owner) do + begin + FDesigner := TfrxDesignerForm(Self.Designer); + FReport := Report; + Result := ShowModal = mrOk; + Free; + end; +end; + + +{ TfrxDotMatrixWizard } + +class function TfrxDotMatrixWizard.GetDescription: String; +begin + Result := frxResources.Get('wzDMP'); +end; + +function TfrxDotMatrixWizard.Execute: Boolean; +begin + with TfrxStdWizardForm.Create(Owner) do + begin + FDesigner := TfrxDesignerForm(Self.Designer); + FDotMatrix := True; + FReport := Report; + Result := ShowModal = mrOk; + Free; + end; +end; + + +{ TfrxStdEmptyWizard } + +class function TfrxStdEmptyWizard.GetDescription: String; +begin + Result := frxResources.Get('wzStdEmpty'); +end; + +function TfrxStdEmptyWizard.Execute: Boolean; +var + Page: TfrxPage; +begin + Result := True; + try + Designer.Lock; + Report.Clear; + Report.FileName := ''; + Report.DotMatrixReport := False; + + Page := TfrxDataPage.Create(Report); + Page.Name := 'Data'; + Page := TfrxReportPage.Create(Report); + Page.Name := 'Page1'; + TfrxReportPage(Page).SetDefaults; + finally + Designer.ReloadReport; + end; +end; + + +{ TfrxDMPEmptyWizard } + +class function TfrxDMPEmptyWizard.GetDescription: String; +begin + Result := frxResources.Get('wzDMPEmpty'); +end; + +function TfrxDMPEmptyWizard.Execute: Boolean; +var + Page: TfrxPage; +begin + Result := True; + try + Designer.Lock; + Report.Clear; + Report.FileName := ''; + Report.DotMatrixReport := True; + + Page := TfrxDataPage.Create(Report); + Page.Name := 'Data'; + Page := TfrxDMPPage.Create(Report); + Page.Name := 'Page1'; + TfrxReportPage(Page).SetDefaults; + finally + Designer.ReloadReport; + end; +end; + + +{ TfrxStdWizardForm } + +constructor TfrxStdWizardForm.Create(AOwner: TComponent); +var + s: TStringStream; +begin + inherited; + FStyleReport := TfrxReport.Create(nil); + s := TStringStream.Create(StyleReport); + FStyleReport.LoadFromStream(s); + s.Free; + FLayoutReport := TfrxReport.Create(nil); + + FStyleSheet := TfrxStyleSheet.Create; + if FileExists(ExtractFilePath(Application.ExeName) + 'wizstyle.xml') then + FStyleSheet.LoadFromFile(ExtractFilePath(Application.ExeName) + 'wizstyle.xml') + else + begin + s := TStringStream.Create(Style); + FStyleSheet.LoadFromStream(s); + s.Free; + end; +end; + +destructor TfrxStdWizardForm.Destroy; +begin + FStyleReport.Free; + FLayoutReport.Free; + FStyleSheet.Free; + inherited; +end; + +procedure TfrxStdWizardForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(5600); + DataTab.Caption := frxGet(5601); + FieldsTab.Caption := frxGet(5602); + GroupsTab.Caption := frxGet(5603); + LayoutTab.Caption := frxGet(5604); + StyleTab.Caption := frxGet(5605); + Step1L.Caption := frxGet(5606); + Step2L.Caption := frxGet(5607); + Step3L.Caption := frxGet(5608); + Step4L.Caption := frxGet(5609); + Step5L.Caption := frxGet(5610); + AddFieldB.Caption := frxGet(5611); + AddAllFieldsB.Caption := frxGet(5612); + RemoveFieldB.Caption := frxGet(5613); + RemoveAllFieldsB.Caption := frxGet(5614); + AddGroupB.Caption := frxGet(5615); + RemoveGroupB.Caption := frxGet(5616); + SelectedFieldsL.Caption := frxGet(5617); + AvailableFieldsL.Caption := frxGet(5618); + AvailableFieldsL1.Caption := frxGet(5618); + GroupsL.Caption := frxGet(5619); + OrientationL.Caption := frxGet(5620); + LayoutL.Caption := frxGet(5621); + PortraitRB.Caption := frxGet(5622); + LandscapeRB.Caption := frxGet(5623); + TabularRB.Caption := frxGet(5624); + ColumnarRB.Caption := frxGet(5625); + FitWidthCB.Caption := frxGet(5626); + BackB.Caption := frxGet(5627); + NextB.Caption := frxGet(5628); + FinishB.Caption := frxGet(5629); + NewTableB.Caption := frxGet(5630); + NewQueryB.Caption := frxGet(5631); + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxStdWizardForm.FormShow(Sender: TObject); +var + Page: TfrxPage; +begin + FDesigner.Lock; + FReport.Clear; + + Page := TfrxDataPage.Create(FReport); + Page.Name := 'Data'; + + if FDotMatrix then + Page := TfrxDMPPage.Create(FReport) else + Page := TfrxReportPage.Create(FReport); + Page.Name := 'Page1'; + TfrxReportPage(Page).SetDefaults; + FDesigner.SetReportDefaults; + FDesigner.ReloadReport; + + FillDatasets; + DatasetsCB.ItemIndex := 0; + DatasetsCBClick(nil); + + FStyleSheet.GetList(StyleLB.Items); + StyleLB.ItemIndex := 0; + StyleLBClick(nil); + + TabularRBClick(nil); + if FDotMatrix then + StyleTab.Free; +end; + +procedure TfrxStdWizardForm.FillDatasets; +var + i: Integer; + ds: TfrxDataSet; + dsList: TStringList; +begin + dsList := TStringList.Create; + FReport.GetActiveDataSetList(dsList); + dsList.Sort; + + DatasetsCB.Clear; + + for i := 0 to dsList.Count - 1 do + begin + ds := TfrxDataSet(dsList.Objects[i]); + if ds is TfrxCustomDBDataSet then + DatasetsCB.Items.AddObject(ds.UserName, ds); + end; + + dsList.Free; +end; + +procedure TfrxStdWizardForm.FillFields; +var + ds: TfrxDataSet; +begin + FieldsLB.Clear; + SelectedFieldsLB.Clear; + UpdateAvailableFields; + + if DatasetsCB.ItemIndex <> -1 then + begin + ds := TfrxDataSet(DatasetsCB.Items.Objects[DatasetsCB.ItemIndex]); + ds.GetFieldList(FieldsLB.Items); + end; + + if FieldsLB.Items.Count <> 0 then + begin + FieldsLB.ItemIndex := 0; + FieldsLB.Selected[0] := True; + end; +end; + +procedure TfrxStdWizardForm.UpdateAvailableFields; +begin + AvailableFieldsLB.Items := SelectedFieldsLB.Items; + GroupsLB.Clear; +end; + +procedure TfrxStdWizardForm.NewDBItem(const wizName: String); +var + i: Integer; + wiz: TfrxCustomWizard; +begin + for i := 0 to frxWizards.Count - 1 do + if frxWizards[i].ClassRef.ClassName = wizName then + begin + wiz := TfrxCustomWizard(frxWizards[i].ClassRef.NewInstance); + wiz.Create(FDesigner); + try + FReport.Datasets.Clear; + if wiz.Execute then + begin + FillDatasets; + DatasetsCB.ItemIndex := DatasetsCB.Items.IndexOf(FReport.Datasets[0].Dataset.UserName); + DatasetsCBClick(nil); + FReport.Datasets.Clear; + FDesigner.ReloadReport; + end; + finally + wiz.Free; + end; + break; + end; +end; + +procedure TfrxStdWizardForm.DrawSample(PaintBox: TPaintBox; Report: TfrxReport); +var + i: Integer; + c: TfrxComponent; +begin + with PaintBox do + begin + Canvas.Pen.Color := clBlack; + Canvas.Brush.Color := clWindow; + Canvas.Rectangle(0, 0, Width, Height); + + for i := 0 to Report.AllObjects.Count - 1 do + begin + c := Report.AllObjects[i]; + if c is TfrxCustomMemoView then + with TfrxCustomMemoView(c) do + Draw(Canvas, 1, 1, 10, 10); + end; + end; +end; + +procedure TfrxStdWizardForm.DatasetsCBClick(Sender: TObject); +begin + FillFields; +end; + +procedure TfrxStdWizardForm.NewTableBClick(Sender: TObject); +begin + NewDBItem('TfrxDBTableWizard'); +end; + +procedure TfrxStdWizardForm.NewQueryBClick(Sender: TObject); +begin + NewDBItem('TfrxDBQueryWizard'); +end; + +procedure TfrxStdWizardForm.AddFieldBClick(Sender: TObject); +var + i, j: Integer; +begin + if FieldsLB.ItemIndex = -1 then Exit; + + i := 0; + j := -1; + while i < FieldsLB.Items.Count do + if FieldsLB.Selected[i] then + begin + if j = -1 then + j := i; + SelectedFieldsLB.Items.Add(FieldsLB.Items[i]); + FieldsLB.Items.Delete(i); + end + else + Inc(i); + + if j = FieldsLB.Items.Count then + Dec(j); + if j <> -1 then + begin + FieldsLB.ItemIndex := j; + FieldsLB.Selected[j] := True; + end; + + UpdateAvailableFields; +end; + +procedure TfrxStdWizardForm.AddAllFieldsBClick(Sender: TObject); +begin + if FieldsLB.Items.Count = 0 then Exit; + FillFields; + SelectedFieldsLB.Items := FieldsLB.Items; + FieldsLB.Items.Clear; + UpdateAvailableFields; +end; + +procedure TfrxStdWizardForm.RemoveFieldBClick(Sender: TObject); +var + i, j: Integer; +begin + if SelectedFieldsLB.ItemIndex = -1 then Exit; + + i := 0; + j := -1; + while i < SelectedFieldsLB.Items.Count do + if SelectedFieldsLB.Selected[i] then + begin + if j = -1 then + j := i; + FieldsLB.Items.Add(SelectedFieldsLB.Items[i]); + SelectedFieldsLB.Items.Delete(i); + end + else + Inc(i); + + if j = SelectedFieldsLB.Items.Count then + Dec(j); + if j <> -1 then + begin + SelectedFieldsLB.ItemIndex := j; + SelectedFieldsLB.Selected[j] := True; + end; + + UpdateAvailableFields; +end; + +procedure TfrxStdWizardForm.RemoveAllFieldsBClick(Sender: TObject); +begin + FillFields; +end; + +procedure TfrxStdWizardForm.AddGroupBClick(Sender: TObject); +var + i: Integer; +begin + i := AvailableFieldsLB.ItemIndex; + if i = -1 then Exit; + GroupsLB.Items.Add(AvailableFieldsLB.Items[i]); + AvailableFieldsLB.Items.Delete(i); + AvailableFieldsLB.ItemIndex := i; +end; + +procedure TfrxStdWizardForm.RemoveGroupBClick(Sender: TObject); +var + i: Integer; +begin + i := GroupsLB.ItemIndex; + if i = -1 then Exit; + AvailableFieldsLB.Items.Add(GroupsLB.Items[i]); + GroupsLB.Items.Delete(i); + GroupsLB.ItemIndex := i; +end; + +procedure TfrxStdWizardForm.FieldUpBClick(Sender: TObject); +var + i: Integer; +begin + i := SelectedFieldsLB.ItemIndex; + if i < 1 then Exit; + SelectedFieldsLB.Items.Exchange(i, i - 1); + UpdateAvailableFields; +end; + +procedure TfrxStdWizardForm.FieldDownBClick(Sender: TObject); +var + i: Integer; +begin + i := SelectedFieldsLB.ItemIndex; + if (i = -1) or (SelectedFieldsLB.Items.Count = 0) or + (i = SelectedFieldsLB.Items.Count - 1) then Exit; + SelectedFieldsLB.Items.Exchange(i, i + 1); + SelectedFieldsLB.ItemIndex := i + 1; + UpdateAvailableFields; +end; + +procedure TfrxStdWizardForm.GroupUpBClick(Sender: TObject); +var + i: Integer; +begin + i := GroupsLB.ItemIndex; + if i < 1 then Exit; + GroupsLB.Items.Exchange(i, i - 1); +end; + +procedure TfrxStdWizardForm.GroupDownBClick(Sender: TObject); +var + i: Integer; +begin + i := GroupsLB.ItemIndex; + if (i = -1) or (i = GroupsLB.Items.Count - 1) then Exit; + GroupsLB.Items.Exchange(i, i + 1); + GroupsLB.ItemIndex := i + 1; +end; + +procedure TfrxStdWizardForm.NextBClick(Sender: TObject); +begin + Pages.SelectNextPage(True); + PagesChange(nil); +end; + +procedure TfrxStdWizardForm.BackBClick(Sender: TObject); +begin + Pages.SelectNextPage(False); + PagesChange(nil); +end; + +procedure TfrxStdWizardForm.PagesChange(Sender: TObject); +begin + if not FDotMatrix then + NextB.Enabled := Pages.ActivePage <> StyleTab else + NextB.Enabled := Pages.ActivePage <> LayoutTab; + BackB.Enabled := Pages.ActivePage <> DataTab; +end; + +procedure TfrxStdWizardForm.GroupsTabShow(Sender: TObject); +begin + AvailableFieldsLB.ItemIndex := 0; +end; + +procedure TfrxStdWizardForm.StylePBPaint(Sender: TObject); +begin + DrawSample(StylePB, FStyleReport); +end; + +procedure TfrxStdWizardForm.LayoutPBPaint(Sender: TObject); +begin + DrawSample(LayoutPB, FLayoutReport); +end; + +procedure TfrxStdWizardForm.PortraitRBClick(Sender: TObject); +begin + PortraitImg.Visible := PortraitRB.Checked; + LandscapeImg.Visible := LandscapeRB.Checked; +end; + +procedure TfrxStdWizardForm.StyleLBClick(Sender: TObject); +begin + FStyleReport.Styles := FStyleSheet.Find(StyleLB.Items[StyleLB.ItemIndex]); + StylePBPaint(nil); +end; + +procedure TfrxStdWizardForm.TabularRBClick(Sender: TObject); +var + s: TStringStream; +begin + if TabularRB.Checked then + s := TStringStream.Create(LayoutTabularReport) + else + s := TStringStream.Create(LayoutColumnarReport); + FLayoutReport.LoadFromStream(s); + s.Free; + FLayoutReport.Styles := FStyleSheet[0]; + LayoutPBPaint(nil); +end; + +procedure TfrxStdWizardForm.FinishBClick(Sender: TObject); +var + DataSet: TfrxDataSet; + Page: TfrxReportPage; + Band: TfrxBand; + Memo: TfrxCustomMemoView; + CurY, PageWidth, MaxHeaderWidth: Extended; + Widths, HeaderWidths, DataWidths: array of Extended; + + function Duplicate(n: Integer): String; + begin +{$IFDEF Delphi12} + Result := StringOfChar(Char('0'), n) +{$ELSE} + Result := ''; + SetLength(Result, n); + FillChar(Result[1], n, '0'); +{$ENDIF} + end; + + function CreateMemo(Parent: TfrxComponent): TfrxCustomMemoView; + begin + if FDotMatrix then + Result := TfrxDMPMemoView.Create(Parent) else + Result := TfrxMemoView.Create(Parent); + if Parent <> nil then + Result.CreateUniqueName; + end; + + procedure CreatePage; + begin + Page := TfrxReportPage(FReport.Pages[1]); + if PortraitRB.Checked then + Page.Orientation := poPortrait else + Page.Orientation := poLandscape; + PageWidth := (Page.PaperWidth - Page.LeftMargin - Page.RightMargin) * 96 / 25.4; + end; + + procedure CreateWidthsArray; + var + i, FieldsCount: Integer; + HeaderMemo, DataMemo: TfrxCustomMemoView; + MaxWidth, HeadersWidth, GapWidth: Extended; + Style: TfrxStyles; + begin + FieldsCount := AvailableFieldsLB.Items.Count; + SetLength(Widths, FieldsCount); + SetLength(HeaderWidths, FieldsCount); + SetLength(DataWidths, FieldsCount); + + HeaderMemo := CreateMemo(nil); + DataMemo := CreateMemo(nil); + if not FDotMatrix then + begin + Style := FStyleSheet.Find(StyleLB.Items[StyleLB.ItemIndex]); + HeaderMemo.ApplyStyle(Style.Find('Header')); + DataMemo.ApplyStyle(Style.Find('Data')); + end; + + MaxWidth := 0; + HeadersWidth := 0; + MaxHeaderWidth := 0; + GapWidth := 0; + for i := 0 to FieldsCount - 1 do + begin + HeaderMemo.Text := AvailableFieldsLB.Items[i]; + DataMemo.Text := Duplicate(DataSet.DisplayWidth[AvailableFieldsLB.Items[i]]); + HeaderWidths[i] := HeaderMemo.CalcWidth; + DataWidths[i] := DataMemo.CalcWidth; + if HeaderWidths[i] > DataWidths[i] then + Widths[i] := HeaderWidths[i] + else + begin + Widths[i] := DataWidths[i]; + GapWidth := GapWidth + DataWidths[i] - HeaderWidths[i]; + end; + MaxWidth := MaxWidth + Widths[i]; + HeadersWidth := HeadersWidth + HeaderWidths[i]; + if HeaderWidths[i] > MaxHeaderWidth then + MaxHeaderWidth := HeaderWidths[i]; + end; + + if FitWidthCB.Checked and (MaxWidth > PageWidth) then + begin + if HeadersWidth > PageWidth then + begin + for i := 0 to FieldsCount - 1 do + Widths[i] := HeaderWidths[i] / (HeadersWidth / PageWidth); + end + else + begin + for i := 0 to FieldsCount - 1 do + if HeaderWidths[i] < DataWidths[i] then + Widths[i] := Widths[i] - (DataWidths[i] - HeaderWidths[i]) / + GapWidth * (MaxWidth - PageWidth); + end; + end; + + HeaderMemo.Free; + DataMemo.Free; + end; + + procedure CreateTitle; + begin + Band := TfrxReportTitle.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, 0, 0, fr01cm * 7); + CurY := 30; + + Memo := CreateMemo(Band); + Memo.SetBounds(0, 0, 0, fr01cm * 6); + Memo.Align := baWidth; + Memo.HAlign := haCenter; + Memo.VAlign := vaCenter; + Memo.Text := 'Report'; + Memo.Style := 'Title'; + end; + + procedure CreateHeader; + var + i: Integer; + X, Y: Extended; + HeaderMemo: TfrxCustomMemoView; + begin + if ColumnarRB.Checked then Exit; + + Band := TfrxPageHeader.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, CurY, 0, fr01cm * 7); + + HeaderMemo := CreateMemo(Band); + HeaderMemo.SetBounds(0, 0, PageWidth, 0); + HeaderMemo.Style := 'Header line'; + + X := 0; + Y := 0; + for i := 0 to AvailableFieldsLB.Items.Count - 1 do + begin + if X + Widths[i] > PageWidth + 1 then + begin + X := 0; + Y := Y + fr01cm * 6; + end; + + Memo := CreateMemo(Band); + Memo.SetBounds(X, Y, Widths[i], fr01cm * 6); + Memo.Text := AvailableFieldsLB.Items[i]; + Memo.Style := 'Header'; + + X := X + Widths[i]; + end; + + Band.Height := Y + fr01cm * 6; + HeaderMemo.Height := Band.Height; + if FDotMatrix then + HeaderMemo.Free; + CurY := CurY + Band.Height; + end; + + procedure CreateGroupHeaders; + var + i: Integer; + begin + for i := 0 to GroupsLB.Items.Count - 1 do + begin + Band := TfrxGroupHeader.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, CurY, 0, fr01cm * 7); + TfrxGroupHeader(Band).Condition := DataSet.UserName + '."' + GroupsLB.Items[i] + '"'; + CurY := CurY + 30; + + Memo := CreateMemo(Band); + Memo.SetBounds(0, 0, 0, fr01cm * 6); + Memo.Align := baWidth; + Memo.VAlign := vaCenter; + Memo.DataSet := DataSet; + Memo.DataField := GroupsLB.Items[i]; + Memo.Style := 'Group header'; + end; + end; + + procedure CreateData; + var + i: Integer; + X, Y: Extended; + begin + Band := TfrxMasterData.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, CurY, 0, 0); + TfrxMasterData(Band).DataSet := DataSet; + CurY := CurY + 30; + + X := 0; + Y := 0; + for i := 0 to AvailableFieldsLB.Items.Count - 1 do + begin + if ColumnarRB.Checked then + begin + Memo := CreateMemo(Band); + Memo.SetBounds(0, Y, MaxHeaderWidth, fr01cm * 5); + Memo.Text := AvailableFieldsLB.Items[i]; + Memo.Style := 'Header'; + + Memo := CreateMemo(Band); + Memo.SetBounds(MaxHeaderWidth + fr01cm * 5, Y, DataWidths[i], fr01cm * 5); + Memo.DataSet := DataSet; + Memo.DataField := AvailableFieldsLB.Items[i]; + Memo.Style := 'Data'; + + Y := Y + fr01cm * 5; + end + else + begin + if X + Widths[i] > PageWidth + 1 then + begin + X := 0; + Y := Y + fr01cm * 5; + end; + + Memo := CreateMemo(Band); + Memo.SetBounds(X, Y, Widths[i], fr01cm * 5); + Memo.DataSet := DataSet; + Memo.DataField := AvailableFieldsLB.Items[i]; + Memo.Style := 'Data'; + + X := X + Widths[i]; + end; + end; + + Band.Height := Y + fr01cm * 5; + CurY := CurY + Band.Height; + end; + + procedure CreateGroupFooters; + var + i: Integer; + begin + CurY := 1000; + for i := GroupsLB.Items.Count - 1 downto 0 do + begin + Band := TfrxGroupFooter.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, CurY, 0, 0); + CurY := CurY - 30; + end; + end; + + procedure CreateFooter; + begin + Band := TfrxPageFooter.Create(Page); + Band.CreateUniqueName; + Band.SetBounds(0, 1000, 0, fr01cm * 7); + + Memo := CreateMemo(Band); + Memo.Align := baWidth; + Memo.Frame.Typ := [ftTop]; + Memo.Frame.Width := 2; + + Memo := CreateMemo(Band); + Memo.SetBounds(0, 1, 0, fr01cm * 6); + Memo.AutoWidth := True; + Memo.Text := '[Date] [Time]'; + + Memo := CreateMemo(Band); + Memo.SetBounds(100, 1, fr1cm * 2, fr01cm * 6); + Memo.Align := baRight; + Memo.HAlign := haRight; + Memo.Text := 'Page [Page#]'; + end; + +begin + try + FDesigner.Lock; + FReport.FileName := ''; + FReport.DotMatrixReport := FDotMatrix; + + DataSet := nil; + FReport.DataSets.Clear; + if DatasetsCB.ItemIndex <> -1 then + begin + DataSet := TfrxDataSet(DatasetsCB.Items.Objects[DatasetsCB.ItemIndex]); + FReport.DataSets.Add(DataSet); + end; + + CreatePage; + CreateWidthsArray; + CreateTitle; + CreateHeader; + CreateGroupHeaders; + CreateData; + CreateGroupFooters; + CreateFooter; + + if not FDotMatrix then + FReport.Styles := FStyleSheet.Find(StyleLB.Items[StyleLB.ItemIndex]); + + finally + FDesigner.ReloadReport; + Widths := nil; + HeaderWidths := nil; + DataWidths := nil; + end; +end; + +procedure TfrxStdWizardForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + + +initialization + frxWizards.Register1(TfrxStdWizard, 1); + frxWizards.Register1(TfrxStdEmptyWizard, 0); +{$IFNDEF FR_LITE} + frxWizards.Register1(TfrxDotMatrixWizard, 1); + frxWizards.Register1(TfrxDMPEmptyWizard, 0); +{$ENDIF} + +finalization + frxWizards.Unregister(TfrxStdWizard); + frxWizards.Unregister(TfrxStdEmptyWizard); +{$IFNDEF FR_LITE} + frxWizards.Unregister(TfrxDotMatrixWizard); + frxWizards.Unregister(TfrxDMPEmptyWizard); +{$ENDIF} + +end. + + +// diff --git a/official/4.8.11/Source/frxStdWizard.res b/official/4.8.11/Source/frxStdWizard.res new file mode 100644 index 0000000..cee610b Binary files /dev/null and b/official/4.8.11/Source/frxStdWizard.res differ diff --git a/official/4.8.11/Source/frxSynMemo.pas b/official/4.8.11/Source/frxSynMemo.pas new file mode 100644 index 0000000..078b0c7 --- /dev/null +++ b/official/4.8.11/Source/frxSynMemo.pas @@ -0,0 +1,2105 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Syntax memo control } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxSynMemo; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, + Forms, frxCtrls, fs_iparser, frxPopupForm; + +type + TCharAttr = (caNo, caText, caBlock, caComment, caKeyword, caString, + caNumber); + TCharAttributes = set of TCharAttr; + + TfrxCodeCompletionEvent = procedure(const Name: String; List: TStrings) of object; + + TfrxSyntaxMemo = class(TfrxScrollWin) + private + FActiveLine: Integer; + FAllowLinesChange: Boolean; + FBlockColor: TColor; + FBlockFontColor: TColor; + FBookmarks: array[0..9] of Integer; + FCharHeight: Integer; + FCharWidth: Integer; + FCommentAttr: TFont; + FCompletionForm: TfrxPopupForm; + FCompletionLB: TListBox; + FDoubleClicked: Boolean; + FDown: Boolean; + FToggleBreakPointDown: Boolean; + FGutterWidth: Integer; + FIsMonoType: Boolean; + FKeywordAttr: TFont; + FMaxLength: Integer; + FMessage: String; + FModified: Boolean; + FMoved: Boolean; + FNumberAttr: TFont; + FOffset: TPoint; + FOnChangePos: TNotifyEvent; + FOnChangeText: TNotifyEvent; + FOnCodeCompletion: TfrxCodeCompletionEvent; + FParser: TfsParser; + FPos: TPoint; + FStringAttr: TFont; + FSelEnd: TPoint; + FSelStart: TPoint; + FShowGutter: boolean; + FSynStrings: TStrings; + FSyntax: String; + FTempPos: TPoint; + FText: TStringList; + FTextAttr: TFont; + FUndo: TStringList; + FUpdatingSyntax: Boolean; + FWindowSize: TPoint; + FBreakPoints: TStringList; + function GetCharAttr(Pos: TPoint): TCharAttributes; + function GetLineBegin(Index: Integer): Integer; + function GetPlainTextPos(Pos: TPoint): Integer; + function GetPosPlainText(Pos: Integer): TPoint; + function GetRunLine(Index: Integer): Boolean; + function GetSelText: String; + function GetText: TStrings; + function LineAt(Index: Integer): String; + function LineLength(Index: Integer): Integer; + function Pad(n: Integer): String; + procedure AddSel; + procedure AddUndo; + procedure ClearSel; + procedure ClearSyntax(ClearFrom: Integer); + procedure CompletionLBDblClick(Sender: TObject); + procedure CompletionLBDrawItem(Control: TWinControl; Index: Integer; + ARect: TRect; State: TOwnerDrawState); + procedure CompletionLBKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure CorrectBookmark(Line, Delta: Integer); + procedure CorrectBreakPoints(Line, Delta: Integer); + procedure CreateSynArray(EndLine: Integer); + procedure DoBackspace; + procedure DoChange; + procedure DoChar(Ch: Char); + procedure DoCodeCompletion; + procedure DoCtrlI; + procedure DoCtrlU; + procedure DoCtrlR; + procedure DoCtrlL; + procedure DoDel; + procedure DoDown; + procedure DoEnd(Ctrl: Boolean); + procedure DoHome(Ctrl: Boolean); + procedure DoLeft; + procedure DoPgUp; + procedure DoPgDn; + procedure DoReturn; + procedure DoRight; + procedure DoUp; + procedure EnterIndent; + procedure LinesChange(Sender: TObject); + procedure SetActiveLine(Line: Integer); + procedure SetCommentAttr(Value: TFont); + procedure SetKeywordAttr(Value: TFont); + procedure SetNumberAttr(const Value: TFont); + procedure SetRunLine(Index: Integer; const Value: Boolean); + procedure SetSelText(const Value: String); + procedure SetShowGutter(Value: Boolean); + procedure SetStringAttr(Value: TFont); + procedure SetSyntax(const Value: String); + procedure SetText(Value: TStrings); + procedure SetTextAttr(Value: TFont); + procedure ShiftSelected(ShiftRight: Boolean); + procedure ShowCaretPos; + procedure TabIndent; + procedure UnIndent; + procedure UpdateScrollBar; + procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + function GetTextSelected: Boolean; + protected + procedure DblClick; override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure MouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure OnHScrollChange(Sender: TObject); override; + procedure OnVScrollChange(Sender: TObject); override; + procedure Resize; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Paint; override; + procedure CopyToClipboard; + procedure CutToClipboard; + procedure PasteFromClipboard; + procedure SelectAll; + procedure SetPos(x, y: Integer); + procedure ShowMessage(const s: String); + procedure Undo; + procedure UpdateView; + function Find(const SearchText: String; CaseSensitive: Boolean; + var SearchFrom: Integer): Boolean; + function GetPlainPos: Integer; + function GetPos: TPoint; + function IsBookmark(Line: Integer): Integer; + procedure AddBookmark(Line, Number: Integer); + procedure DeleteBookmark(Number: Integer); + procedure GotoBookmark(Number: Integer); + procedure AddBreakPoint(Number: Integer; const Condition: String); + procedure ToggleBreakPoint(Number: Integer; const Condition: String); + procedure DeleteBreakPoint(Number: Integer); + procedure DeleteF4BreakPoints; + function IsBreakPoint(Number: Integer): Boolean; + function GetBreakPointCondition(Number: Integer): String; + + property ActiveLine: Integer read FActiveLine write SetActiveLine; + property BlockColor: TColor read FBlockColor write FBlockColor; + property BlockFontColor: TColor read FBlockFontColor write FBlockFontColor; + property BreakPoints: TStringList read FBreakPoints; + property Color; + property CommentAttr: TFont read FCommentAttr write SetCommentAttr; + property Font; + property GutterWidth: Integer read FGutterWidth write FGutterWidth; + property KeywordAttr: TFont read FKeywordAttr write SetKeywordAttr; + property Modified: Boolean read FModified write FModified; + property NumberAttr: TFont read FNumberAttr write SetNumberAttr; + property RunLine[Index: Integer]: Boolean read GetRunLine write SetRunLine; + property SelText: String read GetSelText write SetSelText; + property StringAttr: TFont read FStringAttr write SetStringAttr; + property TextAttr: TFont read FTextAttr write SetTextAttr; + property Lines: TStrings read GetText write SetText; + property Syntax: String read FSyntax write SetSyntax; + property ShowGutter: boolean read FShowGutter write SetShowGutter; + property TextSelected: Boolean read GetTextSelected; + property OnChangePos: TNotifyEvent read FOnChangePos write FOnChangePos; + property OnChangeText: TNotifyEvent read FOnChangeText write FOnChangeText; + property OnCodeCompletion: TfrxCodeCompletionEvent read FOnCodeCompletion + write FOnCodeCompletion; + property OnDragDrop; + property OnDragOver; + property OnKeyDown; + end; + + +implementation + + +uses Clipbrd, fs_itools, frxXML; + +const + SQLKeywords = + 'active,after,all,alter,and,any,as,asc,ascending,at,auto,' + + 'base_name,before,begin,between,by,cache,call,cast,check,column,commit,' + + 'committed,computed,conditional,constraint,containing,count,create,' + + 'current,cursor,database,debug,declare,default,delete,desc,descending,' + + 'distinct,do,domain,drop,else,end,entry_point,escape,exception,execute,' + + 'exists,exit,external,extract,filter,for,foreign,from,full,function,' + + 'generator,grant,group,having,if,in,inactive,index,inner,insert,into,is,' + + 'isolation,join,key,left,level,like,merge,names,no,not,null,of,on,only,' + + 'or,order,outer,parameter,password,plan,position,primary,privileges,' + + 'procedure,protected,read,retain,returns,revoke,right,rollback,schema,' + + 'select,set,shadow,shared,snapshot,some,suspend,table,then,to,' + + 'transaction,trigger,uncommitted,union,unique,update,user,using,values,' + + 'view,wait,when,where,while,with,work'; + + WordChars = ['a'..'z', 'A'..'Z', 'а'..'я', 'А'..'Я', '0'..'9', '_']; + + +{$IFDEF Delphi12} +function IsUnicodeChar(Chr: Char): Boolean; +begin + Result := ((Chr >= Char($007F)) and (Chr <= Char($FFFF))); +end; +{$ENDIF} + +{ TfrxSyntaxMemo } + +constructor TfrxSyntaxMemo.Create(AOwner: TComponent); +var + i: Integer; +begin + inherited; + DoubleBuffered := True; + TabStop := True; + Cursor := crIBeam; + Color := clWindow; + + FBreakPoints := TStringList.Create; + + FBlockColor := clHighlight; + FBlockFontColor := clHighlightText; + + FCommentAttr := TFont.Create; + FCommentAttr.Color := clNavy; + FCommentAttr.Style := [fsItalic]; + + FKeywordAttr := TFont.Create; + FKeywordAttr.Color := clWindowText; + FKeywordAttr.Style := [fsBold]; + + FNumberAttr := TFont.Create; + FNumberAttr.Color := clGreen; + FNumberAttr.Style := []; + + FStringAttr := TFont.Create; + FStringAttr.Color := clNavy; + FStringAttr.Style := []; + + FTextAttr := TFont.Create; + FTextAttr.Color := clWindowText; + FTextAttr.Style := []; + + Font.Size := 10; + Font.Name := 'Courier New'; + + FText := TStringList.Create; + FParser := TfsParser.Create; + FParser.SkipSpace := False; + FParser.UseY := False; + FSynStrings := TStringList.Create; + FUndo := TStringList.Create; + FText.Add(''); + FText.OnChange := LinesChange; + FMaxLength := 1024; + FMoved := True; + SetPos(1, 1); + + ShowGutter := True; + OnMouseWheelUp := MouseWheelUp; + OnMouseWheelDown := MouseWheelDown; + + FActiveLine := -1; + for i := 0 to 9 do + FBookmarks[i] := -1; +end; + +destructor TfrxSyntaxMemo.Destroy; +begin + FBreakPoints.Free; + FCommentAttr.Free; + FKeywordAttr.Free; + FNumberAttr.Free; + FStringAttr.Free; + FTextAttr.Free; + FText.Free; + FUndo.Free; + FSynStrings.Free; + FParser.Free; + inherited; +end; + +procedure TfrxSyntaxMemo.WMKillFocus(var Msg: TWMKillFocus); +begin + inherited; + HideCaret(Handle); + DestroyCaret; +end; + +procedure TfrxSyntaxMemo.WMSetFocus(var Msg: TWMSetFocus); +begin + inherited; + CreateCaret(Handle, 0, 2, FCharHeight); + ShowCaretPos; +end; + +procedure TfrxSyntaxMemo.ShowCaretPos; +begin + if FPos.X > FOffset.X then + begin + SetCaretPos(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, + FCharHeight * (FPos.Y - 1 - FOffset.Y)); + ShowCaret(Handle); + end + else + SetCaretPos(-100, -100); + if Assigned(FOnChangePos) then + FOnChangePos(Self); +end; + +procedure TfrxSyntaxMemo.CMFontChanged(var Message: TMessage); +var + b: TBitmap; +begin + FCommentAttr.Size := Font.Size; + FCommentAttr.Name := Font.Name; + FKeywordAttr.Size := Font.Size; + FKeywordAttr.Name := Font.Name; + FNumberAttr.Size := Font.Size; + FNumberAttr.Name := Font.Name; + FStringAttr.Size := Font.Size; + FStringAttr.Name := Font.Name; + FTextAttr.Size := Font.Size; + FTextAttr.Name := Font.Name; + + b := TBitmap.Create; + with b.Canvas do + begin + Font.Assign(Self.Font); + Font.Style := [fsBold]; + FCharHeight := TextHeight('Wg') + 1; + FCharWidth := TextWidth('W'); + FIsMonoType := Pos('COURIER NEW', AnsiUppercase(Self.Font.Name)) <> 0; + end; + b.Free; +end; + +procedure TfrxSyntaxMemo.Resize; +begin + inherited; + if FCharWidth = 0 then Exit; + FWindowSize := Point((ClientWidth - FGutterWidth) div FCharWidth, + ClientHeight div FCharHeight); + HorzPage := FWindowSize.X; + VertPage := FWindowSize.Y; + UpdateScrollBar; +end; + +procedure TfrxSyntaxMemo.UpdateScrollBar; +begin + VertRange := FText.Count; + HorzRange := FMaxLength; + LargeChange := FWindowSize.Y; + VertPosition := FOffset.Y; + HorzPosition := FOffset.X; +end; + +function TfrxSyntaxMemo.GetText: TStrings; +//var +// i: Integer; +begin +// FAllowLinesChange := False; +// for i := 0 to FText.Count - 1 do +// FText[i] := LineAt(i); + Result := FText; + FAllowLinesChange := True; +end; + +function TfrxSyntaxMemo.GetPlainPos: Integer; +begin + Result := GetPlainTextPos(FPos); +end; + +function TfrxSyntaxMemo.GetPos: TPoint; +begin + Result := FPos; +end; + +procedure TfrxSyntaxMemo.SetText(Value: TStrings); +begin + FAllowLinesChange := True; + FText.Assign(Value); +end; + +procedure TfrxSyntaxMemo.SetSyntax(const Value: String); +var + sl: TStringList; + + procedure GetGrammar; + var + Grammar: TfrxXMLDocument; + ss: TStringStream; + ParserRoot, xi: TfrxXMLItem; + i: Integer; + Name, PropText: String; + begin + Grammar := TfrxXMLDocument.Create; + ss := TStringStream.Create(fsGetLanguage(Value)); + Grammar.LoadFromStream(ss); + ss.Free; + + ParserRoot := Grammar.Root.FindItem('parser'); + xi := ParserRoot.FindItem('keywords'); + for i := 0 to xi.Count - 1 do + FParser.Keywords.Add(xi[i].Name); + + for i := 0 to ParserRoot.Count - 1 do + begin + Name := LowerCase(ParserRoot[i].Name); + PropText := ParserRoot[i].Prop['text']; + if Name = 'identchars' then + FParser.ConstructCharset(PropText) + else if Name = 'commentline1' then + FParser.CommentLine1 := PropText + else if Name = 'commentline2' then + FParser.CommentLine2 := PropText + else if Name = 'commentblock1' then + FParser.CommentBlock1 := PropText + else if Name = 'commentblock2' then + FParser.CommentBlock2 := PropText + else if Name = 'stringquotes' then + FParser.StringQuotes := PropText + else if Name = 'hexsequence' then + FParser.HexSequence := PropText + end; + + Grammar.Free; + end; + +begin + FSyntax := Value; + FParser.Keywords.Clear; + sl := TStringList.Create; + if AnsiCompareText(Value, 'SQL') = 0 then + begin + sl.CommaText := SQLKeywords; + FParser.Keywords.Assign(sl); + FParser.CommentLine1 := '--'; + FParser.CommentLine2 := ''; + FParser.CommentBlock1 := '/*,*/'; + FParser.CommentBlock2 := ''; + FParser.StringQuotes := '"'; + FParser.HexSequence := '0x'; + end + else + begin + fsGetLanguageList(sl); + if sl.IndexOf(Value) <> -1 then + GetGrammar; + end; + + ClearSyntax(1); + sl.Free; +end; + +procedure TfrxSyntaxMemo.SetCommentAttr(Value: TFont); +begin + FCommentAttr.Assign(Value); + Repaint; +end; + +procedure TfrxSyntaxMemo.SetKeywordAttr(Value: TFont); +begin + FKeywordAttr.Assign(Value); + Repaint; +end; + +procedure TfrxSyntaxMemo.SetNumberAttr(const Value: TFont); +begin + FNumberAttr.Assign(Value); + Repaint; +end; + +procedure TfrxSyntaxMemo.SetStringAttr(Value: TFont); +begin + FStringAttr.Assign(Value); + Repaint; +end; + +procedure TfrxSyntaxMemo.SetTextAttr(Value: TFont); +begin + FTextAttr.Assign(Value); + Repaint; +end; + +procedure TfrxSyntaxMemo.SetActiveLine(Line: Integer); +begin + FActiveLine := Line; + Repaint; +end; + +procedure TfrxSyntaxMemo.DoChange; +begin + FModified := True; + if Assigned(FOnChangeText) then + FOnChangeText(Self); +end; + +procedure TfrxSyntaxMemo.LinesChange(Sender: TObject); +begin + if FAllowLinesChange then + begin + FAllowLinesChange := False; + if FText.Count = 0 then + FText.Add(''); + ClearSyntax(1); + FMoved := True; + FUndo.Clear; + FPos := Point(1, 1); + FOffset := Point(0, 0); + ClearSel; + ShowCaretPos; + UpdateScrollBar; + end; +end; + +procedure TfrxSyntaxMemo.ShowMessage(const s: String); +begin + FMessage := s; + Repaint; +end; + +procedure TfrxSyntaxMemo.CopyToClipboard; +begin + if FSelStart.X <> 0 then + Clipboard.AsText := SelText; +end; + +procedure TfrxSyntaxMemo.CutToClipboard; +begin + if FSelStart.X <> 0 then + begin + Clipboard.AsText := SelText; + SelText := ''; + end; + CorrectBookmark(FSelStart.Y, FSelStart.Y - FSelEnd.Y); + Repaint; +end; + +procedure TfrxSyntaxMemo.PasteFromClipboard; +begin + SelText := Clipboard.AsText; +end; + +procedure TfrxSyntaxMemo.SelectAll; +begin + SetPos(0, 0); + FSelStart := FPos; + SetPos(LineLength(FText.Count - 1) + 1, FText.Count); + FSelEnd := FPos; + Repaint; +end; + +function TfrxSyntaxMemo.LineAt(Index: Integer): String; +begin + if Index < FText.Count then + Result := TrimRight(FText[Index]) + else + Result := ''; +end; + +function TfrxSyntaxMemo.LineLength(Index: Integer): Integer; +begin + Result := Length(LineAt(Index)); +end; + +function TfrxSyntaxMemo.Pad(n: Integer): String; +begin + Result := ''; + SetLength(Result, n); +{$IFDEF Delphi12} + Result := StringOfChar(Char(' '), n); +{$ELSE} + FillChar(Result[1], n, ' '); +{$ENDIF} +end; + +procedure TfrxSyntaxMemo.AddUndo; +begin + if not FMoved then exit; + FUndo.Add(Format('%5d%5d', [FPos.X, FPos.Y]) + FText.Text); + if FUndo.Count > 32 then + FUndo.Delete(0); + FMoved := False; +end; + +procedure TfrxSyntaxMemo.Undo; +var + s: String; +begin + FMoved := True; + if FUndo.Count = 0 then exit; + s := FUndo[FUndo.Count - 1]; + FPos.X := StrToInt(Copy(s, 1, 5)); + FPos.Y := StrToInt(Copy(s, 6, 5)); + FAllowLinesChange := False; + FText.Text := Copy(s, 11, Length(s) - 10); + FAllowLinesChange := True; + FUndo.Delete(FUndo.Count - 1); + SetPos(FPos.X, FPos.Y); + ClearSyntax(1); + DoChange; +end; + +function TfrxSyntaxMemo.GetPlainTextPos(Pos: TPoint): Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Pos.Y - 2 do + Result := Result + Length(FText[i]) + 2; + Result := Result + Pos.X; +end; + +function TfrxSyntaxMemo.GetPosPlainText(Pos: Integer): TPoint; +var + i: Integer; + s: String; +begin + Result := Point(0, 1); + s := FText.Text; + i := 1; + while i <= Pos do + if s[i] = #13 then + begin + Inc(i, 2); + if i <= Pos then + begin + Inc(Result.Y); + Result.X := 0; + end + else + Inc(Result.X); + end + else + begin + Inc(i); + Inc(Result.X); + end; +end; + +function TfrxSyntaxMemo.GetLineBegin(Index: Integer): Integer; +var + s: String; +begin + s := FText[Index]; + Result := 1; + if Trim(s) <> '' then + for Result := 1 to Length(s) do + if s[Result] <> ' ' then + break; +end; + +procedure TfrxSyntaxMemo.TabIndent; +begin + SelText := Pad((FPos.X div 8 + 1) * 8 - FPos.X); +end; + +procedure TfrxSyntaxMemo.EnterIndent; +var + res: Integer; +begin + if Trim(FText[FPos.Y - 1]) = '' then + res := FPos.X else + res := GetLineBegin(FPos.Y - 1); + + if FPos.X = 1 then + CorrectBookmark(FPos.Y - 1, 1) else + CorrectBookmark(FPos.Y, 1); + + FPos := Point(1, FPos.Y + 1); + SelText := Pad(res - 1); +end; + +procedure TfrxSyntaxMemo.UnIndent; +var + i, res: Integer; +begin + i := FPos.Y - 2; + res := FPos.X - 1; + CorrectBookmark(FPos.Y, -1); + while i >= 0 do + begin + res := GetLineBegin(i); + if (res < FPos.X) and (Trim(FText[i]) <> '') then + break else + Dec(i); + end; + FSelStart := FPos; + FSelEnd := FPos; + Dec(FSelEnd.X, FPos.X - res); + SelText := ''; +end; + +procedure TfrxSyntaxMemo.ShiftSelected(ShiftRight: Boolean); +var + i, ib, ie: Integer; + s: String; + Shift: Integer; +begin + AddUndo; + if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + ib := FSelStart.Y - 1; + ie := FSelEnd.Y - 1; + end + else + begin + ib := FSelEnd.Y - 1; + ie := FSelStart.Y - 1; + end; + if FSelEnd.X = 1 then + Dec(ie); + + Shift := 2; + if not ShiftRight then + for i := ib to ie do + begin + s := FText[i]; + if (Trim(s) <> '') and (GetLineBegin(i) - 1 < Shift) then + Shift := GetLineBegin(i) - 1; + end; + + for i := ib to ie do + begin + s := FText[i]; + if ShiftRight then + s := Pad(Shift) + s + else if Trim(s) <> '' then + Delete(s, 1, Shift); + FText[i] := s; + end; + + ClearSyntax(FSelStart.Y); + DoChange; +end; + +function TfrxSyntaxMemo.GetSelText: String; +var + p1, p2: TPoint; + i: Integer; +begin + if FSelStart.X = 0 then + begin + Result := ''; + Exit; + end; + + if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + p1 := FSelStart; + p2 := FSelEnd; + Dec(p2.X); + end + else + begin + p1 := FSelEnd; + p2 := FSelStart; + Dec(p2.X); + end; + + if LineLength(p1.Y - 1) < p1.X then + begin + Inc(p1.Y); + p1.X := 1; + end; + if LineLength(p2.Y - 1) < p2.X then + p2.X := LineLength(p2.Y - 1); + + i := GetPlainTextPos(p1); + Result := Copy(FText.Text, i, GetPlainTextPos(p2) - i + 1); +end; + +procedure TfrxSyntaxMemo.SetSelText(const Value: String); +var + p1, p2, p3: TPoint; + i: Integer; + s: String; +begin + AddUndo; + if FSelStart.X = 0 then + begin + p1 := FPos; + p2 := p1; + Dec(p2.X); + end + else if FSelStart.X + FSelStart.Y * FMaxLength < FSelEnd.X + FSelEnd.Y * FMaxLength then + begin + p1 := FSelStart; + p2 := FSelEnd; + Dec(p2.X); + end + else + begin + p1 := FSelEnd; + p2 := FSelStart; + Dec(p2.X); + end; + FAllowLinesChange := False; + if LineLength(p1.Y - 1) < p1.X then + FText[p1.Y - 1] := FText[p1.Y - 1] + Pad(p1.X - LineLength(p1.Y - 1) + 1); + if LineLength(p2.Y - 1) < p2.X then + p2.X := LineLength(p2.Y - 1); + + i := GetPlainTextPos(p1); + s := FText.Text; + Delete(s, i, GetPlainTextPos(p2) - i + 1); + Insert(Value, s, i); + FText.Text := s; + p3 := GetPosPlainText(i + Length(Value)); + FAllowLinesChange := True; + CorrectBookmark(FPos.Y, p3.y - FPos.Y); + + SetPos(p3.X, p3.Y); + FSelStart.X := 0; + DoChange; + i := p3.Y; + if p2.Y < i then + i := p2.Y; + if p1.Y < i then + i := p1.Y; + ClearSyntax(i); +end; + +procedure TfrxSyntaxMemo.ClearSel; +begin + if FSelStart.X <> 0 then + begin + FSelStart := Point(0, 0); + Repaint; + end; +end; + +procedure TfrxSyntaxMemo.AddSel; +begin + if FSelStart.X = 0 then + FSelStart := FTempPos; + FSelEnd := FPos; + Repaint; +end; + +procedure TfrxSyntaxMemo.SetPos(x, y: Integer); +begin + if FMessage <> '' then + begin + FMessage := ''; + Repaint; + end; + + if x > FMaxLength then x := FMaxLength; + if x < 1 then x := 1; + if y > FText.Count then y := FText.Count; + if y < 1 then y := 1; + + FPos := Point(x, y); + if (FWindowSize.X = 0) or (FWindowSize.Y = 0) then exit; + + if FOffset.Y >= FText.Count then + FOffset.Y := FText.Count - 1; + + if FPos.X > FOffset.X + FWindowSize.X then + begin + Inc(FOffset.X, FPos.X - (FOffset.X + FWindowSize.X)); + Repaint; + end + else if FPos.X <= FOffset.X then + begin + Dec(FOffset.X, FOffset.X - FPos.X + 1); + Repaint; + end + else if FPos.Y > FOffset.Y + FWindowSize.Y then + begin + Inc(FOffset.Y, FPos.Y - (FOffset.Y + FWindowSize.Y)); + Repaint; + end + else if FPos.Y <= FOffset.Y then + begin + Dec(FOffset.Y, FOffset.Y - FPos.Y + 1); + Repaint; + end; + + ShowCaretPos; + UpdateScrollBar; + +end; + +procedure TfrxSyntaxMemo.OnHScrollChange(Sender: TObject); +begin + FOffset.X := HorzPosition; + if FOffset.X > 1024 then + FOffset.X := 1024; + ShowCaretPos; + Repaint; +end; + +procedure TfrxSyntaxMemo.OnVScrollChange(Sender: TObject); +begin + FOffset.Y := VertPosition; + if FOffset.Y > FText.Count then + FOffset.Y := FText.Count; + ShowCaretPos; + Repaint; +end; + +procedure TfrxSyntaxMemo.DblClick; +var + s: String; +begin + FDoubleClicked := True; + DoCtrlL; + FSelStart := FPos; + s := LineAt(FPos.Y - 1); + if s <> '' then +{$IFDEF Delphi12} + while CharInSet(s[FPos.X], WordChars) + or IsUnicodeChar(s[FPos.X]) do +{$ELSE} + while s[FPos.X] in WordChars do +{$ENDIF} + Inc(FPos.X); + FSelEnd := FPos; + Repaint; +end; + +procedure TfrxSyntaxMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + if FDoubleClicked then + begin + FDoubleClicked := False; + Exit; + end; + + FMoved := True; + if not Focused then + SetFocus; + FDown := True; + if X < FGutterWidth then + FToggleBreakPointDown := True; + X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; + Y := Y div FCharHeight + 1 + FOffset.Y; + FTempPos := FPos; + SetPos(X, Y); + if ssShift in Shift then + AddSel + else + ClearSel; +end; + +procedure TfrxSyntaxMemo.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + if FDown then + begin + FTempPos := FPos; + FPos.X := (X - FGutterWidth) div FCharWidth + 1 + FOffset.X; + FPos.Y := Y div FCharHeight + 1 + FOffset.Y; + if (FPos.X <> FTempPos.X) or (FPos.Y <> FTempPos.Y) then + begin + SetPos(FPos.X, FPos.Y); + AddSel; + end; + end; + + if X < FGutterWidth then + Cursor := crArrow + else + Cursor := crIBeam; +end; + +procedure TfrxSyntaxMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + FDown := False; + if (X < FGutterWidth) and (FToggleBreakPointDown) then + ToggleBreakPoint(FPos.Y, ''); + FToggleBreakPointDown := False; +end; + +procedure TfrxSyntaxMemo.KeyDown(var Key: Word; Shift: TShiftState); +var + MyKey: Boolean; + TempPos: Tpoint; +begin + inherited; + FAllowLinesChange := False; + + FTempPos := FPos; + MyKey := True; + case Key of + vk_Left: + if ssCtrl in Shift then + DoCtrlL else + DoLeft; + + vk_Right: + if ssCtrl in Shift then + DoCtrlR else + DoRight; + + vk_Up: + DoUp; + + vk_Down: + DoDown; + + vk_Home: + DoHome(ssCtrl in Shift); + + vk_End: + DoEnd(ssCtrl in Shift); + + vk_Prior: + DoPgUp; + + vk_Next: + DoPgDn; + + vk_Return: + if Shift = [] then + DoReturn; + + vk_Delete: + begin + if ssCtrl in Shift then // Ctrl+Del delete word before cursor + begin + TempPos := FPos; + Inc(FPos.X); + DblClick; + FDoubleClicked := False; + if FSelEnd.X <= TempPos.X then + begin + FSelStart := TempPos; + FSelEnd := TempPos; + dec(FSelStart.X); + end; + end; + if ssShift in Shift then + CutToClipboard else + DoDel; + end; + + vk_Back: + begin + if ssCtrl in Shift then // Ctrl+BackSpace delete word after cursor + begin + DblClick; + FDoubleClicked := False; + end; + DoBackspace; + end; + + vk_Insert: + if ssCtrl in Shift then + CopyToClipboard + else if ssShift in Shift then + PasteFromClipboard; + + vk_Tab: + TabIndent; + + else + MyKey := False; + end; + + if Shift = [ssCtrl] then + if Key = 65 then // Ctrl+A Select all + begin + SelectAll; + end + else if Key = 89 then // Ctrl+Y Delete line + begin + if FText.Count > FPos.Y then + begin + FMoved := True; + AddUndo; + FText.Delete(FPos.Y - 1); + CorrectBookmark(FPos.Y, -1); + DoChange; + end + else if FText.Count = FPos.Y then + begin + FMoved := True; + AddUndo; + FText[FPos.Y - 1] := ''; + FPos.X := 1; + SetPos(FPos.X, FPos.Y); + DoChange; + end; + ClearSyntax(FPos.Y); + end + else if Key in [48..57] then + GotoBookmark(Key - 48) + else if Key = 32 then // Ctrl+Space code completion + begin + if Assigned(FOnCodeCompletion) then + DoCodeCompletion; + MyKey := True; + end + else if Key = Ord('C') then + begin + CopyToClipboard; + MyKey := True; + end + else if Key = Ord('V') then + begin + PasteFromClipboard; + MyKey := True; + end + else if Key = Ord('X') then + begin + CutToClipboard; + MyKey := True; + end + else if Key = Ord('I') then + begin + DoCtrlI; + MyKey := True; + end + else if Key = Ord('U') then + begin + DoCtrlU; + MyKey := True; + end + else if Key = Ord('Z') then + begin + Undo; + MyKey := True; + end; + + if Shift = [ssCtrl, ssShift] then + if Key in [48..57] then + if IsBookmark(FPos.Y - 1) < 0 then + AddBookmark(FPos.Y - 1, Key - 48) + else if IsBookmark(FPos.Y - 1) = (Key - 48) then + DeleteBookmark(Key - 48); + + if Key in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Home, vk_End, vk_Prior, vk_Next] then + begin + FMoved := True; + if ssShift in Shift then + AddSel else + ClearSel; + end + else if Key in [vk_Return, vk_Delete, vk_Back, vk_Insert, vk_Tab] then + FMoved := True; + + if MyKey then + Key := 0; +end; + +procedure TfrxSyntaxMemo.KeyPress(var Key: Char); +var + MyKey, ControlKeyDown: Boolean; +begin + inherited; + + ControlKeyDown := (((GetKeyState(VK_LCONTROL) and not $7FFF) <> 0) or + ((GetKeyState(VK_RCONTROL) and not $7FFF) <> 0)) and + (GetKeyState(VK_RMENU) >= 0); + MyKey := True; + +{$IFDEF Delphi12} + if ((Key = #32) and not ControlKeyDown) or (CharInSet(Key, [#33..#255])) + or IsUnicodeChar(Key) and not((Key = #127) and ControlKeyDown) then +{$ELSE} + if ((Key = #32) and not ControlKeyDown) or (Key in [#33..#255]) and not((Key = #127) and ControlKeyDown) then +{$ENDIF} + begin + DoChar(Key); + FMoved := False; + end + else + MyKey := False; + + if MyKey then + Key := #0; +end; + +procedure TfrxSyntaxMemo.DoCodeCompletion; +var + p: TPoint; + + function GetCompletionString: String; + var + i: Integer; + s: String; + fl1, fl2: Boolean; + fl3, fl4: Integer; + begin + Result := ''; + s := LineAt(FPos.Y - 1); + s := Trim(Copy(s, 1, FPos.X)); + + fl1 := False; + fl2 := False; + fl3 := 0; + fl4 := 0; + + i := Length(s); + while i > 1 do + begin + Dec(i); + if (s[i] = '''') and not fl2 then + fl1 := not fl1 + else if (s[i] = '"') and not fl1 then + fl2 := not fl2 + else if not fl1 and not fl2 and (s[i] = ')') then + Inc(fl3) + else if not fl1 and not fl2 and (s[i] = '(') and (fl3 > 0) then + Dec(fl3) + else if not fl1 and not fl2 and (s[i] = ']') then + Inc(fl4) + else if not fl1 and not fl2 and (s[i] = '[') and (fl4 > 0) then + Dec(fl4) + else if not fl1 and not fl2 and (fl3 = 0) and (fl4 = 0) then +{$IFDEF Delphi12} + if CharInSet(s[i], ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', ' ']) + or IsUnicodeChar(s[i]) then +{$ELSE} + if s[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', ' '] then +{$ENDIF} + Result := s[i] + Result + else + break; + end; + end; + +begin + FCompletionForm := TfrxPopupForm.Create(Self); + FCompletionLB := TListBox.Create(FCompletionForm); + with FCompletionLB do + begin + Parent := FCompletionForm; + Ctl3D := False; + Align := alClient; + ItemHeight := ItemHeight + 2; + Style := lbOwnerDrawFixed; + Sorted := True; + OnDblClick := CompletionLBDblClick; + OnKeyDown := CompletionLBKeyDown; + OnDrawItem := CompletionLBDrawItem; + if Assigned(FOnCodeCompletion) then + FOnCodeCompletion(GetCompletionString, Items); + + p := Self.ClientToScreen( + Point(FCharWidth * (FPos.X - 1 - FOffset.X) + FGutterWidth, + FCharHeight * (FPos.Y - FOffset.Y))); + FCompletionForm.SetBounds(p.X, p.Y, 300, 100); + FCompletionForm.Show; + end; +end; + +procedure TfrxSyntaxMemo.CompletionLBDblClick(Sender: TObject); +var + s, s1: String; + i: Integer; + stepBack: Boolean; +begin + if FCompletionLB.ItemIndex <> -1 then + begin + s := FCompletionLB.Items[FCompletionLB.ItemIndex]; + i := 2; +{$IFDEF Delphi12} + while (i <= Length(s)) and ((CharInSet(s[i], WordChars) or IsUnicodeChar(s[i]))) do +{$ELSE} + while (i <= Length(s)) and (s[i] in WordChars) do +{$ENDIF} + Inc(i); + s1 := Copy(s, 1, i - 1); + stepBack := (i <= Length(s)) and (s[i] = '('); + if stepBack then + s1 := s1 + '()'; + SelText := s1; + if stepBack then + DoLeft; + end; + FCompletionForm.Close; +end; + +procedure TfrxSyntaxMemo.CompletionLBKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_ESCAPE then + FCompletionForm.Close; + if Key = VK_RETURN then + CompletionLBDblClick(nil); +end; + +procedure TfrxSyntaxMemo.CompletionLBDrawItem(Control: TWinControl; Index: Integer; + ARect: TRect; State: TOwnerDrawState); +var + i, w: Integer; + s: String; +begin + with FCompletionLB.Canvas do + begin + FillRect(ARect); + if Index <> -1 then + begin + i := Integer(FCompletionLB.Items.Objects[Index]); + s := ''; + Font.Color := clFuchsia; + if Pos('Constructor', FCompletionLB.Items[Index]) <> 0 then + s := 'constructor' + else + case i of + 0: begin s := 'var'; Font.Color := clBlue; end; + 1: begin s := 'property'; Font.Color := clBlue; end; + 2: s := 'procedure'; + 3: s := 'function'; + end; + + if odSelected in State then + Font.Color := clWhite; + Font.Style := []; + TextOut(ARect.Left + 2, ARect.Top + 2, s); + w := TextWidth('constructor'); + Font.Color := clBlack; + if odSelected in State then + Font.Color := clWhite; + Font.Style := [fsBold]; + s := FCompletionLB.Items[Index]; + i := 1; +{$IFDEF Delphi12} + while (i <= Length(s)) and ((CharInSet(s[i], WordChars)) + or IsUnicodeChar(s[i])) do +{$ELSE} + while (i <= Length(s)) and (s[i] in WordChars) do +{$ENDIF} + Inc(i); + s := Copy(s, 1, i - 1); + TextOut(ARect.Left + w + 6, ARect.Top + 2, s); + w := w + TextWidth(s); + Font.Style := []; + s := Copy(FCompletionLB.Items[Index], i, 255); + if Pos(': Constructor', s) <> 0 then + s := Copy(s, 1, Pos(': Constructor', s) - 1); + TextOut(ARect.Left + w + 6, ARect.Top + 2, s); + end; + end; +end; + +procedure TfrxSyntaxMemo.DoLeft; +begin + Dec(FPos.X); + if FPos.X < 1 then + FPos.X := 1; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoRight; +begin + Inc(FPos.X); + if FPos.X > FMaxLength then + FPos.X := FMaxLength; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoUp; +begin + Dec(FPos.Y); + if FPos.Y < 1 then + FPos.Y := 1; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoDown; +begin + Inc(FPos.Y); + if FPos.Y > FText.Count then + FPos.Y := FText.Count; + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoHome(Ctrl: Boolean); +begin + if Ctrl then + SetPos(1, 1) else + SetPos(1, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoEnd(Ctrl: Boolean); +begin + if Ctrl then + SetPos(LineLength(FText.Count - 1) + 1, FText.Count) else + SetPos(LineLength(FPos.Y - 1) + 1, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoPgUp; +begin + if FOffset.Y > FWindowSize.Y then + begin + Dec(FOffset.Y, FWindowSize.Y - 1); + Dec(FPos.Y, FWindowSize.Y - 1); + end + else + begin + if FOffset.Y > 0 then + begin + Dec(FPos.Y, FOffset.Y); + FOffset.Y := 0; + end + else + FPos.Y := 1; + end; + SetPos(FPos.X, FPos.Y); + Repaint; +end; + +procedure TfrxSyntaxMemo.DoPgDn; +begin + if FOffset.Y + FWindowSize.Y < FText.Count then + begin + Inc(FOffset.Y, FWindowSize.Y - 1); + Inc(FPos.Y, FWindowSize.Y - 1); + end + else + begin + FOffset.Y := FText.Count; + FPos.Y := FText.Count; + end; + SetPos(FPos.X, FPos.Y); + Repaint; +end; + +procedure TfrxSyntaxMemo.DoReturn; +var + s: String; +begin + s := LineAt(FPos.Y - 1); + FText[FPos.Y - 1] := Copy(s, 1, FPos.X - 1); + FText.Insert(FPos.Y, Copy(s, FPos.X, FMaxLength)); + EnterIndent; +end; + +procedure TfrxSyntaxMemo.DoDel; +var + s: String; +begin + FMessage := ''; + if FSelStart.X <> 0 then + SelText := '' + else + begin + s := FText[FPos.Y - 1]; + AddUndo; + if FPos.X <= LineLength(FPos.Y - 1) then + begin + Delete(s, FPos.X, 1); + FText[FPos.Y - 1] := s; + end + else if FPos.Y < FText.Count then + begin + s := s + Pad(FPos.X - Length(s) - 1) + LineAt(FPos.Y); + FText[FPos.Y - 1] := s; + FText.Delete(FPos.Y); + CorrectBookmark(FPos.Y, -1); + end; + UpdateScrollBar; + ClearSyntax(FPos.Y); + DoChange; + end; +end; + +procedure TfrxSyntaxMemo.DoBackspace; +var + s: String; +begin + FMessage := ''; + if FSelStart.X <> 0 then + SelText := '' + else + begin + s := FText[FPos.Y - 1]; + if FPos.X > 1 then + begin + if (GetLineBegin(FPos.Y - 1) = FPos.X) or (Trim(s) = '') then + UnIndent + else + begin + AddUndo; + if Trim(s) <> '' then + begin + Delete(s, FPos.X - 1, 1); + FText[FPos.Y - 1] := s; + DoLeft; + end + else + DoHome(False); + ClearSyntax(FPos.Y); + DoChange; + end; + end + else if FPos.Y > 1 then + begin + AddUndo; + CorrectBookmark(FPos.Y, -1); + s := LineAt(FPos.Y - 2); + FText[FPos.Y - 2] := s + FText[FPos.Y - 1]; + FText.Delete(FPos.Y - 1); + SetPos(Length(s) + 1, FPos.Y - 1); + ClearSyntax(FPos.Y); + DoChange; + end; + end; +end; + +procedure TfrxSyntaxMemo.DoCtrlI; +begin + if FSelStart.X <> 0 then + ShiftSelected(True); +end; + +procedure TfrxSyntaxMemo.DoCtrlU; +begin + if FSelStart.X <> 0 then + ShiftSelected(False); +end; + +procedure TfrxSyntaxMemo.DoCtrlL; +var + i: Integer; + s: String; +begin + s := FText.Text; + i := Length(LineAt(FPos.Y - 1)); + if FPos.X > i then + FPos.X := i; + + i := GetPlainTextPos(FPos); + + Dec(i); +{$IFDEF Delphi12} + while (i > 0) and not ((CharInSet(s[i], WordChars)) + or IsUnicodeChar(s[i])) do +{$ELSE} + while (i > 0) and not (s[i] in WordChars) do +{$ENDIF} + if s[i] = #13 then + break else + Dec(i); +{$IFDEF Delphi12} + while (i > 0) and ((CharInSet(s[i], WordChars)) + or IsUnicodeChar(s[i])) do +{$ELSE} + while (i > 0) and (s[i] in WordChars) do +{$ENDIF} + Dec(i); + Inc(i); + + FPos := GetPosPlainText(i); + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoCtrlR; +var + i: Integer; + s: String; +begin + s := FText.Text; + i := Length(LineAt(FPos.Y - 1)); + if FPos.X > i then + begin + DoDown; + DoHome(False); + FPos.X := 0; + end; + + i := GetPlainTextPos(FPos); + +{$IFDEF Delphi12} + while (i < Length(s)) and ((CharInSet(s[i], WordChars)) + or IsUnicodeChar(s[i])) do +{$ELSE} + while (i < Length(s)) and (s[i] in WordChars) do +{$ENDIF} + Inc(i); +{$IFDEF Delphi12} + while (i < Length(s)) and not ((CharInSet(s[i], WordChars)) + or IsUnicodeChar(s[i])) do +{$ELSE} + while (i < Length(s)) and not (s[i] in WordChars) do +{$ENDIF} + if s[i] = #13 then + begin + while (i > 1) and (s[i - 1] = ' ') do + Dec(i); + break; + end + else + Inc(i); + + FPos := GetPosPlainText(i); + SetPos(FPos.X, FPos.Y); +end; + +procedure TfrxSyntaxMemo.DoChar(Ch: Char); +begin + SelText := Ch; +end; + +function TfrxSyntaxMemo.GetCharAttr(Pos: TPoint): TCharAttributes; + + function IsBlock: Boolean; + var + p1, p2, p3: Integer; + begin + Result := False; + if FSelStart.X = 0 then Exit; + + p1 := FSelStart.X + FSelStart.Y * FMaxLength; + p2 := FSelEnd.X + FSelEnd.Y * FMaxLength; + if p1 > p2 then + begin + p3 := p1; + p1 := p2; + p2 := p3; + end; + p3 := Pos.X + Pos.Y * FMaxLength; + Result := (p3 >= p1) and (p3 < p2); + end; + + function CharAttr: TCharAttr; + var + s: String; + begin + if Pos.Y - 1 < FSynStrings.Count then + begin + s := FSynStrings[Pos.Y - 1]; + if Pos.X <= Length(s) then + Result := TCharAttr(Ord(s[Pos.X])) else + Result := caText; + end + else + Result := caText; + end; + +begin + Result := [CharAttr]; + if IsBlock then + Result := Result + [caBlock]; +end; + +procedure TfrxSyntaxMemo.Paint; +var + i, j, j1: Integer; + a, a1: TCharAttributes; + s: String; + + procedure SetAttr(a: TCharAttributes; Line: Integer); + begin + with Canvas do + begin + Brush.Color := Color; + + if caText in a then + Font.Assign(FTextAttr); + + if caComment in a then + Font.Assign(FCommentAttr); + + if caKeyword in a then + Font.Assign(FKeywordAttr); + + if caNumber in a then + Font.Assign(FNumberAttr); + + if caString in a then + Font.Assign(FStringAttr); + + if (caBlock in a) or (Line = FActiveLine - 1) then + begin + Brush.Color := FBlockColor; + Font.Color := FBlockFontColor; + end; + + Font.Charset := Self.Font.Charset; + end; + end; + + procedure MyTextOut(x, y: Integer; const s: String); + var + i: Integer; + begin + if FIsMonoType then + begin + Canvas.FillRect(Rect(x, y, x + Length(s) * FCharWidth, y + FCharHeight)); + Canvas.TextOut(x, y, s) + end + else + with Canvas do + begin + FillRect(Rect(x, y, x + Length(s) * FCharWidth, y + FCharHeight)); + for i := 1 to Length(s) do + TextOut(x + (i - 1) * FCharWidth, y, s[i]); + MoveTo(x + Length(s) * FCharWidth, y); + end; + end; + + procedure DrawLineMarks(Line, Y: Integer); + begin + if not FShowGutter then Exit; + if IsBookmark(Line) >= 0 then + with Canvas do + begin + Brush.Color := clBlack; + FillRect(Rect(13, Y + 3, 23, Y + 14)); + Brush.Color := clGreen; + FillRect(Rect(12, Y + 4, 22, Y + 15)); + Font.Name := 'Tahoma'; + Font.Color := clWhite; + Font.Style := [fsBold]; + Font.Size := 7; + TextOut(14, Y + 4, IntToStr(IsBookmark(Line))); + end; + if RunLine[Line + 1] then + with Canvas do + begin + Brush.Color := clBlue; + Pen.Color := clBlack; + Ellipse(4, Y + 7, 8, Y + 11); + Pixels[5, Y + 7] := clAqua; + Pixels[4, Y + 8] := clAqua; + end; + if IsBreakPoint(Line + 1) then + with Canvas do + begin + Brush.Color := clRed; + Pen.Color := clRed; + Ellipse(2, Y + 4, 13, Y + 15); + end; + end; + +begin + inherited; + + with Canvas do + begin + Brush.Color := clBtnFace; + FillRect(Rect(0, 0, FGutterWidth - 2, Height)); + Pen.Color := clBtnHighlight; + MoveTo(FGutterWidth - 4, 0); + LineTo(FGutterWidth - 4, Height + 1); + + if FUpdatingSyntax then Exit; + CreateSynArray(FOffset.Y + FWindowSize.Y - 1); + + for i := FOffset.Y to FOffset.Y + FWindowSize.Y - 1 do + begin + if i >= FText.Count then break; + + s := FText[i]; + PenPos := Point(FGutterWidth, (i - FOffset.Y) * FCharHeight); + j1 := FOffset.X + 1; + a := GetCharAttr(Point(j1, i + 1)); + a1 := a; + + for j := j1 to FOffset.X + FWindowSize.X do + begin + if j > Length(s) then break; + + a1 := GetCharAttr(Point(j, i + 1)); + if a1 <> a then + begin + SetAttr(a, i); + MyTextOut(PenPos.X, PenPos.Y, Copy(FText[i], j1, j - j1)); + a := a1; + j1 := j; + end; + end; + + SetAttr(a, i); + MyTextOut(PenPos.X, PenPos.Y, Copy(s, j1, FMaxLength)); + if (caBlock in GetCharAttr(Point(1, i + 1))) or (i = FActiveLine - 1) then + MyTextOut(PenPos.X, PenPos.Y, Pad(FWindowSize.X - Length(s) - FOffset.X + 3)); + + DrawLineMarks(i, PenPos.Y); + end; + + if FMessage <> '' then + begin + Font.Name := 'Tahoma'; + Font.Color := clWhite; + Font.Style := [fsBold]; + Font.Size := 8; + Brush.Color := clMaroon; + FillRect(Rect(0, ClientHeight - TextHeight('|') - 6, ClientWidth, ClientHeight)); + TextOut(6, ClientHeight - TextHeight('|') - 5, FMessage); + end + end; +end; + +procedure TfrxSyntaxMemo.ClearSyntax(ClearFrom: Integer); +begin + Dec(ClearFrom); + if ClearFrom < 1 then + ClearFrom := 1; + FUpdatingSyntax := True; + while FSynStrings.Count > ClearFrom - 1 do + FSynStrings.Delete(FSynStrings.Count - 1); + FUpdatingSyntax := False; + Repaint; +end; + +procedure TfrxSyntaxMemo.CreateSynArray(EndLine: Integer); +var + i, j, n, Max: Integer; + FSyn, s: String; + attr: TCharAttr; +begin + if EndLine >= FText.Count then + EndLine := FText.Count - 1; + if EndLine <= FSynStrings.Count - 1 then Exit; + + FUpdatingSyntax := True; + FAllowLinesChange := False; + + for i := FSynStrings.Count to EndLine do + FSynStrings.Add(FText[i]); + FSyn := FSynStrings.Text; + FParser.Text := FText.Text; + Max := Length(FSyn); + + for i := Length(FSyn) downto 1 do + if FSyn[i] = Chr(Ord(caText)) then + begin + j := i; + while (j > 1) and (FSyn[j] = Chr(Ord(caText))) do + Dec(j); + FParser.Position := j + 1; + break; + end; + + while FParser.Position < Max do + begin + n := FParser.Position; + FParser.SkipSpaces; + for i := n to FParser.Position - 1 do + if i <= Max then + if FSyn[i] > #31 then + FSyn[i] := Chr(Ord(caComment)); + + attr := caText; + n := FParser.Position; + s := FParser.GetWord; + if s <> '' then + begin + if FParser.IsKeyword(s) then + attr := caKeyword; + end + else + begin + s := FParser.GetNumber; + if s <> '' then + attr := caNumber + else + begin + s := FParser.GetString; + if s <> '' then + attr := caString else + FParser.Position := FParser.Position + 1 + end + end; + + for i := n to FParser.Position - 1 do + if i <= Max then + if FSyn[i] > #31 then + FSyn[i] := Chr(Ord(attr)); + end; + + FSynStrings.Text := FSyn; + FUpdatingSyntax := False; + FAllowLinesChange := True; +end; + +procedure TfrxSyntaxMemo.UpdateView; +begin + Invalidate; +end; + +procedure TfrxSyntaxMemo.MouseWheelUp(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + VertPosition := VertPosition - SmallChange; +end; + +procedure TfrxSyntaxMemo.MouseWheelDown(Sender: TObject; + Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); +begin + VertPosition := VertPosition + SmallChange; +end; + +procedure TfrxSyntaxMemo.SetShowGutter(Value: Boolean); +begin + FShowGutter := Value; + if Value then + FGutterWidth := 30 else + FGutterWidth := 0; + Repaint; +end; + +function TfrxSyntaxMemo.IsBookmark(Line: Integer): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to 9 do + if FBookmarks[i] = Line then + begin + Result := i; + break; + end; +end; + +procedure TfrxSyntaxMemo.AddBookmark(Line, Number: Integer); +begin + if Number < Length(FBookmarks) then + begin + FBookmarks[Number] := Line; + Repaint; + end; +end; + +procedure TfrxSyntaxMemo.DeleteBookmark(Number: Integer); +begin + if Number < Length(FBookmarks) then + begin + FBookmarks[Number] := -1; + Repaint; + end; +end; + +procedure TfrxSyntaxMemo.CorrectBookmark(Line, Delta: Integer); +var + i: Integer; +begin + if Delta = 0 then exit; + CorrectBreakPoints(Line, Delta); + for i := 0 to Length(FBookmarks) - 1 do + if FBookmarks[i] >= Line then + Inc(FBookmarks[i], Delta); +end; + +procedure TfrxSyntaxMemo.GotoBookmark(Number : Integer); +begin + if Number < Length(FBookmarks) then + if FBookmarks[Number] >= 0 then + SetPos(0, FBookmarks[Number] + 1); +end; + +function TfrxSyntaxMemo.GetRunLine(Index: Integer): Boolean; +begin + if (Index < 1) or (Index > FText.Count) then + Result := False else + Result := FText.Objects[Index - 1] = Pointer(1); +end; + +procedure TfrxSyntaxMemo.SetRunLine(Index: Integer; const Value: Boolean); +begin + if (Index < 1) or (Index > FText.Count) then Exit; + if Value then + FText.Objects[Index - 1] := Pointer(1) else + FText.Objects[Index - 1] := Pointer(0); +end; + +function TfrxSyntaxMemo.Find(const SearchText: String; + CaseSensitive: Boolean; var SearchFrom: Integer): Boolean; +var + i: Integer; + s: String; +begin + i := 0; + Result := False; + if FText.Count > 1 then + begin + s := FText.Text; + if SearchFrom = 0 then + SearchFrom := 1; + s := Copy(s, SearchFrom, Length(s) - SearchFrom + 1); + if CaseSensitive then + begin + i := Pos(SearchText, s); + if i <> 0 then + Result := True; + end + else + begin + i := Pos(AnsiUpperCase(SearchText), AnsiUpperCase(s)); + if i <> 0 then + Result := True; + end; + end; + + if Result then + begin + Inc(SearchFrom, i); + FSelStart := GetPosPlainText(SearchFrom - 1); + FSelEnd := Point(FSelStart.X + Length(SearchText), FSelStart.Y); + Inc(SearchFrom, Length(SearchText)); + SetPos(FSelStart.X, FSelStart.Y); + Repaint; + end; +end; + +procedure TfrxSyntaxMemo.AddBreakPoint(Number: Integer; const Condition: String); +begin + FBreakPoints.AddObject(Condition, TObject(Number)); + Repaint; +end; + +procedure TfrxSyntaxMemo.ToggleBreakPoint(Number: Integer; const Condition: String); +begin + if IsBreakPoint(Number) then + DeleteBreakPoint(Number) + else + AddBreakPoint(Number, Condition); +end; + +procedure TfrxSyntaxMemo.DeleteBreakPoint(Number: Integer); +begin + if IsBreakPoint(Number) then + FBreakPoints.Delete(FBreakPoints.IndexOfObject(TObject(Number))); + Repaint; +end; + +function TfrxSyntaxMemo.IsBreakPoint(Number: Integer): Boolean; +begin + Result := FBreakPoints.IndexOfObject(TObject(Number)) <> -1; +end; + +function TfrxSyntaxMemo.GetBreakPointCondition(Number: Integer): String; +begin + Result := ''; + if IsBreakPoint(Number) then + Result := FBreakPoints[FBreakPoints.IndexOfObject(TObject(Number))]; +end; + +procedure TfrxSyntaxMemo.DeleteF4BreakPoints; +var + i: Integer; +begin + i := 0; + while i < FBreakPoints.Count do + if FBreakPoints[i] = 'F4' then + FBreakPoints.Delete(i) + else + Inc(i); +end; + +procedure TfrxSyntaxMemo.CorrectBreakPoints(Line, Delta: Integer); +var + i, bPos: Integer; +begin +// FBreakPoints[FBreakPoints.IndexOfObject(TObject(Number))] + for i := 0 to FBreakPoints.Count - 1 do + begin + bPos := Integer(FBreakPoints.Objects[i]); + if bPos >= Line then + begin + Inc(bPos, Delta); + FBreakPoints.Objects[i] := TObject(bPos); + end; + end; +end; + +function TfrxSyntaxMemo.GetTextSelected: Boolean; +begin +// + Result := True;// FSelStart + +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxTee10.bdsproj b/official/4.8.11/Source/frxTee10.bdsproj new file mode 100644 index 0000000..833a6b8 --- /dev/null +++ b/official/4.8.11/Source/frxTee10.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + frxTee10.dpk + + + 7.0 + + + diff --git a/official/4.8.11/Source/frxTee10.dpk b/official/4.8.11/Source/frxTee10.dpk new file mode 100644 index 0000000..6c04d4c --- /dev/null +++ b/official/4.8.11/Source/frxTee10.dpk @@ -0,0 +1,52 @@ +// Package file for Delphi 2006 + +package frxTee10; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE710, TEEUI710, {$ENDIF} +{$IFDEF TeeChartStd8}TEE810, TEEUI810, {$ENDIF} +{$IFDEF TeeChart4} TEE410, TEEPRO410, {$ENDIF} +{$IFDEF TeeChart5} TEE510, TEEPRO510, {$ENDIF} +{$IFDEF TeeChart6} TEE610, TEEPRO610, {$ENDIF} +{$IFDEF TeeChart7} TEE710, TEEPRO710, {$ENDIF} +{$IFDEF TeeChart8} TEE810, TEEPRO810, {$ENDIF} + fs10, + fsTee10, + frx10; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee11.bdsproj b/official/4.8.11/Source/frxTee11.bdsproj new file mode 100644 index 0000000..e0fc17b --- /dev/null +++ b/official/4.8.11/Source/frxTee11.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + frxTee11.dpk + + + 7.0 + + + diff --git a/official/4.8.11/Source/frxTee11.dpk b/official/4.8.11/Source/frxTee11.dpk new file mode 100644 index 0000000..bf712b7 --- /dev/null +++ b/official/4.8.11/Source/frxTee11.dpk @@ -0,0 +1,52 @@ +// Package file for Delphi 2007 + +package frxTee11; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE711, TEEUI711, {$ENDIF} +{$IFDEF TeeChartStd8}TEE811, TEEUI811, {$ENDIF} +{$IFDEF TeeChart4} TEE411, TEEPRO411, {$ENDIF} +{$IFDEF TeeChart5} TEE511, TEEPRO511, {$ENDIF} +{$IFDEF TeeChart6} TEE611, TEEPRO611, {$ENDIF} +{$IFDEF TeeChart7} TEE711, TEEPRO711, {$ENDIF} +{$IFDEF TeeChart8} TEE811, TEEPRO811, {$ENDIF} + fs11, + fsTee11, + frx11; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee12.bdsproj b/official/4.8.11/Source/frxTee12.bdsproj new file mode 100644 index 0000000..97d3994 --- /dev/null +++ b/official/4.8.11/Source/frxTee12.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + frxTee12.dpk + + + 7.0 + + + diff --git a/official/4.8.11/Source/frxTee12.dpk b/official/4.8.11/Source/frxTee12.dpk new file mode 100644 index 0000000..60102e7 --- /dev/null +++ b/official/4.8.11/Source/frxTee12.dpk @@ -0,0 +1,52 @@ +// Package file for Delphi 2008 + +package frxTee12; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE712, TEEUI712, {$ENDIF} +{$IFDEF TeeChartStd8}TEE812, TEEUI812, {$ENDIF} +{$IFDEF TeeChart4} TEE412, TEEPRO412, {$ENDIF} +{$IFDEF TeeChart5} TEE512, TEEPRO512, {$ENDIF} +{$IFDEF TeeChart6} TEE612, TEEPRO612, {$ENDIF} +{$IFDEF TeeChart7} TEE712, TEEPRO712, {$ENDIF} +{$IFDEF TeeChart8} TEE812, TEEPRO812, {$ENDIF} + fs12, + fsTee12, + frx12; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee14.bdsproj b/official/4.8.11/Source/frxTee14.bdsproj new file mode 100644 index 0000000..b1c6a02 --- /dev/null +++ b/official/4.8.11/Source/frxTee14.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + frxTee14.dpk + + + 7.0 + + + diff --git a/official/4.8.11/Source/frxTee14.dpk b/official/4.8.11/Source/frxTee14.dpk new file mode 100644 index 0000000..3b64c09 --- /dev/null +++ b/official/4.8.11/Source/frxTee14.dpk @@ -0,0 +1,51 @@ +// Package file for Delphi 2008 + +package frxTee14; + +{$I frx.inc} +{$I tee.inc} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE714, TEEUI714, {$ENDIF} +{$IFDEF TeeChartStd8}TEE814, TEEUI814, {$ENDIF} +{$IFDEF TeeChart4} TEE414, TEEPRO414, {$ENDIF} +{$IFDEF TeeChart5} TEE514, TEEPRO514, {$ENDIF} +{$IFDEF TeeChart6} TEE614, TEEPRO614, {$ENDIF} +{$IFDEF TeeChart7} TEE714, TEEPRO714, {$ENDIF} +{$IFDEF TeeChart8} TEE814, TEEPRO814, {$ENDIF} + fs14, + fsTee14, + frx14; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee4.bpk b/official/4.8.11/Source/frxTee4.bpk new file mode 100644 index 0000000..c246e5b --- /dev/null +++ b/official/4.8.11/Source/frxTee4.bpk @@ -0,0 +1,189 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = frxTee4.bpl +OBJFILES = frxRegTee.obj frxTee4.obj frxChart.obj frxChartEditor.obj frxChartRTTI.obj +RESFILES = frx4.res frxReg.dcr +RESDEPEN = $(RESFILES) +LIBFILES = +LIBRARIES = +SPARELIBS = VCL40.lib +PACKAGES = vcl40.bpi vclsmp40.bpi vcljpg40.bpi tee40.bpi teeui40.bpi vclx40.bpi fs4.bpi fsTee4.bpi frx4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release;..\FastScript;..\FastQB +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -O2 -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -a8 \ + -k- -vi -c -b- -w-par -w-inl -Vx -tWM -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$Y- -$L- -$D- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zn +LFLAGS = -L$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -D"FastReport 4.0 Tee Components" -aa \ + -Tpp -x -Gn -Gl -Gi +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName=Fast Reports Inc. +FileDescription=FastReport +FileVersion=4.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=4.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxTee4.cpp b/official/4.8.11/Source/frxTee4.cpp new file mode 100644 index 0000000..bb0c6a4 --- /dev/null +++ b/official/4.8.11/Source/frxTee4.cpp @@ -0,0 +1,28 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("frx4.res"); +USEPACKAGE("vcl40.bpi"); +USEUNIT("frxRegTee.pas"); +USEUNIT("frxChart.pas"); +USEUNIT("frxChartEditor.pas"); +USEUNIT("frxChartRTTI.pas"); +USERES("frxReg.dcr"); +USEPACKAGE("vclsmp40.bpi"); +USEPACKAGE("vclx40.bpi"); +USEPACKAGE("vcljpg40.bpi"); +USEPACKAGE("tee40.bpi"); +USEPACKAGE("teeui40.bpi"); +USEPACKAGE("fs4.bpi"); +USEPACKAGE("fsTee4.bpi"); +USEPACKAGE("frx4.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxTee4.dpk b/official/4.8.11/Source/frxTee4.dpk new file mode 100644 index 0000000..69a523d --- /dev/null +++ b/official/4.8.11/Source/frxTee4.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 4 + +package frxTee4; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL40, +{$IFDEF TeeChartStd} TEE40, TEEUI40, {$ENDIF} +{$IFDEF TeeChart4} TEE44, TEEPRO44, {$ENDIF} +{$IFDEF TeeChart5} TEE54, TEEPRO54, {$ENDIF} +{$IFDEF TeeChart6} TEE64, TEEPRO64, {$ENDIF} +{$IFDEF TeeChart7} TEE74, TEEPRO74, {$ENDIF} +{$IFDEF TeeChart8} TEE84, TEEPRO84, {$ENDIF} + fs4, + fsTee4, + frx4; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee5.bpk b/official/4.8.11/Source/frxTee5.bpk new file mode 100644 index 0000000..5838bc8 --- /dev/null +++ b/official/4.8.11/Source/frxTee5.bpk @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName=Fast Reports Inc. +FileDescription=FastReport +FileVersion=4.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=4.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + + \ No newline at end of file diff --git a/official/4.8.11/Source/frxTee5.cpp b/official/4.8.11/Source/frxTee5.cpp new file mode 100644 index 0000000..2d987a5 --- /dev/null +++ b/official/4.8.11/Source/frxTee5.cpp @@ -0,0 +1,28 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("frx5.res"); +USEUNIT("frxRegTee.pas"); +USEUNIT("frxChart.pas"); +USEUNIT("frxChartEditor.pas"); +USEUNIT("frxChartRTTI.pas"); +USERES("frxReg.dcr"); +USEPACKAGE("vcl50.bpi"); +USEPACKAGE("vclsmp50.bpi"); +USEPACKAGE("vclx50.bpi"); +USEPACKAGE("vcljpg50.bpi"); +USEPACKAGE("tee50.bpi"); +USEPACKAGE("teeui50.bpi"); +USEPACKAGE("fs5.bpi"); +USEPACKAGE("fsTee5.bpi"); +USEPACKAGE("frx5.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/official/4.8.11/Source/frxTee5.dpk b/official/4.8.11/Source/frxTee5.dpk new file mode 100644 index 0000000..4228d0e --- /dev/null +++ b/official/4.8.11/Source/frxTee5.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 5 + +package frxTee5; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL50, +{$IFDEF TeeChartStd} TEE50, TEEUI50, {$ENDIF} +{$IFDEF TeeChart4} TEE45, TEEPRO45, {$ENDIF} +{$IFDEF TeeChart5} TEE55, TEEPRO55, {$ENDIF} +{$IFDEF TeeChart6} TEE65, TEEPRO65, {$ENDIF} +{$IFDEF TeeChart7} TEE75, TEEPRO75, {$ENDIF} +{$IFDEF TeeChart8} TEE85, TEEPRO85, {$ENDIF} + fs5, + fsTee5, + frx5; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee6.bpk b/official/4.8.11/Source/frxTee6.bpk new file mode 100644 index 0000000..7866c5a --- /dev/null +++ b/official/4.8.11/Source/frxTee6.bpk @@ -0,0 +1,139 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 + +[Version Info Keys] +CompanyName=Fast Reports Inc. +FileDescription=FastReport +FileVersion=4.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=4.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\Projects;$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\Projects;$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/official/4.8.11/Source/frxTee6.cpp b/official/4.8.11/Source/frxTee6.cpp new file mode 100644 index 0000000..48ce892 --- /dev/null +++ b/official/4.8.11/Source/frxTee6.cpp @@ -0,0 +1,18 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- + +// Package source. +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/official/4.8.11/Source/frxTee6.dpk b/official/4.8.11/Source/frxTee6.dpk new file mode 100644 index 0000000..c66fe01 --- /dev/null +++ b/official/4.8.11/Source/frxTee6.dpk @@ -0,0 +1,50 @@ +// Package file for Delphi 6 + +package frxTee6; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChart4} TEE46, TEEPRO46, {$ENDIF} +{$IFDEF TeeChart5} TEE56, TEEPRO56, {$ENDIF} +{$IFDEF TeeChart6} TEE66, TEEPRO66, {$ENDIF} +{$IFDEF TeeChart7} TEE76, TEEPRO76, {$ENDIF} +{$IFDEF TeeChart8} TEE86, TEEPRO86, {$ENDIF} + fs6, + fsTee6, + frx6; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee7.dpk b/official/4.8.11/Source/frxTee7.dpk new file mode 100644 index 0000000..e83e9f8 --- /dev/null +++ b/official/4.8.11/Source/frxTee7.dpk @@ -0,0 +1,52 @@ +// Package file for Delphi 7 + +package frxTee7; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE77, TEEUI77, {$ENDIF} +{$IFDEF TeeChartStd8}TEE87, TEEUI87, {$ENDIF} +{$IFDEF TeeChart4} TEE47, TEEPRO47, {$ENDIF} +{$IFDEF TeeChart5} TEE57, TEEPRO57, {$ENDIF} +{$IFDEF TeeChart6} TEE67, TEEPRO67, {$ENDIF} +{$IFDEF TeeChart7} TEE77, TEEPRO77, {$ENDIF} +{$IFDEF TeeChart8} TEE87, TEEPRO87, {$ENDIF} + fs7, + fsTee7, + frx7; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxTee9.bdsproj b/official/4.8.11/Source/frxTee9.bdsproj new file mode 100644 index 0000000..ee432f3 --- /dev/null +++ b/official/4.8.11/Source/frxTee9.bdsproj @@ -0,0 +1,19 @@ +п»ї + + + + + + + + + + + frxTee9.dpk + + + 7.0 + + + diff --git a/official/4.8.11/Source/frxTee9.dpk b/official/4.8.11/Source/frxTee9.dpk new file mode 100644 index 0000000..1efc205 --- /dev/null +++ b/official/4.8.11/Source/frxTee9.dpk @@ -0,0 +1,52 @@ +// Package file for Delphi 2005 + +package frxTee9; + +{$I frx.inc} +{$I tee.inc} + +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + VCL, +{$IFDEF TeeChartStd} TEE, TEEUI, {$ENDIF} +{$IFDEF TeeChartStd7}TEE79, TEEUI79, {$ENDIF} +{$IFDEF TeeChartStd8}TEE89, TEEUI89, {$ENDIF} +{$IFDEF TeeChart4} TEE49, TEEPRO49, {$ENDIF} +{$IFDEF TeeChart5} TEE59, TEEPRO59, {$ENDIF} +{$IFDEF TeeChart6} TEE69, TEEPRO69, {$ENDIF} +{$IFDEF TeeChart7} TEE79, TEEPRO79, {$ENDIF} +{$IFDEF TeeChart8} TEE89, TEEPRO89, {$ENDIF} + fs9, + fsTee9, + frx9; + +contains + frxChart in 'frxChart.pas', + frxChartEditor in 'frxChartEditor.pas', + frxChartHelpers in 'frxChartHelpers.pas', + frxChartRTTI in 'frxChartRTTI.pas'; + +end. diff --git a/official/4.8.11/Source/frxUnicodeCtrls.pas b/official/4.8.11/Source/frxUnicodeCtrls.pas new file mode 100644 index 0000000..d429327 --- /dev/null +++ b/official/4.8.11/Source/frxUnicodeCtrls.pas @@ -0,0 +1,704 @@ +{*******************************************************} +{ The Delphi Unicode Controls Project } +{ } +{ http://home.ccci.org/wolbrink } +{ } +{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) } +{ } +{*******************************************************} + +unit frxUnicodeCtrls; + +interface + +{$I frx.inc} + +uses Windows, Messages, Classes, Controls, Forms, StdCtrls, frxRichEdit; + +type + TUnicodeEdit = class(TEdit) + private + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + function GetSelText: WideString; reintroduce; + public + property SelText: WideString read GetSelText write SetSelText; + property Text: WideString read GetText write SetText; + end; + + TUnicodeMemo = class(TMemo) + private + procedure SetSelText(const Value: WideString); + function GetText: WideString; + procedure SetText(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + function GetSelText: WideString; reintroduce; + public + property SelText: WideString read GetSelText write SetSelText; + property Text: WideString read GetText write SetText; + end; + + TRxUnicodeRichEdit = class(TRxRichEdit) + {$IFDEF Delphi12}; + {$ELSE} + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + end; + {$ENDIF} + +implementation + +uses SysUtils, Graphics, Imm, RichEdit; + +const + UNICODE_CLASS_EXT = '.UnicodeClass'; + ANSI_UNICODE_HOLDER = $FF; + +var + UnicodeCreationControl: TWinControl = nil; + Win32PlatformIsUnicode: Boolean; + Win32PlatformIsXP: Boolean; + +{$IFDEF Delphi6} +function MakeObjectInstance(Method: TWndMethod): Pointer; +begin + Result := Classes.MakeObjectInstance(Method); +end; + +procedure FreeObjectInstance(ObjectInstance: Pointer); +begin + Classes.FreeObjectInstance(ObjectInstance); +end; +{$ENDIF} + +function IsUnicodeCreationControl(Handle: HWND): Boolean; +begin + Result := (UnicodeCreationControl <> nil) + and (UnicodeCreationControl.HandleAllocated) + and (UnicodeCreationControl.Handle = Handle); +end; + +function WMNotifyFormatResult(FromHandle: HWND): Integer; +begin + if Win32PlatformIsUnicode + and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then + Result := NFR_UNICODE + else + Result := NFR_ANSI; +end; + +function IsTextMessage(Msg: UINT): Boolean; +begin + // WM_CHAR is omitted because of the special handling it receives + Result := (Msg = WM_SETTEXT) + or (Msg = WM_GETTEXT) + or (Msg = WM_GETTEXTLENGTH); +end; + +procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Msg = WM_CHAR); + Assert(Unused = 0); + if (CharCode > Word(High(AnsiChar))) then begin + Unused := CharCode; + CharCode := ANSI_UNICODE_HOLDER; + end; + end; +end; + +procedure RestoreWMCharMsg(var Message: TMessage); +begin + with TWMChar(Message) do begin + Assert(Message.Msg = WM_CHAR); + if (Unused > 0) + and (CharCode = ANSI_UNICODE_HOLDER) then + CharCode := Unused; + Unused := 0; + end; +end; + +//----------------------------------------------------------------------------------- +type + TAccessControl = class(TControl); + TAccessWinControl = class(TWinControl); + + TWinControlTrap = class(TComponent) + private + WinControl_ObjectInstance: Pointer; + ObjectInstance: Pointer; + DefObjectInstance: Pointer; + function IsInSubclassChain(Control: TWinControl): Boolean; + procedure SubClassWindowProc; + private + FControl: TAccessWinControl; + Handle: THandle; + PrevWin32Proc: Pointer; + PrevDefWin32Proc: Pointer; + PrevWindowProc: TWndMethod; + private + LastWin32Msg: UINT; + Win32ProcLevel: Integer; + IDEWindow: Boolean; + DestroyTrap: Boolean; + TestForNull: Boolean; + FoundNull: Boolean; +// {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc: TWndMethod; +/// {$ENDIF} + procedure Win32Proc(var Message: TMessage); + procedure DefWin32Proc(var Message: TMessage); + procedure WindowProc(var Message: TMessage); + private +{$IFDEF Delphi12} + procedure SubClassControl(Params_Caption: PWideChar); +{$ELSE} + procedure SubClassControl(Params_Caption: PAnsiChar); +{$ENDIF} + + procedure UnSubClassUnicodeControl; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +constructor TWinControlTrap.Create(AOwner: TComponent); +begin + FControl := TAccessWinControl(AOwner as TWinControl); + inherited Create(nil); + FControl.FreeNotification(Self); + + WinControl_ObjectInstance := MakeObjectInstance(FControl.MainWndProc); + ObjectInstance := MakeObjectInstance(Win32Proc); + DefObjectInstance := MakeObjectInstance(DefWin32Proc); +end; + +destructor TWinControlTrap.Destroy; +begin + FreeObjectInstance(ObjectInstance); + FreeObjectInstance(DefObjectInstance); + FreeObjectInstance(WinControl_ObjectInstance); + inherited; +end; + +procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FControl) and (Operation = opRemove) then begin + FControl := nil; + if Win32ProcLevel = 0 then + Free + else + DestroyTrap := True; + end; +end; + +procedure TWinControlTrap.SubClassWindowProc; +begin + if not IsInSubclassChain(FControl) then begin + PrevWindowProc := FControl.WindowProc; + FControl.WindowProc := Self.WindowProc; + end; +// {$IFDEF TNT_VERIFY_WINDOWPROC} + LastVerifiedWindowProc := FControl.WindowProc; +// {$ENDIF} +end; + + +{$IFDEF Delphi12} +procedure TWinControlTrap.SubClassControl(Params_Caption: PWideChar); +{$ELSE} +procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar); +{$ENDIF} +begin + // initialize trap object + Handle := FControl.Handle; + PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC)); + PrevDefWin32Proc := FControl.DefWndProc; + + // subclass Window Procedures + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance)); + FControl.DefWndProc := DefObjectInstance; + SubClassWindowProc; +end; + +function SameWndMethod(A, B: TWndMethod): Boolean; +begin + Result := @A = @B; +end; + +var + PendingRecreateWndTrapList: TList = nil; + +procedure TWinControlTrap.UnSubClassUnicodeControl; +begin + // restore window procs (restore WindowProc only if we are still the direct subclass) + if SameWndMethod(FControl.WindowProc, Self.WindowProc) then + FControl.WindowProc := PrevWindowProc; + TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc; + SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc)); + + if IDEWindow then + DestroyTrap := True + else if not (csDestroying in FControl.ComponentState) then + // control not being destroyed, probably recreating window + PendingRecreateWndTrapList.Add(Self); +end; + +var + Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak. + Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. } + +procedure TWinControlTrap.Win32Proc(var Message: TMessage); +begin + if (not Finalized) then begin + Inc(Win32ProcLevel); + try + with Message do begin +// {$IFDEF TNT_VERIFY_WINDOWPROC} + if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin + SubClassWindowProc; + LastVerifiedWindowProc := FControl.WindowProc; + end; +// {$ENDIF} + LastWin32Msg := Msg; + Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam); + end; + finally + Dec(Win32ProcLevel); + end; + if (Win32ProcLevel = 0) and (DestroyTrap) then + Free; + end else if (Message.Msg = WM_DESTROY) then + FControl.WindowHandle := 0 +end; + +procedure TWinControlTrap.DefWin32Proc(var Message: TMessage); +begin + with Message do begin + if Msg = WM_NOTIFYFORMAT then + Result := WMNotifyFormatResult(Message.wParam) + else begin + if (Msg = WM_CHAR) then begin + RestoreWMCharMsg(Message) + end; + if (Msg = WM_IME_CHAR) and (not Win32PlatformIsXP) then + begin + { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. } + { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. } + { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. } + Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam) + end else begin + if (Msg = WM_DESTROY) then begin + UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } + end; + { Normal DefWindowProc } + Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam); + end; + end; + end; +end; + +function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean; +var + Message: TMessage; +begin + if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then + Result := False { no subclassing } + else if SameWndMethod(Control.WindowProc, Self.WindowProc) then + Result := True { directly subclassed } + else begin + TestForNull := True; + FoundNull := False; + ZeroMemory(@Message, SizeOf(Message)); + Message.Msg := WM_NULL; + Control.WindowProc(Message); + Result := FoundNull; { indirectly subclassed } + end; +end; + +procedure TWinControlTrap.WindowProc(var Message: TMessage); +var + CameFromWindows: Boolean; +begin + if TestForNull and (Message.Msg = WM_NULL) then + FoundNull := True; + + if (not FControl.HandleAllocated) then + FControl.WndProc(Message) + else begin + CameFromWindows := LastWin32Msg <> WM_NULL; + LastWin32Msg := WM_NULL; + with Message do begin + if (not CameFromWindows) + and (IsTextMessage(Msg)) then + Result := SendMessageA(Handle, Msg, wParam, lParam) + else begin + if (Msg = WM_CHAR) then begin + MakeWMCharMsgSafeForAnsi(Message); + end; + PrevWindowProc(Message) + end; + end; + end; +end; + +//---------------------------------------------------------------------------------- + +function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap; +var + i: integer; +begin + // find or create trap object + Result := nil; + for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin + if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin + Result := TWinControlTrap(PendingRecreateWndTrapList[i]); + PendingRecreateWndTrapList.Delete(i); + break; { found it } + end; + end; + if Result = nil then + Result := TWinControlTrap.Create(Control); +end; + +{$IFDEF Delphi12} +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PWideChar; IDEWindow: Boolean = False); +{$ELSE} +procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); +{$ENDIF} +var + WinControlTrap: TWinControlTrap; +begin + if not IsWindowUnicode(Control.Handle) then + raise Exception.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.'); + + WinControlTrap := FindOrCreateWinControlTrap(Control); + WinControlTrap.SubClassControl(Params_Caption); + WinControlTrap.IDEWindow := IDEWindow; +end; + + +//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE + +var + WindowAtom: TAtom; + ControlAtom: TAtom; + WindowAtomString: String; + ControlAtomString: String; + +type + TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + +function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; + + function GetObjectInstance(Control: TWinControl): Pointer; + var + WinControlTrap: TWinControlTrap; + begin + WinControlTrap := FindOrCreateWinControlTrap(Control); + PendingRecreateWndTrapList.Add(WinControlTrap); + Result := WinControlTrap.WinControl_ObjectInstance; + end; + +var + ObjectInstance: Pointer; +begin + TAccessWinControl(CreationControl).WindowHandle := HWindow; + ObjectInstance := GetObjectInstance(CreationControl); + {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!} + SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance)); + if (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0) + and (GetWindowLongW(HWindow, GWL_ID) = 0) then + SetWindowLongW(HWindow, GWL_ID, Integer(HWindow)); + SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl)); + SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl)); + CreationControl := nil; + Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam); +end; + +procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); +var + TempClass: TWndClassW; + WideClass: TWndClassW; + ClassRegistered: Boolean; + InitialProc: TFNWndProc; +begin + if IDEWindow then + InitialProc := @InitWndProc + else + InitialProc := @InitWndProcW; + + with Params do begin + WideWinClassName := WinClassName + UNICODE_CLASS_EXT; + ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass); + if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc) + then begin + if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance)); + // Prepare a TWndClassW record + WideClass := TWndClassW(WindowClass); + WideClass.hInstance := hInstance; + WideClass.lpfnWndProc := InitialProc; + WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName)); + WideClass.lpszClassName := PWideChar(WideWinClassName); + + // Register the UNICODE class + RegisterClassW(WideClass); + end; + end; +end; + +procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; + const SubClass: WideString; IDEWindow: Boolean = False); +var + TempSubClass: TWndClassW; + WideWinClassName: WideString; + Handle: THandle; +begin + if (not Win32PlatformIsUnicode) then begin + with Params do + TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName, + Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); + end else begin + // SubClass the unicode version of this control by getting the correct DefWndProc + if (SubClass <> '') + and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then + TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc + else + TAccessWinControl(Control).DefWndProc := @DefWindowProcW; + + // make sure Unicode window class is registered + RegisterUnicodeClass(Params, WideWinClassName, IDEWindow); + + // Create UNICODE window handle + UnicodeCreationControl := Control; + try + with Params do + Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil, + Style, X, Y, Width, Height, WndParent, 0, hInstance, Param); + TAccessWinControl(Control).WindowHandle := Handle; + if IDEWindow then + SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC)); + finally + UnicodeCreationControl := nil; + end; + + SubClassUnicodeControl(Control, Params.Caption, IDEWindow); + end; +end; + + +//----------------------------------------------- GET/SET WINDOW TEXT + +function WideGetWindowText(Control: TWinControl): WideString; +begin + if (not Control.HandleAllocated) + or (not IsWindowUnicode(Control.Handle)) then begin + // NO HANDLE -OR- NOT UNICODE + result := TAccessWinControl(Control).Text; + end else begin + // UNICODE & HANDLE + SetLength(Result, GetWindowTextLengthW(Control.Handle) + 1); + GetWindowTextW(Control.Handle, PWideChar(Result), Length(Result)); + SetLength(Result, Length(Result) - 1); + end; +end; + +procedure WideSetWindowText(Control: TWinControl; const Text: WideString); +begin + if (not Control.HandleAllocated) + or (not IsWindowUnicode(Control.Handle)) then begin + // NO HANDLE -OR- NOT UNICODE + TAccessWinControl(Control).Text := Text; + end else if WideGetWindowText(Control) <> Text then begin + // UNICODE & HANDLE + SetWindowTextW(Control.Handle, PWideChar(Text)); + Control.Perform(CM_TEXTCHANGED, 0, 0); + end; +end; + + + +{ TUnicodeEdit } + +procedure TUnicodeEdit.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'EDIT'); +end; + +function TUnicodeEdit.GetSelText: WideString; +begin + Result := Copy(GetText, SelStart + 1, SelLength); +end; + +function TUnicodeEdit.GetText: WideString; +begin + Result := WideGetWindowText(Self); +end; + +procedure TUnicodeEdit.SetSelText(const Value: WideString); +begin + SendMessageW(Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value))); +end; + +procedure TUnicodeEdit.SetText(const Value: WideString); +begin + WideSetWindowText(Self, Value); +end; + + +{ TUnicodeMemo } + +procedure TUnicodeMemo.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, 'EDIT'); +end; + +function TUnicodeMemo.GetSelText: WideString; +begin + Result := Copy(GetText, SelStart + 1, SelLength); +end; + +function TUnicodeMemo.GetText: WideString; +begin + Result := WideGetWindowText(Self); +end; + +procedure TUnicodeMemo.SetSelText(const Value: WideString); +begin + SendMessageW(Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value))); +end; + +procedure TUnicodeMemo.SetText(const Value: WideString); +begin + WideSetWindowText(Self, Value); +end; + + +procedure InitControls; +var + Controls_HInstance: Cardinal; +begin + Controls_HInstance := FindClassHInstance(TWinControl); + WindowAtomString := Format('Delphi%.8X',[GetCurrentProcessID]); + ControlAtomString := Format('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]); +{$IFDEF Delphi12} + WindowAtom := (GlobalAddAtom(PWideChar(WindowAtomString))); + ControlAtom := (GlobalAddAtom(PWideChar(ControlAtomString))); +{$ELSE} + WindowAtom := (GlobalAddAtom(PAnsiChar(WindowAtomString))); + ControlAtom := (GlobalAddAtom(PAnsiChar(ControlAtomString))); +{$ENDIF} + +end; + + +//=========================================================================== +// GetMessage Hook is needed to support entering Unicode +{$IFDEF HOOK_WNDPROC_FOR_UNICODE} +var + _GetMessageHook: HHOOK; + +function _IsDlgMsg(var Msg: TMsg): Boolean; +begin + Result := False; + if (Application.DialogHandle <> 0) then begin + if IsWindowUnicode(Application.DialogHandle) then + Result := IsDialogMessageW(Application.DialogHandle, Msg) + else + Result := IsDialogMessageA(Application.DialogHandle, Msg); + end; +end; + +function _GetMessage(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall; +var + Msg: PMsg; + Handled: Boolean; +begin + if (Code >= 0) and (wParam = PM_REMOVE) then + begin + Msg := PMsg(lParam); + if (Application <> nil) and IsWindowUnicode(Msg.hwnd) and (Msg.message = WM_CHAR) + and (Msg.wParam > Integer(High(AnsiChar))) then + begin + Handled := False; + if Assigned(Application.OnMessage) then + Application.OnMessage(Msg^, Handled); + + if (not Handled) and (not _IsDlgMsg(Msg^)) then + begin + DispatchMessageW(Msg^); + Msg.message := WM_NULL; + end; + end; + end; + Result := CallNextHookEx(_GetMessageHook, Code, wParam, lParam); +end; + +procedure _CreateGetMessageHook; +var + LastError: Integer; +begin + Assert(Win32Platform = VER_PLATFORM_WIN32_NT); + _GetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, _GetMessage, 0, GetCurrentThreadID); + if _GetMessageHook = 0 then + begin + LastError := GetLastError; + raise Exception.Create(SysErrorMessage(LastError)); + end; +end; +{$ENDIF} + +{ TUnicodeRxRichEdit } + +{$IFNDEF Delphi12} +procedure TRxUnicodeRichEdit.CreateWindowHandle( + const Params: TCreateParams); +var + Bounds: TRect; +begin + if Win32PlatformIsUnicode and (RichEditVersion >= 2) then + begin + Bounds := BoundsRect; + if RichEditVersion > 3 then + CreateUnicodeHandle(Self, Params, 'RichEdit50W') + else + CreateUnicodeHandle(Self, Params, RICHEDIT_CLASSW); + if HandleAllocated then BoundsRect := Bounds; + end + else + inherited +end; +{$ENDIF} +initialization + Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); + Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) + or (Win32MajorVersion > 5); + {$IFDEF HOOK_WNDPROC_FOR_UNICODE} + if Win32PlatformIsUnicode then + _CreateGetMessageHook; + {$ENDIF} + PendingRecreateWndTrapList := TList.Create; + InitControls; + +finalization + {$IFDEF HOOK_WNDPROC_FOR_UNICODE} + if _GetMessageHook <> 0 then + UnhookWindowsHookEx(_GetMessageHook); + {$ENDIF} + GlobalDeleteAtom(ControlAtom); + GlobalDeleteAtom(WindowAtom); + PendingRecreateWndTrapList.Free; + PendingRecreateWndTrapList := nil; + Finalized := True; + +end. + + +// diff --git a/official/4.8.11/Source/frxUnicodeUtils.pas b/official/4.8.11/Source/frxUnicodeUtils.pas new file mode 100644 index 0000000..383a3ef --- /dev/null +++ b/official/4.8.11/Source/frxUnicodeUtils.pas @@ -0,0 +1,770 @@ +{*******************************************************} +{ The Delphi Unicode Controls Project } +{ } +{ http://home.ccci.org/wolbrink } +{ } +{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) } +{ } +{*******************************************************} + +unit frxUnicodeUtils; + +interface + +{$I frx.inc} + +uses Windows, Classes, SysUtils +{$IFDEF Delphi10} + , WideStrings +{$ENDIF}; + +type + TWString = record + WString: WideString; + Obj: TObject; + end; +{$IFDEF Delphi10} + TfrxWideStrings = class(TWideStrings) + private + FWideStringList: TList; + procedure ReadData(Reader: TReader); +{$IFDEF Delphi12} + procedure ReadDataWOld(Reader: TReader); +{$ENDIF} + procedure ReadDataW(Reader: TReader); + procedure WriteDataW(Writer: TWriter); + protected + function Get(Index: Integer): WideString; override; + procedure Put(Index: Integer; const S: WideString); override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; Value: TObject); override; + procedure AssignTo(Dest: TPersistent); override; + procedure DefineProperties(Filer: TFiler); override; + function GetTextStr: WideString; override; + procedure SetTextStr(const Value: WideString); override; + function GetCount: Integer; override; + public + constructor Create; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + function Add(const S: WideString): Integer; override; + procedure AddStrings(Strings: TWideStrings); override; + function AddObject(const S: WideString; AObject: TObject): Integer; override; + function IndexOf(const S: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + procedure LoadFromFile(const FileName: WideString); override; + procedure LoadFromStream(Stream: TStream); override; + procedure LoadFromWStream(Stream: TStream); + procedure SaveToFile(const FileName: WideString); override; + procedure SaveToStream(Stream: TStream); override; + property Objects[Index: Integer]: TObject read GetObject write PutObject; + property Strings[Index: Integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + end; +{$ELSE} + TWideStrings = class(TPersistent) + private + FWideStringList: TList; + procedure ReadData(Reader: TReader); + procedure ReadDataW(Reader: TReader); + procedure WriteDataW(Writer: TWriter); + protected + function Get(Index: Integer): WideString; + procedure Put(Index: Integer; const S: WideString); + function GetObject(Index: Integer): TObject; + procedure PutObject(Index: Integer; Value: TObject); + procedure AssignTo(Dest: TPersistent); override; + procedure DefineProperties(Filer: TFiler); override; + function GetTextStr: WideString; + procedure SetTextStr(const Value: WideString); + public + constructor Create; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + function Count: Integer; + procedure Clear; + procedure Delete(Index: Integer); + function Add(const S: WideString): Integer; + procedure AddStrings(Strings: TWideStrings); + function AddObject(const S: WideString; AObject: TObject): Integer; + function IndexOf(const S: WideString): Integer; + procedure Insert(Index: Integer; const S: WideString); + procedure LoadFromFile(const FileName: WideString); + procedure LoadFromStream(Stream: TStream); + procedure LoadFromWStream(Stream: TStream); + procedure SaveToFile(const FileName: WideString); + procedure SaveToStream(Stream: TStream); + property Objects[Index: Integer]: TObject read GetObject write PutObject; + property Strings[Index: Integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + end; +{$ENDIF} + +{$IFNDEF Delphi6} +function Utf8Encode(const WS: WideString): AnsiString; +function UTF8Decode(const S: String): WideString; +function VarToWideStr(const V: Variant): WideString; +{$ENDIF} +function AnsiToUnicode(const s: AnsiString; Charset: UINT; CodePage: Integer = 0): WideString; +function _UnicodeToAnsi(const WS: WideString; Charset: UINT; CodePage: Integer = 0): Ansistring; +function OemToStr(const AnsiStr: AnsiString): AnsiString; +function CharSetToCodePage(ciCharset: DWORD): Cardinal; +function GetLocalByCharSet(Charset: UINT): Cardinal; + + +implementation + +const + sLineBreak = #13#10; + WideLineSeparator = WideChar($2028); + NameValueSeparator = '='; + + +{$IFNDEF Delphi6} +function Utf8Encode(const WS: WideString): AnsiString; +var + L: Integer; + Temp: AnsiString; + + function ToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; + Source: PWideChar; SourceChars: Cardinal): Cardinal; + var + i, count: Cardinal; + c: Cardinal; + begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := AnsiChar(Char(c)); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := AnsiChar(Char($E0 or (c shr 12))); + Dest[count+1] := AnsiChar(Char($80 or ((c shr 6) and $3F))); + Dest[count+2] := AnsiChar(Char($80 or (c and $3F))); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := AnsiChar(Char($C0 or (c shr 6))); + Dest[count+1] := AnsiChar(Char($80 or (c and $3F))); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := AnsiChar(#0); + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; + end; + +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); + L := ToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: String): WideString; +var + L: Integer; + Temp: WideString; + + function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; + var + i, count: Cardinal; + c: Byte; + wc: Cardinal; + begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + end; + Inc(count); + end; + end; + Result := count+1; + end; + +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString; +begin + if not VarIsNull(V) then + Result := V + else + Result := ADefault; +end; + +function VarToWideStr(const V: Variant): WideString; +begin + Result := VarToWideStrDef(V, ''); +end; +{$ENDIF} + +function OemToStr(const AnsiStr: AnsiString): AnsiString; +begin + SetLength(Result, Length(AnsiStr)); + if Length(Result) > 0 then + OemToAnsiBuff(PAnsiChar(AnsiStr), PAnsiChar(Result), Length(Result)); +end; + +{ TWideStrings } +constructor {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Create; +begin + FWideStringList := TList.Create; +end; + +destructor {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Destroy; +begin + Clear; + FWideStringList.Free; + inherited; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Clear; +var + Index: Integer; + PWStr: ^TWString; +begin + for Index := 0 to FWideStringList.Count-1 do + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + Dispose(PWStr); + end; + FWideStringList.Clear; +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Get(Index: Integer): WideString; +var + PWStr: ^TWString; +begin + Result := ''; + if ( (Index >= 0) and (Index < FWideStringList.Count) ) then + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + Result := PWStr^.WString; + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Put(Index: Integer; const S: WideString); +begin + Insert(Index, S); +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.GetObject(Index: Integer): TObject; +var + PWStr: ^TWString; +begin + Result := nil; + if ( (Index >= 0) and (Index < FWideStringList.Count) ) then + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + Result := PWStr^.Obj; + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.PutObject(Index: Integer; Value: TObject); +var + PWStr: ^TWString; +begin + if ( (Index >= 0) and (Index < FWideStringList.Count) ) then + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + PWStr^.Obj := Value; + end; +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Add(const S: WideString): Integer; +var + PWStr: ^TWString; +begin + New(PWStr); + PWStr^.WString := S; + PWStr^.Obj := nil; + Result := FWideStringList.Add(PWStr); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Delete(Index: Integer); +var + PWStr: ^TWString; +begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + Dispose(PWStr); + FWideStringList.Delete(Index); +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.IndexOf(const S: WideString): Integer; +var + Index: Integer; + PWStr: ^TWString; +begin + Result := -1; + for Index := 0 to FWideStringList.Count -1 do + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + begin + if S = PWStr^.WString then + begin + Result := Index; + break; + end; + end; + end; +end; + +{$IFDEF Delphi10} +function TfrxWideStrings.GetCount: Integer; +begin + Result := FWideStringList.Count; +end; +{$ELSE} +function TWideStrings.Count: Integer; +begin + Result := FWideStringList.Count; +end; +{$ENDIF} + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Insert(Index: Integer; const S: WideString); +var + PWStr: ^TWString; +begin + if((Index < 0) or (Index > FWideStringList.Count)) then + raise Exception.Create('Wide String Out of Bounds'); + if Index < FWideStringList.Count then + begin + PWStr := FWideStringList.Items[Index]; + if PWStr <> nil then + PWStr.WString := S; + end + else + Add(S); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.AddStrings(Strings: TWideStrings); +var + I: Integer; +begin + for I := 0 to Strings.Count - 1 do + AddObject(Strings[I], Strings.Objects[I]); +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.AddObject(const S: WideString; AObject: TObject): Integer; +begin + Result := Add(S); + PutObject(Result, AObject); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.Assign(Source: TPersistent); +var + I: Integer; +begin + if Source is TWideStrings then + begin + Clear; + AddStrings(TWideStrings(Source)); + end + else if Source is TStrings then + begin + Clear; + for I := 0 to TStrings(Source).Count - 1 do + AddObject(TStrings(Source)[I], TStrings(Source).Objects[I]); + end + else + inherited Assign(Source); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.AssignTo(Dest: TPersistent); +var + I: Integer; +begin + if Dest is TWideStrings then + Dest.Assign(Self) + else if Dest is TStrings then + begin + TStrings(Dest).BeginUpdate; + try + TStrings(Dest).Clear; + for I := 0 to Count - 1 do + TStrings(Dest).AddObject(Strings[I], Objects[I]); + finally + TStrings(Dest).EndUpdate; + end; + end + else + inherited AssignTo(Dest); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.DefineProperties(Filer: TFiler); +begin + // compatibility + Filer.DefineProperty('Strings', ReadData, nil, Count > 0); +{$IFDEF Delphi12} + Filer.DefineProperty('UTF8', ReadDataWOld, nil, Count > 0); + Filer.DefineProperty('UTF8W', ReadDataW, WriteDataW, Count > 0); +{$ELSE} + Filer.DefineProperty('UTF8', ReadDataW, WriteDataW, Count > 0); +{$ENDIF} + +end; + +function {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.GetTextStr: WideString; +var + I, L, Size, Count: Integer; + P: PWideChar; + S, LB: WideString; +begin + Count := FWideStringList.Count; + Size := 0; + LB := sLineBreak; + for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); + SetString(Result, nil, Size); + P := Pointer(Result); + for I := 0 to Count - 1 do + begin + S := Get(I); + L := Length(S); + if L <> 0 then + begin + System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + L := Length(LB); + if L <> 0 then + begin + System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); + Inc(P, L); + end; + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.LoadFromStream(Stream: TStream); +var + Size: Integer; + S: WideString; + ansiS: String; + sign: Word; +begin + Size := Stream.Size - Stream.Position; + sign := 0; + if Size > 2 then + Stream.Read(sign, 2); + + if sign = $FEFF then + begin + Dec(Size, 2); + SetLength(S, Size div 2); + Stream.Read(S[1], Size); + SetTextStr(S); + end + else + begin + Stream.Seek(-2, soFromCurrent); + SetLength(ansiS, Size); + Stream.Read(ansiS[1], Size); + SetTextStr(ansiS); + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.LoadFromWStream(Stream: TStream); +var + Size: Integer; + S: WideString; +begin + Size := Stream.Size - Stream.Position; + SetLength(S, Size div 2); + Stream.Read(S[1], Size); + SetTextStr(S); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.ReadData(Reader: TReader); +begin + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.ReadDataW(Reader: TReader); +begin + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do +{$IFDEF Delphi12} + Add(Reader.ReadString); +{$ELSE} + Add(Utf8Decode(Reader.ReadString)); +{$ENDIF} + Reader.ReadListEnd; +end; + +{$IFDEF Delphi12} +procedure TfrxWideStrings.ReadDataWOld(Reader: TReader); +begin + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + Add(Utf8Decode(AnsiString(Reader.ReadString))); + Reader.ReadListEnd; +end; +{$ENDIF} + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.SaveToStream(Stream: TStream); +var + SW: WideString; +begin + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.SetTextStr(const Value: WideString); +var + P, Start: PWideChar; + S: WideString; +begin + Clear; + P := Pointer(Value); + if P <> nil then + while P^ <> #0 do + begin + Start := P; +{$IFDEF Delphi12} + while not (CharInSet(P^, [WideChar(#0), WideChar(#10), WideChar(#13)])) and (P^ <> WideLineSeparator) do +{$ELSE} + while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do +{$ENDIF} + Inc(P); + SetString(S, Start, P - Start); + Add(S); + if P^ = #13 then Inc(P); + if P^ = #10 then Inc(P); + if P^ = WideLineSeparator then Inc(P); + end; +end; + +procedure {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}.WriteDataW(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count - 1 do +{$IFDEF Delphi12} + Writer.WriteString(Get(I)); +{$ELSE} + Writer.WriteString(Utf8Encode(Get(I))); +{$ENDIF} + Writer.WriteListEnd; +end; + +function TranslateCharsetInfo(lpSrc: DWORD; var lpCs: TCharsetInfo; + dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; + +function CharSetToCodePage(ciCharset: DWORD): Cardinal; +var + C: TCharsetInfo; +begin + if ciCharset = DEFAULT_CHARSET then + Result := GetACP + else if ciCharset = MAC_CHARSET then + Result := CP_MACCP + else if ciCharset = OEM_CHARSET then + Result := CP_OEMCP// GetACP + else + begin + Win32Check(TranslateCharsetInfo(ciCharset, C, TCI_SRCCHARSET)); + Result := C.ciACP; + end; +end; + +function AnsiToUnicode(const s: AnsiString; Charset: UINT; CodePage: Integer): WideString; +var + InputLength, OutputLength: Integer; +begin + Result := ''; + if CodePage = 0 then + CodePage := CharSetToCodePage(Charset); + InputLength := Length(S); + OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); + if OutputLength <> 0 then + begin + SetLength(Result, OutputLength); + MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); + end; +end; + +function _UnicodeToAnsi(const WS: WideString; Charset: UINT; CodePage: Integer): AnsiString; +var + InputLength, + OutputLength: Integer; +begin + Result := ''; + if CodePage = 0 then + CodePage := CharSetToCodePage(Charset); + InputLength := Length(WS); + OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); + if OutputLength <> 0 then + begin + SetLength(Result, OutputLength); + WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); + end; +end; + +function GetLocalByCharSet(Charset: UINT): Cardinal; +begin + case Charset of + EASTEUROPE_CHARSET: Result := $0405;//$040e + RUSSIAN_CHARSET: Result := $0419; + GREEK_CHARSET: Result := $0408; + TURKISH_CHARSET: Result := $041F; + HEBREW_CHARSET: Result := $040D; + ARABIC_CHARSET: Result := $3401; + BALTIC_CHARSET: Result := $0425; + VIETNAMESE_CHARSET: Result := $042A; + JOHAB_CHARSET: Result := $0812; + THAI_CHARSET: Result := $041E; + SHIFTJIS_CHARSET: Result := $0411; + GB2312_CHARSET: Result := $0804; + HANGEUL_CHARSET: Result := $0412; + CHINESEBIG5_CHARSET: Result := $0C04; + else + Result := GetThreadLocale; + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxUtils.pas b/official/4.8.11/Source/frxUtils.pas new file mode 100644 index 0000000..a9f4b12 --- /dev/null +++ b/official/4.8.11/Source/frxUtils.pas @@ -0,0 +1,1111 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Various routines } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxUtils; + +interface + +{$I frx.inc} + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, + StdCtrls, Menus, ImgList, ActnList, ComCtrls, frxClass +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TfrxRectArea = class + public + X, Y, X1, Y1: Extended; + constructor Create(c: TfrxComponent); overload; + constructor Create(Left, Top, Right, Bottom: Extended); overload; + function InterceptsX(a: TfrxRectArea): Boolean; + function InterceptsY(a: TfrxRectArea): Boolean; + function InterceptX(a: TfrxRectArea): TfrxRectArea; + function InterceptY(a: TfrxRectArea): TfrxRectArea; + function Max(x1, x2: Extended): Extended; + function Min(x1, x2: Extended): Extended; + end; + + +function frxFindComponent(Owner: TComponent; const Name: String): TComponent; +procedure frxGetComponents(Owner: TComponent; ClassRef: TClass; + List: TStrings; Skip: TComponent); +function frxGetFullName(Owner: TComponent; c: TComponent): String; +procedure frxSetCommaText(const Text: String; sl: TStrings; Comma: Char = ';'); +function frxRemoveQuotes(const s: String): String; +function frxStreamToString(Stream: TStream): String; +procedure frxStringToStream(const s: String; Stream: TStream); + +function frxStrToFloat(s: String): Extended; + +function frxFloatToStr(d: Extended): String; +function frxRect(ALeft, ATop, ARight, ABottom: Extended): TfrxRect; +function frxPoint(X, Y: Extended): TfrxPoint; +function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: AnsiString; + var i, j: Integer): AnsiString; +function frxGetBrackedVariableW(const Str, OpenBracket, CloseBracket: WideString; + var i, j: Integer): WideString; +procedure frxCommonErrorHandler(Report: TfrxReport; const Text: String); +procedure frxErrorMsg(const Text: String); +procedure frxInfoMsg(const Text: String); +function frxConfirmMsg(const Text: String; Buttons: Integer): Integer; +function frxIsValidFloat(const Value: string): Boolean; +procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer; + ImgList1: TImageList; ImgList2: TImageList = nil); +procedure frxDrawTransparent(Canvas: TCanvas; x, y: Integer; bmp: TBitmap); +procedure frxDrawGraphic(Canvas: TCanvas; DestRect: TRect; aGraph: TGraphic; + IsPrinting: Boolean); +procedure frxParsePageNumbers(const PageNumbers: String; List: TStrings; + Total: Integer); +function HTMLRGBColor(Color: TColor): string; +procedure frxWriteCollection(Collection: TCollection; Writer: TWriter; + Owner: TfrxComponent); +procedure frxReadCollection(Collection: TCollection; Reader: TReader; + Owner: TfrxComponent); +function GetAppFileName: String; +function GetAppPath: String; +function GetTemporaryFolder: String; +function GetTempFile: String; +function frxCreateTempFile(const TempDir: String): String; +{$IFNDEF Delphi7} +function frFloat2Str(const Value: Extended; const Prec: Integer = 2): String; +{$ELSE} +function frFloat2Str(const Value: Extended; const Prec: Integer = 2; const Sep: Char = '.'): String; +{$ENDIF} +function frxReverseString(const AText: string): string; +function frxStreamCRC32(Stream: TStream): Cardinal; +function frxUnixPath2WinPath(const Path: string): string; +{$IFNDEF Delphi6} +function DirectoryExists(const Name: string): Boolean; +{$ENDIF} +{$IFNDEF Delphi7} +function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer; +{$ENDIF} + + +implementation + +uses frxXMLSerializer, frxRes, TypInfo; + + +{ TfrxRectArea } + +constructor TfrxRectArea.Create(c: TfrxComponent); +begin + Create(c.AbsLeft, c.AbsTop, c.AbsLeft + c.Width, c.AbsTop + c.Height); +end; + +constructor TfrxRectArea.Create(Left, Top, Right, Bottom: Extended); +begin + X := Left; + Y := Top; + X1 := Right; + Y1 := Bottom; +end; + +function TfrxRectArea.InterceptsX(a: TfrxRectArea): Boolean; +begin + Result := False; + if (a.X < X1 - 1e-4) and (a.X1 > X + 1e-4) then + Result := True; +end; + +function TfrxRectArea.InterceptsY(a: TfrxRectArea): Boolean; +begin + Result := False; + if (a.Y < Y1 - 1e-4) and (a.Y1 > Y + 1e-4) then + Result := True; +end; + +function TfrxRectArea.InterceptX(a: TfrxRectArea): TfrxRectArea; +begin + Result := nil; + if InterceptsX(a) then + Result := TfrxRectArea.Create(Max(a.X, X), 0, Min(a.X1, X1), 0); +end; + +function TfrxRectArea.InterceptY(a: TfrxRectArea): TfrxRectArea; +begin + Result := nil; + if InterceptsY(a) then + Result := TfrxRectArea.Create(0, Max(a.Y, Y), 0, Min(a.Y1, Y1)); +end; + +function TfrxRectArea.Max(x1, x2: Extended): Extended; +begin + if x1 > x2 then + Result := x1 + else + Result := x2; +end; + +function TfrxRectArea.Min(x1, x2: Extended): Extended; +begin + if x1 < x2 then + Result := x1 + else + Result := x2; +end; + + + +const + CRCTable: array [0..255] of Cardinal = ( + 0000000000, 1996959894, 3993919788, 2567524794, + 0124634137, 1886057615, 3915621685, 2657392035, + 0249268274, 2044508324, 3772115230, 2547177864, + 0162941995, 2125561021, 3887607047, 2428444049, + 0498536548, 1789927666, 4089016648, 2227061214, + 0450548861, 1843258603, 4107580753, 2211677639, + 0325883990, 1684777152, 4251122042, 2321926636, + 0335633487, 1661365465, 4195302755, 2366115317, + 0997073096, 1281953886, 3579855332, 2724688242, + 1006888145, 1258607687, 3524101629, 2768942443, + 0901097722, 1119000684, 3686517206, 2898065728, + 0853044451, 1172266101, 3705015759, 2882616665, + 0651767980, 1373503546, 3369554304, 3218104598, + 0565507253, 1454621731, 3485111705, 3099436303, + 0671266974, 1594198024, 3322730930, 2970347812, + 0795835527, 1483230225, 3244367275, 3060149565, + 1994146192, 0031158534, 2563907772, 4023717930, + 1907459465, 0112637215, 2680153253, 3904427059, + 2013776290, 0251722036, 2517215374, 3775830040, + 2137656763, 0141376813, 2439277719, 3865271297, + 1802195444, 0476864866, 2238001368, 4066508878, + 1812370925, 0453092731, 2181625025, 4111451223, + 1706088902, 0314042704, 2344532202, 4240017532, + 1658658271, 0366619977, 2362670323, 4224994405, + 1303535960, 0984961486, 2747007092, 3569037538, + 1256170817, 1037604311, 2765210733, 3554079995, + 1131014506, 0879679996, 2909243462, 3663771856, + 1141124467, 0855842277, 2852801631, 3708648649, + 1342533948, 0654459306, 3188396048, 3373015174, + 1466479909, 0544179635, 3110523913, 3462522015, + 1591671054, 0702138776, 2966460450, 3352799412, + 1504918807, 0783551873, 3082640443, 3233442989, + 3988292384, 2596254646, 0062317068, 1957810842, + 3939845945, 2647816111, 0081470997, 1943803523, + 3814918930, 2489596804, 0225274430, 2053790376, + 3826175755, 2466906013, 0167816743, 2097651377, + 4027552580, 2265490386, 0503444072, 1762050814, + 4150417245, 2154129355, 0426522225, 1852507879, + 4275313526, 2312317920, 0282753626, 1742555852, + 4189708143, 2394877945, 0397917763, 1622183637, + 3604390888, 2714866558, 0953729732, 1340076626, + 3518719985, 2797360999, 1068828381, 1219638859, + 3624741850, 2936675148, 0906185462, 1090812512, + 3747672003, 2825379669, 0829329135, 1181335161, + 3412177804, 3160834842, 0628085408, 1382605366, + 3423369109, 3138078467, 0570562233, 1426400815, + 3317316542, 2998733608, 0733239954, 1555261956, + 3268935591, 3050360625, 0752459403, 1541320221, + 2607071920, 3965973030, 1969922972, 0040735498, + 2617837225, 3943577151, 1913087877, 0083908371, + 2512341634, 3803740692, 2075208622, 0213261112, + 2463272603, 3855990285, 2094854071, 0198958881, + 2262029012, 4057260610, 1759359992, 0534414190, + 2176718541, 4139329115, 1873836001, 0414664567, + 2282248934, 4279200368, 1711684554, 0285281116, + 2405801727, 4167216745, 1634467795, 0376229701, + 2685067896, 3608007406, 1308918612, 0956543938, + 2808555105, 3495958263, 1231636301, 1047427035, + 2932959818, 3654703836, 1088359270, 0936918000, + 2847714899, 3736837829, 1202900863, 0817233897, + 3183342108, 3401237130, 1404277552, 0615818150, + 3134207493, 3453421203, 1423857449, 0601450431, + 3009837614, 3294710456, 1567103746, 0711928724, + 3020668471, 3272380065, 1510334235, 0755167117); + +function frxStreamCRC32(Stream: TStream): Cardinal; +var + OldPos: Integer; + b: Byte; + c: Cardinal; +begin + OldPos := Stream.Position; + Stream.Position := 0; + c := $ffffffff; + while Stream.Position < Stream.Size do + begin + Stream.Read(b,1); + c := CrcTable[(c xor Cardinal(b)) and $ff] xor (c shr 8); + end; + Stream.Position := OldPos; + Result := c xor $ffffffff; +end; + +function frxFindComponent(Owner: TComponent; const Name: String): TComponent; +var + n: Integer; + s1, s2: String; +begin + Result := nil; + n := Pos('.', Name); + try + if n = 0 then + begin + if Owner <> nil then + Result := Owner.FindComponent(Name); + if (Result = nil) and (Owner is TfrxReport) and (Owner.Owner <> nil) then + Result := Owner.Owner.FindComponent(Name); + end + else + begin + s1 := Copy(Name, 1, n - 1); // module name + s2 := Copy(Name, n + 1, 255); // component name + Owner := FindGlobalComponent(s1); + if Owner <> nil then + begin + n := Pos('.', s2); + if n <> 0 then // frame name - Delphi5 + begin + s1 := Copy(s2, 1, n - 1); + s2 := Copy(s2, n + 1, 255); + Owner := Owner.FindComponent(s1); + if Owner <> nil then + Result := Owner.FindComponent(s2); + end + else + Result := Owner.FindComponent(s2); + end; + end; + except + on Exception do + raise EClassNotFound.Create('Missing ' + Name); + end; +end; + +{$HINTS OFF} +procedure frxGetComponents(Owner: TComponent; ClassRef: TClass; + List: TStrings; Skip: TComponent); +var + i, j: Integer; + + procedure EnumComponents(f: TComponent); + var + i: Integer; + c: TComponent; + begin +{$IFDEF Delphi5} + if f is TForm then + for i := 0 to TForm(f).ControlCount - 1 do + begin + c := TForm(f).Controls[i]; + if c is TFrame then + EnumComponents(c); + end; +{$ENDIF} + for i := 0 to f.ComponentCount - 1 do + begin + c := f.Components[i]; + if (c <> Skip) and (c is ClassRef) then + List.AddObject(frxGetFullName(Owner, c), c); + end; + end; + +begin + List.Clear; + if Owner is TfrxReport then + EnumComponents(Owner); + for i := 0 to Screen.FormCount - 1 do + EnumComponents(Screen.Forms[i]); + for i := 0 to Screen.DataModuleCount - 1 do + EnumComponents(Screen.DataModules[i]); +{$IFDEF Delphi6} // D6 bugfix + with Screen do + for i := 0 to CustomFormCount - 1 do + with CustomForms[i] do + if (ClassName = 'TDataModuleForm') then + for j := 0 to ComponentCount - 1 do + begin + if (Components[j] is TDataModule) then + EnumComponents(Components[j]); + end; +{$ENDIF} +end; +{$HINTS ON} + +function frxGetFullName(Owner: TComponent; c: TComponent): String; +var + o: TComponent; +begin + Result := ''; + if c = nil then Exit; + + o := c.Owner; + if (o = nil) or (o = Owner) or ((Owner is TfrxReport) and (o = Owner.Owner)) then + Result := c.Name + else if ((o is TForm) or (o is TDataModule)) then + Result := o.Name + '.' + c.Name +{$IFDEF Delphi5} + else if o is TFrame then + if o.Owner <> nil then + Result := o.Owner.Name + '.' + c.Owner.Name + '.' + c.Name + else + Result := c.Owner.Name + '.' + c.Name +{$ENDIF} +end; + +procedure frxSetCommaText(const Text: String; sl: TStrings; Comma: Char = ';'); +var + i: Integer; + + function ExtractCommaName(s: string; var Pos: Integer): string; + var + i: Integer; + begin + i := Pos; + while (i <= Length(s)) and (s[i] <> Comma) do Inc(i); + Result := Copy(s, Pos, i - Pos); + if (i <= Length(s)) and (s[i] = Comma) then Inc(i); + Pos := i; + end; + +begin + i := 1; + sl.Clear; + while i <= Length(Text) do + sl.Add(ExtractCommaName(Text, i)); +end; + +function frxRemoveQuotes(const s: String): String; +begin + if (Length(s) > 2) and (s[1] = '"') and (s[Length(s)] = '"') then + Result := Copy(s, 2, Length(s) - 2) else + Result := s; +end; + +function frxStreamToString(Stream: TStream): String; +var + Size: Integer; + p: PChar; +begin + Size := Stream.Size; + SetLength(Result, Size * 2); + GetMem(p, Size); + + Stream.Position := 0; + Stream.Read(p^, Size); + + BinToHex(p, PChar(@Result[1]), Size); + + FreeMem(p, Size); +end; + +procedure frxStringToStream(const s: String; Stream: TStream); +var + Size: Integer; + p: PChar; +begin + Size := Length(s) div 2; + GetMem(p, Size); + + HexToBin(PChar(@s[1]), p, Size * 2); + + Stream.Position := 0; + Stream.Write(p^, Size); + + FreeMem(p, Size); +end; + +function frxStrToFloat(s: String): Extended; +var + i: Integer; +begin + for i := 1 to Length(s) do +{$IFDEF Delphi12} + if CharInSet(s[i], [',', '.']) then +{$ELSE} + if s[i] in [',', '.'] then +{$ENDIF} + s[i] := DecimalSeparator; + while Pos(' ', s) <> 0 do + Delete(s, Pos(' ', s), 1); + Result := StrToFloat(s); +end; + +function frxFloatToStr(d: Extended): String; +begin + if Int(d) = d then + Result := FloatToStr(d) else + Result := Format('%2.2f', [d]); +end; + +function frxRect(ALeft, ATop, ARight, ABottom: Extended): TfrxRect; +begin + with Result do + begin + Left := ALeft; + Top := ATop; + Right := ARight; + Bottom := ABottom; + end; +end; + +function frxPoint(X, Y: Extended): TfrxPoint; +begin + Result.X := X; + Result.Y := Y; +end; + +function frxGetBrackedVariable(const Str, OpenBracket, CloseBracket: AnsiString; + var i, j: Integer): AnsiString; +var + c: Integer; + fl1, fl2: Boolean; +begin + Result := ''; + j := i; + fl1 := True; + fl2 := True; + c := 0; + if (Str = '') or (j > Length(Str)) then Exit; + + Dec(j); + repeat + Inc(j); + if isDBCSLeadByte(Byte(Str[j])) then { if DBCS then skip 2 bytes } + Inc(j, 2); + + if fl1 and fl2 then + if Copy(Str, j, Length(OpenBracket)) = OpenBracket then + begin + if c = 0 then i := j; + Inc(c); + end + else if Copy(Str, j, Length(CloseBracket)) = CloseBracket then + Dec(c); + if fl1 then + if Str[j] = '"' then fl2 := not fl2; + if fl2 then + if Str[j] = '''' then fl1 := not fl1; + until (c = 0) or (j >= Length(Str)); + + Result := Copy(Str, i + Length(OpenBracket), j - i - Length(OpenBracket)); + if i <> j then + Inc(j, Length(CloseBracket) - 1); +end; + +function frxGetBrackedVariableW(const Str, OpenBracket, CloseBracket: WideString; + var i, j: Integer): WideString; +var + c: Integer; + fl1, fl2: Boolean; +begin + Result := ''; + j := i; + fl1 := True; + fl2 := True; + c := 0; + if (Str = '') or (j > Length(Str)) then Exit; + + Dec(j); + repeat + Inc(j); + if fl1 and fl2 then + if Copy(Str, j, Length(OpenBracket)) = OpenBracket then + begin + if c = 0 then i := j; + Inc(c); + end + else if Copy(Str, j, Length(CloseBracket)) = CloseBracket then + Dec(c); + if fl1 then + if Str[j] = '"' then fl2 := not fl2; + if fl2 then + if Str[j] = '''' then fl1 := not fl1; + until (c = 0) or (j >= Length(Str)); + + Result := Copy(Str, i + Length(OpenBracket), j - i - Length(OpenBracket)); + if i <> j then + Inc(j, Length(CloseBracket) - 1); +end; + +procedure frxCommonErrorHandler(Report: TfrxReport; const Text: String); +var + e: Exception; +begin + case Report.EngineOptions.NewSilentMode of + simMessageBoxes: frxErrorMsg(Text); + simReThrow: begin e := Exception.Create(Text); raise e; end; + end; +end; + +procedure frxErrorMsg(const Text: String); +begin + Application.MessageBox(PChar(Text), PChar(frxResources.Get('mbError')), + mb_Ok + mb_IconError); +end; + +function frxConfirmMsg(const Text: String; Buttons: Integer): Integer; +begin + Result := Application.MessageBox(PChar(Text), + PChar(frxResources.Get('mbConfirm')), mb_IconQuestion + Buttons); +end; + +procedure frxInfoMsg(const Text: String); +begin + Application.MessageBox(PChar(Text), PChar(frxResources.Get('mbInfo')), + mb_Ok + mb_IconInformation); +end; + +function frxIsValidFloat(const Value: string): Boolean; +begin + Result := True; + try + frxStrToFloat(Value); + except + Result := False; + end; +end; + +procedure frxAssignImages(Bitmap: TBitmap; dx, dy: Integer; + ImgList1: TImageList; ImgList2: TImageList = nil); +var + b: TBitmap; + x, y: Integer; + Done: Boolean; +begin + b := TBitmap.Create; + b.Width := dx; + b.Height := dy; + + x := 0; y := 0; + + repeat + b.Canvas.CopyRect(Rect(0, 0, dx, dy), Bitmap.Canvas, Rect(x, y, x + dx, y + dy)); + Done := y > Bitmap.Height; + + if not Done then + begin + ImgList1.AddMasked(b, b.TransparentColor); + if ImgList2 <> nil then + begin + Inc(x, dx); + b.Canvas.CopyRect(Rect(0, 0, dx, dy), Bitmap.Canvas, Rect(x, y, x + dx, y + dy)); + ImgList2.AddMasked(b, b.TransparentColor); + end; + end; + + Inc(x, dx); + if x >= Bitmap.Width then + begin + x := 0; + Inc(y, dy); + end; + until Done; + + b.Free; +end; + +procedure frxDrawTransparent(Canvas: TCanvas; x, y: Integer; bmp: TBitmap); +var + img: TImageList; +begin + if Assigned(bmp) then + begin + img := TImageList.Create(nil); + try + img.Width := bmp.Width; + img.Height := bmp.Height; + img.AddMasked(bmp, bmp.TransparentColor); + img.Draw(Canvas, x, y, 0); + img.Clear; + finally + img.Free; + end; + end; +end; + +procedure DrawBitmap(aCanvas: TCanvas; Dest: TRect; Bitmap: TBitmap); +var + Info: PBitmapInfo; + HInfo: HGLOBAL; + InfoSize: DWord; + Image: Pointer; + HImage: HGLOBAL; + ImageSize: DWord; +begin + with Bitmap do + begin + GetDIBSizes(Handle, InfoSize, ImageSize); + HInfo := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, InfoSize); + Info := PBitmapInfo(GlobalLock(HInfo)); + try + HImage := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, ImageSize); + Image := Pointer(GlobalLock(HImage)); + try + GetDIB(Handle, Palette, Info^, Image^); + SetStretchBltMode(ACanvas.Handle, STRETCH_HALFTONE); + with Info^.bmiHeader do + StretchDIBits(aCanvas.Handle, Dest.Left, Dest.Top, + Dest.RIght - Dest.Left, Dest.Bottom - Dest.Top, + 0, 0, biWidth, biHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY); + finally + GlobalUnlock(HImage); + GlobalFree(HImage); + end; + finally + GlobalUnlock(HInfo); + GlobalFree(HInfo); + end; + end; +end; + +procedure frxDrawGraphic(Canvas: TCanvas; DestRect: TRect; aGraph: TGraphic; + IsPrinting: Boolean); +var + Bitmap: TBitmap; +begin + if (aGraph is TMetaFile) or not IsPrinting then + Canvas.StretchDraw(DestRect, aGraph) + else + begin + Bitmap := TBitmap.Create; + try + Bitmap.Width := aGraph.Width; + Bitmap.Height := aGraph.Height; + Bitmap.PixelFormat := pf32Bit; + Bitmap.Canvas.Draw(0, 0, aGraph); + DrawBitmap(Canvas, DestRect, Bitmap); + finally + Bitmap.Free; + end; + end +end; + +procedure frxParsePageNumbers(const PageNumbers: String; List: TStrings; + Total: Integer); +var + i, j, n1, n2: Integer; + s: String; + IsRange: Boolean; +begin + List.Clear; + s := PageNumbers; + while Pos(' ', s) <> 0 do + Delete(s, Pos(' ', s), 1); + if s = '' then Exit; + + if s[Length(s)] = '-' then + s := s + IntToStr(Total); + s := s + ','; + i := 1; j := 1; n1 := 1; + IsRange := False; + + while i <= Length(s) do + begin + if s[i] = ',' then + begin + n2 := StrToInt(Copy(s, j, i - j)); + j := i + 1; + if IsRange then + while n1 <= n2 do + begin + List.Add(IntToStr(n1)); + Inc(n1); + end + else + List.Add(IntToStr(n2)); + IsRange := False; + end + else if s[i] = '-' then + begin + IsRange := True; + n1 := StrToInt(Copy(s, j, i - j)); + j := i + 1; + end; + Inc(i); + end; +end; + +function HTMLRGBColor(Color: TColor): string; +var + TheRgbValue : TColorRef; +begin + TheRgbValue := ColorToRGB(Color); + Result := '#' + Format('%.2x%.2x%.2x', [GetRValue(TheRGBValue), GetGValue(TheRGBValue), GetBValue(TheRGBValue)]); +end; + + +procedure ConvertOneItem(Item: TCollectionItem; ToAnsi: Boolean); +var + i: Integer; + TypeInfo: PTypeInfo; + PropCount: Integer; + PropList: PPropList; + + function Convert(const Value: String): String; + var + i: Integer; + begin + Result := ''; + i := 1; + while i <= Length(Value) do + begin + if ToAnsi then + begin + if Value[i] >= #128 then + Result := Result + #1 + Chr(Ord(Value[i]) - 128) else + Result := Result + Value[i]; + end + else + begin + if (Value[i] = #1) and (i < Length(Value)) then + begin + Result := Result + Chr(Ord(Value[i + 1]) + 128); + Inc(i); + end + else + Result := Result + Value[i]; + end; + + Inc(i); + end; + end; + + procedure DoStrProp; + var + Value, NewValue: String; + begin + Value := GetStrProp(Item, PropList[i]); + NewValue := Convert(Value); + if Value <> NewValue then + SetStrProp(Item, PropList[i], NewValue); + end; + + procedure DoVariantProp; + var + Value: Variant; + begin + Value := GetVariantProp(Item, PropList[i]); + if (TVarData(Value).VType = varString) or (TVarData(Value).VType = varOleStr) + {$IFDEF Delphi12} or (TVarData(Value).VType = varOleStr){$ENDIF} then + begin + Value := Convert(Value); + SetVariantProp(Item, PropList[i], Value); + end; + end; + +begin + TypeInfo := Item.ClassInfo; + PropCount := GetTypeData(TypeInfo).PropCount; + GetMem(PropList, PropCount * SizeOf(PPropInfo)); + GetPropInfos(TypeInfo, PropList); + + try + for i := 0 to PropCount - 1 do + begin + case PropList[i].PropType^.Kind of + tkString, tkLString, tkWString: + DoStrProp; + + tkVariant: + DoVariantProp; + end; + end; + + finally + FreeMem(PropList, PropCount * SizeOf(PPropInfo)); + end; +end; + +procedure frxWriteCollection(Collection: TCollection; Writer: TWriter; + Owner: TfrxComponent); +var + i: Integer; + xs: TfrxXMLSerializer; + s: String; +{$IFDEF Delphi12} +{$ELSE} + vt: TValueType; + l: Integer; +{$ENDIF} +begin + if Owner.IsWriting then + begin + { called from SaveToStream } + Writer.WriteListBegin; + xs := TfrxXMLSerializer.Create(nil); + try + xs.Owner := Owner.Report; + for i := 0 to Collection.Count - 1 do + begin + Writer.WriteListBegin; +{$IFDEF Delphi12} + s := {UTF8Encode(}xs.ObjToXML(Collection.Items[i]); + Writer.WriteString(s); + Writer.WriteListEnd; +{$ELSE} + s := xs.ObjToXML(Collection.Items[i]); + vt := vaLString; + Writer.Write(vt, SizeOf(vt)); + l := Length(s); + Writer.Write(l, SizeOf(l)); + Writer.Write(s[1], l); + Writer.WriteListEnd; +{$ENDIF} + end; + finally + Writer.WriteListEnd; + xs.Free; + end; + end + else + begin + { called from Delphi streamer } + Writer.WriteCollection(Collection); + end; +end; + +procedure frxReadCollection(Collection: TCollection; Reader: TReader; + Owner: TfrxComponent); +var + i: Integer; + vt: TValueType; + xs: TfrxXMLSerializer; + s: String; + Item: TCollectionItem; + NeedFree: Boolean; +begin + vt := Reader.ReadValue; + if vt <> vaCollection then + begin + { called from LoadFromStream } + NeedFree := False; + xs := nil; + if Owner.Report <> nil then + xs := TfrxXMLSerializer(Owner.Report.XMLSerializer); + + if xs = nil then + begin + xs := TfrxXMLSerializer.Create(nil); + xs.Owner := Owner.Report; + NeedFree := True; + end; + + try + Collection.Clear; + + while not Reader.EndOfList do + begin + Reader.ReadListBegin; + Item := Collection.Add; +{$IFDEF Delphi12} +//UTF8Decode() + s := Reader.ReadString; +{$ELSE} + s := Reader.ReadString; +{$ENDIF} + if NeedFree then + xs.ReadPersistentStr(Owner.Report, Item, s) + else + xs.XMLToObj(s, Item); + Reader.ReadListEnd; + end; + finally + Reader.ReadListEnd; + if NeedFree then + xs.Free; + end; + end + else + begin + { called from Delphi streamer } + Reader.ReadCollection(Collection); + for i := 0 to Collection.Count - 1 do + ConvertOneItem(Collection.Items[i], False); + end; +end; + +function GetTemporaryFolder: String; +var + Path: String; +begin + Setlength(Path, MAX_PATH); + SetLength(Path, GetTempPath(MAX_PATH, @Path[1])); +{$IFDEF Delphi12} + Result := StrPas(PWideChar(@Path[1])); +{$ELSE} + Result := StrPas(@Path[1]); +{$ENDIF} +end; + +function GetTempFile: String; +var + Path: String; + FileName: String; +begin + SetLength(Path, MAX_PATH); + SetLength(Path, GetTempPath(MAX_PATH, @Path[1])); + SetLength(FileName, MAX_PATH); + GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]); +{$IFDEF Delphi12} + Result := StrPas(PWideChar(@FileName[1])); +{$ELSE} + Result := StrPas(@FileName[1]); +{$ENDIF} +end; + +function frxCreateTempFile(const TempDir: String): String; +var + Path: String; + FileName: String; +begin + Path := TempDir; + if (Path <> '') and (Path[Length(Path)] <> '\') then + Path := Path + '\'; + SetLength(FileName, MAX_PATH); + if Path = '' then + begin + SetLength(Path, MAX_PATH); + SetLength(Path, GetTempPath(MAX_PATH, @Path[1])); + end + else begin + Path := Path + #0; + SetLength(Path, MAX_PATH); + end; + GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]); +{$IFDEF Delphi12} + Result := StrPas(PWideChar(@FileName[1])); +{$ELSE} + Result := StrPas(@FileName[1]); +{$ENDIF} +end; + +function GetAppFileName: String; +var + fName: String; + nsize: cardinal; +begin + nsize := MAX_PATH; + SetLength(fName,nsize); + SetLength(fName, GetModuleFileName(hinstance, pchar(fName), nsize)); + Result := fName; +end; + +function GetAppPath: String; +begin + Result := ExtractFilePath(GetAppFileName); +end; + +{$IFNDEF Delphi7} +function frFloat2Str(const Value: Extended; const Prec: Integer = 2): String; +var + i: Integer; + IntVal: Integer; +begin + IntVal := Trunc(Value); + if IntVal <> Value then + Result := Format('%.' + IntToStr(Prec)+ 'f', [Value]) + else + Result := IntToStr(IntVal); + if DecimalSeparator <> '.' then + begin + i := Pos(DecimalSeparator, Result); + if i > 0 then + Result[i] := '.'; + end; +end; +{$ELSE} +function frFloat2Str(const Value: Extended; const Prec: Integer = 2; const Sep: Char = '.'): String; +var + FormatSettings: TFormatSettings; + Buffer: array[0..63] of Char; +begin + FormatSettings.DecimalSeparator := Sep; + FormatSettings.ThousandSeparator := Char(0); + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + ffFixed, 32, Prec, FormatSettings)); +end; +{$ENDIF} + +function frxReverseString(const AText: string): string; +var + I: Integer; + P: PChar; +begin + SetLength(Result, Length(AText)); + P := PChar(Result); + for I := Length(AText) downto 1 do + begin + P^ := AText[I]; + Inc(P); + end; +end; + +function ChangeChars(const Str: string; FromChar, ToChar: Char): string; +var + I: Integer; +begin + Result := Str; + for I := 1 to Length(Result) do + if Result[I] = FromChar then + Result[I] := ToChar; +end; + +function frxUnixPath2WinPath(const Path: string): string; +begin + Result := ChangeChars(Path, '/', '\'); +end; + +{$IFNDEF Delphi6} +function DirectoryExists(const Name: string): Boolean; +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(Name)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; +{$ENDIF} + + +{$IFNDEF Delphi7} +function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer; +var + I,X: Integer; + Len, LenSubStr: Integer; +begin + if Offset = 1 then + Result := Pos(SubStr, S) + else + begin + I := Offset; + LenSubStr := Length(SubStr); + Len := Length(S) - LenSubStr + 1; + while I <= Len do + begin + if S[I] = SubStr[1] then + begin + X := 1; + while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do + Inc(X); + if (X = LenSubStr) then + begin + Result := I; + exit; + end; + end; + Inc(I); + end; + Result := 0; + end; +end; +{$ENDIF} + + +end. + + +// diff --git a/official/4.8.11/Source/frxVariables.pas b/official/4.8.11/Source/frxVariables.pas new file mode 100644 index 0000000..0886856 --- /dev/null +++ b/official/4.8.11/Source/frxVariables.pas @@ -0,0 +1,411 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ FR Variables } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxVariables; + +interface + +{$I frx.inc} + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, + frxXML +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxVariable = class(TCollectionItem) + private + FName: String; + FValue: Variant; + public + constructor Create(Collection: TCollection); override; + procedure Assign(Source: TPersistent); override; + published + property Name: String read FName write FName; + property Value: Variant read FValue write FValue; + end; + + TfrxVariables = class(TCollection) + private + function GetItems(Index: Integer): TfrxVariable; + function GetVariable(Index: String): Variant; + procedure SetVariable(Index: String; const Value: Variant); + public + constructor Create; + function Add: TfrxVariable; + function Insert(Index: Integer): TfrxVariable; + function IndexOf(const Name: String): Integer; + procedure AddVariable(const ACategory, AName: String; const AValue: Variant); + procedure DeleteCategory(const Name: String); + procedure DeleteVariable(const Name: String); + procedure GetCategoriesList(List: TStrings; ClearList: Boolean = True); + procedure GetVariablesList(const Category: String; List: TStrings); + procedure LoadFromFile(const FileName: String); + procedure LoadFromStream(Stream: TStream); + procedure LoadFromXMLItem(Item: TfrxXMLItem; OldXMLFormat: Boolean = True); + procedure SaveToFile(const FileName: String); + procedure SaveToStream(Stream: TStream); + procedure SaveToXMLItem(Item: TfrxXMLItem); + property Items[Index: Integer]: TfrxVariable read GetItems; + property Variables[Index: String]: Variant read GetVariable + write SetVariable; default; + end; + + TfrxArray = class(TCollection) + private + function GetItems(Index: Integer): TfrxVariable; + function GetVariable(Index: Variant): Variant; + procedure SetVariable(Index: Variant; const Value: Variant); + public + constructor Create; + function IndexOf(const Name: Variant): Integer; + property Items[Index: Integer]: TfrxVariable read GetItems; + property Variables[Index: Variant]: Variant read GetVariable + write SetVariable; default; + end; + + +implementation + +uses frxXMLSerializer; + + +{ TfrxVariable } + +constructor TfrxVariable.Create(Collection: TCollection); +begin + inherited; + FValue := Null; +end; + +procedure TfrxVariable.Assign(Source: TPersistent); +begin + if Source is TfrxVariable then + begin + FName := TfrxVariable(Source).Name; + FValue := TfrxVariable(Source).Value; + end; +end; + + +{ TfrxVariables } + +constructor TfrxVariables.Create; +begin + inherited Create(TfrxVariable); +end; + +function TfrxVariables.Add: TfrxVariable; +begin + Result := TfrxVariable(inherited Add); +end; + +function TfrxVariables.Insert(Index: Integer): TfrxVariable; +begin + Result := TfrxVariable(inherited Insert(Index)); +end; + +function TfrxVariables.GetItems(Index: Integer): TfrxVariable; +begin + Result := TfrxVariable(inherited Items[Index]); +end; + +function TfrxVariables.IndexOf(const Name: String): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to Count - 1 do + if AnsiCompareText(Name, Items[i].Name) = 0 then + begin + Result := i; + break; + end; +end; + +function TfrxVariables.GetVariable(Index: String): Variant; +var + i: Integer; +begin + i := IndexOf(Index); + if i <> -1 then + Result := Items[i].Value else + Result := Null; +end; + +procedure TfrxVariables.SetVariable(Index: String; const Value: Variant); +var + i: Integer; + v: TfrxVariable; +begin + i := IndexOf(Index); + if i <> -1 then + Items[i].Value := Value + else + begin + v := Add; + v.Name := Index; + v.Value := Value; + end; +end; + +procedure TfrxVariables.GetCategoriesList(List: TStrings; ClearList: Boolean = True); +var + i: Integer; + s: String; +begin + if ClearList then + List.Clear; + + for i := 0 to Count - 1 do + begin + s := Items[i].Name; + if (s <> '') and (s[1] = ' ') then + List.Add(Copy(s, 2, 255)); + end; +end; + +procedure TfrxVariables.GetVariablesList(const Category: String; List: TStrings); +var + i, j: Integer; + s: String; +begin + List.Clear; + for i := 0 to Count - 1 do + if (Category = '') or (AnsiCompareText(Items[i].Name, ' ' + Category) = 0) then + begin + if Category <> '' then + j := i + 1 else + j := i; + while j < Count do + begin + s := Items[j].Name; + Inc(j); + if (s <> '') and (s[1] <> ' ') then + List.Add(s) else + break + end; + break; + end; +end; + +procedure TfrxVariables.DeleteCategory(const Name: String); +var + i: Integer; +begin + i := 0; + while i < Count do + begin + if AnsiCompareText(Items[i].Name, ' ' + Name) = 0 then + begin + Items[i].Free; + while (i < Count) and (Items[i].Name[1] <> ' ') do + Items[i].Free; + break; + end; + Inc(i); + end; +end; + +procedure TfrxVariables.DeleteVariable(const Name: String); +var + i: Integer; +begin + i := IndexOf(Name); + if i <> -1 then + Items[i].Free; +end; + +procedure TfrxVariables.AddVariable(const ACategory, AName: String; + const AValue: Variant); +var + i, idx: Integer; +begin + i := 0; + while i < Count do + begin + if AnsiCompareText(Items[i].Name, ' ' + ACategory) = 0 then + begin + Inc(i); + while (i < Count) and (Items[i].Name[1] <> ' ') do + Inc(i); + idx := IndexOf(AName); + if idx <> - 1 then + Items[idx].Value := AValue + else + if i = Count then + with Add do + begin + Name := AName; + Value := AValue; + end + else + with Insert(i) do + begin + Name := AName; + Value := AValue; + end; + break; + end; + Inc(i); + end; +end; + +procedure TfrxVariables.LoadFromFile(const FileName: String); +var + f: TFileStream; +begin + f := TFileStream.Create(FileName, fmOpenRead); + try + LoadFromStream(f); + finally + f.Free; + end; +end; + +procedure TfrxVariables.LoadFromStream(Stream: TStream); +var + x: TfrxXMLDocument; +begin + Clear; + x := TfrxXMLDocument.Create; + try + x.LoadFromStream(Stream); + if CompareText(x.Root.Name, 'variables') = 0 then + LoadFromXMLItem(x.Root, x.OldVersion); + finally + x.Free; + end; +end; + +procedure TfrxVariables.LoadFromXMLItem(Item: TfrxXMLItem; OldXMLFormat: Boolean); +var + xs: TfrxXMLSerializer; + i: Integer; +begin + Clear; + xs := TfrxXMLSerializer.Create(nil); + xs.OldFormat := OldXMLFormat; + try + for i := 0 to Item.Count - 1 do + if CompareText(Item[i].Name, 'item') = 0 then + xs.XMLToObj(Item[i].Text, Add); + finally + xs.Free; + end; +end; + +procedure TfrxVariables.SaveToFile(const FileName: String); +var + f: TFileStream; +begin + f := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(f); + finally + f.Free; + end; +end; + +procedure TfrxVariables.SaveToStream(Stream: TStream); +var + x: TfrxXMLDocument; +begin + x := TfrxXMLDocument.Create; + x.AutoIndent := True; + try + x.Root.Name := 'variables'; + SaveToXMLItem(x.Root); + x.SaveToStream(Stream); + finally + x.Free; + end; +end; + +procedure TfrxVariables.SaveToXMLItem(Item: TfrxXMLItem); +var + xi: TfrxXMLItem; + xs: TfrxXMLSerializer; + i: Integer; +begin + xs := TfrxXMLSerializer.Create(nil); + try + for i := 0 to Count - 1 do + begin + xi := Item.Add; + xi.Name := 'item'; + xi.Text := xs.ObjToXML(Items[i]); + end; + finally + xs.Free; + end; +end; + + +{ TfrxArray } + +constructor TfrxArray.Create; +begin + inherited Create(TfrxVariable); +end; + +function TfrxArray.GetItems(Index: Integer): TfrxVariable; +begin + Result := TfrxVariable(inherited Items[Index]); +end; + +function TfrxArray.IndexOf(const Name: Variant): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to Count - 1 do + if AnsiCompareText(VarToStr(Name), Items[i].Name) = 0 then + begin + Result := i; + break; + end; +end; + +function TfrxArray.GetVariable(Index: Variant): Variant; +var + i: Integer; +begin + i := IndexOf(Index); + if i <> -1 then + Result := Items[i].Value else + Result := Null; +end; + +procedure TfrxArray.SetVariable(Index: Variant; const Value: Variant); +var + i: Integer; + v: TfrxVariable; +begin + i := IndexOf(Index); + if i <> -1 then + Items[i].Value := Value + else + begin + v := TfrxVariable(inherited Add); + v.Name := Index; + v.Value := Value; + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxVersion.inc b/official/4.8.11/Source/frxVersion.inc new file mode 100644 index 0000000..7d9de7e --- /dev/null +++ b/official/4.8.11/Source/frxVersion.inc @@ -0,0 +1 @@ +'4.8.11' \ No newline at end of file diff --git a/official/4.8.11/Source/frxWatchForm.dfm b/official/4.8.11/Source/frxWatchForm.dfm new file mode 100644 index 0000000..9aa34be Binary files /dev/null and b/official/4.8.11/Source/frxWatchForm.dfm differ diff --git a/official/4.8.11/Source/frxWatchForm.pas b/official/4.8.11/Source/frxWatchForm.pas new file mode 100644 index 0000000..3d27d5b --- /dev/null +++ b/official/4.8.11/Source/frxWatchForm.pas @@ -0,0 +1,199 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ Watches toolwindow } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxWatchForm; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ComCtrls, ToolWin, fs_iinterpreter, CheckLst +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + +type + TfrxWatchForm = class(TForm) + ToolBar1: TToolBar; + AddB: TToolButton; + DeleteB: TToolButton; + EditB: TToolButton; + WatchLB: TCheckListBox; + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure FormDestroy(Sender: TObject); + procedure AddBClick(Sender: TObject); + procedure DeleteBClick(Sender: TObject); + procedure EditBClick(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure WatchLBClickCheck(Sender: TObject); + private + FScript: TfsScript; + FScriptRunning: Boolean; + FWatches: TStrings; + function CalcWatch(const s: String): String; + public + procedure UpdateWatches; + property Script: TfsScript read FScript write FScript; + property ScriptRunning: Boolean read FScriptRunning write FScriptRunning; + property Watches: TStrings read FWatches; + end; + + +implementation + +{$R *.DFM} + +uses frxRes, frxEvaluateForm; + +type + THackWinControl = class(TWinControl); + + +procedure TfrxWatchForm.FormCreate(Sender: TObject); +begin + Caption := frxGet(5900); + AddB.Hint := frxGet(5901); + DeleteB.Hint := frxGet(5902); + EditB.Hint := frxGet(5903); + FWatches := TStringList.Create; +{$IFDEF UseTabset} + WatchLB.BevelKind := bkFlat; +{$ELSE} + WatchLB.BorderStyle := bsSingle; +{$ENDIF} + + if UseRightToLeftAlignment then + FlipChildren(True); +end; + +procedure TfrxWatchForm.FormDestroy(Sender: TObject); +begin + FWatches.Free; +end; + +procedure TfrxWatchForm.FormShow(Sender: TObject); +begin + Toolbar1.Images := frxResources.MainButtonImages; +end; + +procedure TfrxWatchForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = VK_F1 then + frxResources.Help(Self); +end; + +procedure TfrxWatchForm.AddBClick(Sender: TObject); +begin + with TfrxEvaluateForm.Create(Owner) do + begin + IsWatch := True; + if ShowModal = mrOk then + begin + //Watches.Add(ExpressionE.Text); + Watches.AddObject(ExpressionE.Text, TObject(1)); + UpdateWatches; + end; + Free; + end; +end; + +procedure TfrxWatchForm.DeleteBClick(Sender: TObject); +begin + if WatchLB.ItemIndex <> -1 then + begin + Watches.Delete(WatchLB.ItemIndex); + UpdateWatches; + end; +end; + +procedure TfrxWatchForm.EditBClick(Sender: TObject); +begin + if WatchLB.ItemIndex <> -1 then + with TfrxEvaluateForm.Create(Owner) do + begin + IsWatch := True; + ExpressionE.Text := Watches[WatchLB.ItemIndex]; + if ShowModal = mrOk then + begin + Watches[WatchLB.ItemIndex] := ExpressionE.Text; + UpdateWatches; + end; + Free; + end; +end; + +function TfrxWatchForm.CalcWatch(const s: String): String; +var + v: Variant; +begin + if (FScript <> nil) and (FScriptRunning) then + begin + v := FScript.Evaluate(s); + Result := VarToStr(v); + if TVarData(v).VType = varBoolean then + if Boolean(v) = True then + Result := 'True' else + Result := 'False' + else if (TVarData(v).VType = varString) or (TVarData(v).VType = varOleStr) + {$IFDEF Delphi12}or (TVarData(v).VType = varUString){$ENDIF} then + Result := '''' + v + '''' + else if v = Null then + Result := 'Null'; + end + else + Result := 'not accessible'; +end; + +procedure TfrxWatchForm.UpdateWatches; +var + i: Integer; +begin + WatchLB.Items.BeginUpdate; + WatchLB.Items.Clear; + for i := 0 to Watches.Count - 1 do + begin + if Watches.Objects[i] = TObject(1) then + WatchLB.Items.Add(Watches[i] + ': ' + CalcWatch(Watches[i])) + else + WatchLB.Items.Add(Watches[i] + ': disabled'); + WatchLB.Checked[i] := Boolean(Watches.Objects[i]); + end; + WatchLB.Items.EndUpdate; +end; + +procedure TfrxWatchForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := False; +end; + +procedure TfrxWatchForm.WatchLBClickCheck(Sender: TObject); +var + Bool: Boolean; +begin + if (WatchLB.ItemIndex <> -1) then + begin + Bool := Boolean(Watches.Objects[WatchLB.ItemIndex]); + Watches.Objects[WatchLB.ItemIndex] := TObject(not Bool); + UpdateWatches; + end; +end; + +end. + + +// diff --git a/official/4.8.11/Source/frxXML.pas b/official/4.8.11/Source/frxXML.pas new file mode 100644 index 0000000..490aaf9 --- /dev/null +++ b/official/4.8.11/Source/frxXML.pas @@ -0,0 +1,1085 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ XML document } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxXML; + +interface + +{$I frx.inc} + +uses + Windows, SysUtils, Classes +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxInvalidXMLException = class(Exception); + + TfrxXMLItem = class(TObject) + private + FData: Pointer; { optional item data } + FHiOffset: Byte; { hi-part of the offset } + FItems: TList; { subitems } + FLoaded: Boolean; { item is loaded, no need to call LoadItem } + FLoOffset: Integer; { lo-part of the offset } + FModified: Boolean; { item is modified (used by preview designer) } + FName: String; { item name } + FParent: TfrxXMLItem; { item parent } + FText: String; { item attributes } + FUnloadable: Boolean; + FValue: String; { item value Value } + function GetCount: Integer; + function GetItems(Index: Integer): TfrxXMLItem; + function GetOffset: Int64; + procedure SetOffset(const Value: Int64); + function GetProp(Index: String): String; + procedure SetProp(Index: String; const Value: String); + public + constructor Create; + destructor Destroy; override; + procedure AddItem(Item: TfrxXMLItem); + procedure Clear; + procedure InsertItem(Index: Integer; Item: TfrxXMLItem); + + function Add: TfrxXMLItem; + function Find(const Name: String): Integer; + function FindItem(const Name: String): TfrxXMLItem; + function IndexOf(Item: TfrxXMLItem): Integer; + function PropExists(const Index: String): Boolean; + function Root: TfrxXMLItem; + procedure DeleteProp(const Index: String); + + property Count: Integer read GetCount; + property Data: Pointer read FData write FData; + property Items[Index: Integer]: TfrxXMLItem read GetItems; default; + property Loaded: Boolean read FLoaded; + property Modified: Boolean read FModified write FModified; + property Name: String read FName write FName; +{ offset is the position of the item in the tempstream. This parameter is needed + for dynamically loading large files. Items that can be loaded on-demand must + have Unloadable = True (in run-time) or have 'ld="0"' parameter (in the file) } + property Offset: Int64 read GetOffset write SetOffset; + property Parent: TfrxXMLItem read FParent; + property Prop[Index: String]: String read GetProp write SetProp; + property Text: String read FText write FText; + property Unloadable: Boolean read FUnloadable write FUnloadable; + property Value: String read FValue write FValue; + end; + + TfrxXMLDocument = class(TObject) + private + FAutoIndent: Boolean; { use indents when writing document to a file } + FRoot: TfrxXMLItem; { root item } + FTempDir: String; { folder for temporary files } + FTempFile: String; { tempfile name } + FTempStream: TStream; { temp stream associated with tempfile } + FTempFileCreated: Boolean; { tempfile has been created - need to delete it } + FOldVersion: Boolean; + procedure CreateTempFile; + procedure DeleteTempFile; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure LoadItem(Item: TfrxXMLItem); + procedure UnloadItem(Item: TfrxXMLItem); + procedure SaveToStream(Stream: TStream); + procedure LoadFromStream(Stream: TStream; AllowPartialLoading: Boolean = False); + procedure SaveToFile(const FileName: String); + procedure LoadFromFile(const FileName: String); + + property AutoIndent: Boolean read FAutoIndent write FAutoIndent; + property Root: TfrxXMLItem read FRoot; + property TempDir: String read FTempDir write FTempDir; + property OldVersion: Boolean read FOldVersion; + end; + +{ TfrxXMLReader and TfrxXMLWriter are doing actual read/write to the XML file. + Read/write process is buffered. } + + TfrxXMLReader = class(TObject) + private + FBuffer: PAnsiChar; + FBufPos: Integer; + FBufEnd: Integer; + FPosition: Int64; + FSize: Int64; + FStream: TStream; + FOldFormat: Boolean; + procedure SetPosition(const Value: Int64); + procedure ReadBuffer; + procedure ReadItem(var {$IFDEF Delphi12}NameS{$ELSE}Name{$ENDIF}, Text: String); + public + constructor Create(Stream: TStream); + destructor Destroy; override; + procedure RaiseException; + procedure ReadHeader; + procedure ReadRootItem(Item: TfrxXMLItem; ReadChildren: Boolean = True); + property Position: Int64 read FPosition write SetPosition; + property Size: Int64 read FSize; + end; + + TfrxXMLWriter = class(TObject) + private + FAutoIndent: Boolean; + FBuffer: AnsiString; + FStream: TStream; + FTempStream: TStream; + procedure FlushBuffer; + procedure WriteLn(const s: AnsiString); + procedure WriteItem(Item: TfrxXMLItem; Level: Integer = 0); + public + constructor Create(Stream: TStream); + procedure WriteHeader; + procedure WriteRootItem(RootItem: TfrxXMLItem); + property TempStream: TStream read FTempStream write FTempStream; + end; + + +{ StrToXML changes '<', '>', '"', cr, lf symbols to its ascii codes } +function frxStrToXML(const s: String): String; + +{ ValueToXML convert a value to the valid XML string } +function frxValueToXML(const Value: Variant): String; + +{ XMLToStr is opposite to StrToXML function } +function frxXMLToStr(const s: String): String; + + + +implementation + +uses FileCtrl; + + +function frxStrToXML(const s: String): String; +const + SpecChars = ['<', '>', '"', #10, #13, '&']; +var + i, lenRes, resI, ch: Integer; + pRes: PChar; + + procedure ReplaceChars(var s: String; i: Integer); + begin +{$IFDEF Delphi12} + Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1); +{$ELSE} + Insert('#' + IntToStr(Ord(s[i])) + ';', s, i + 1); +{$ENDIF} + s[i] := '&'; + end; + +begin + lenRes := Length(s); + + if lenRes < 32 then + begin + Result := s; + for i := lenRes downto 1 do +{$IFDEF Delphi12} + if CharInSet(s[i], SpecChars) then +{$ELSE} + if s[i] in SpecChars then +{$ENDIF} + if s[i] <> '&' then + ReplaceChars(Result, i) + else + begin + if Copy(s, i + 1, 5) = 'quot;' then + begin + Delete(Result, i, 6); + Insert('"', Result, i); + end; + end; + Exit; + end; + + { speed optimized code } + SetLength(Result, lenRes); + pRes := PChar(Result) - 1; + resI := 1; + i := 1; + + while i <= Length(s) do + begin + if resI + 5 > lenRes then + begin + Inc(lenRes, 256); + SetLength(Result, lenRes); + pRes := PChar(Result) - 1; + end; + +{$IFDEF Delphi12} + if CharInSet(s[i], SpecChars) then +{$ELSE} + if s[i] in SpecChars then +{$ENDIF} + begin + if (s[i] = '&') and (i <= Length(s) - 5) and (s[i + 1] = 'q') and + (s[i + 2] = 'u') and (s[i + 3] = 'o') and (s[i + 4] = 't') and (s[i + 5] = ';') then + begin + pRes[resI] := '&'; + pRes[resI + 1] := '#'; + pRes[resI + 2] := '3'; + pRes[resI + 3] := '4'; + pRes[resI + 4] := ';'; + Inc(resI, 4); + Inc(i, 5); + end + else + begin + pRes[resI] := '&'; + pRes[resI + 1] := '#'; + + ch := Ord(s[i]); + if ch < 10 then + begin + pRes[resI + 2] := Char(Chr(ch + $30)); + Inc(resI, 3); + end + else if ch < 100 then + begin + pRes[resI + 2] := Char(Chr(ch div 10 + $30)); + pRes[resI + 3] := Char(Chr(ch mod 10 + $30)); + Inc(resI, 4); + end + else + begin + pRes[resI + 2] := Char(Chr(ch div 100 + $30)); + pRes[resI + 3] := Char(Chr(ch mod 100 div 10 + $30)); + pRes[resI + 4] := Char(Chr(ch mod 10 + $30)); + Inc(resI, 5); + end; + pRes[resI] := ';'; + end; + end + else + pRes[resI] := s[i]; + Inc(resI); + Inc(i); + end; + + SetLength(Result, resI - 1); +end; + +function frxXMLToStr(const s: String): String; +var + i, j, h, n: Integer; +begin +{$IFDEF Delphi12} + Result := s; +{$ELSE} + Result := s; +{$ENDIF} + i := 1; + n := Length(s); + while i < n do + begin + if Result[i] = '&' then + if (i + 3 <= n) and (Result[i + 1] = '#') then + begin + j := i + 3; + while Result[j] <> ';' do + Inc(j); +{$IFDEF Delphi12} + h := StrToInt(String(Copy(Result, i + 2, j - i - 2))); +{$ELSE} + h := StrToInt(Copy(Result, i + 2, j - i - 2)); +{$ENDIF} + Delete(Result, i, j - i); + Result[i] := Char(Chr(h)); + Dec(n, j - i); + end + else if Copy(Result, i + 1, 5) = 'quot;' then + begin + Delete(Result, i, 5); + Result[i] := '"'; + Dec(n, 5); + end + else if Copy(Result, i + 1, 4) = 'amp;' then + begin + Delete(Result, i, 4); + Result[i] := '&'; + Dec(n, 4); + end + else if Copy(Result, i + 1, 3) = 'lt;' then + begin + Delete(Result, i, 3); + Result[i] := '<'; + Dec(n, 3); + end + else if Copy(Result, i + 1, 3) = 'gt;' then + begin + Delete(Result, i, 3); + Result[i] := '>'; + Dec(n, 3); + end; + Inc(i); + end; +end; + +function frxValueToXML(const Value: Variant): String; +begin + case TVarData(Value).VType of + varSmallint, varInteger, varByte: + Result := IntToStr(Value); + + varSingle, varDouble, varCurrency: + Result := FloatToStr(Value); + + varDate: + Result := DateToStr(Value); + + varOleStr, varString, varVariant{$IFDEF Delphi12}, varUString{$ENDIF}: + Result := frxStrToXML(Value); + + varBoolean: + if Value = True then Result := '1' else Result := '0'; + + else + Result := ''; + end; +end; + +{ TfrxXMLItem } + +constructor TfrxXMLItem.Create; +begin + FLoaded := True; +end; + +destructor TfrxXMLItem.Destroy; +begin + Clear; + if FParent <> nil then + FParent.FItems.Remove(Self); + inherited; +end; + +procedure TfrxXMLItem.Clear; +begin + if FItems <> nil then + begin + while FItems.Count > 0 do + TfrxXMLItem(FItems[0]).Free; + FItems.Free; + FItems := nil; + end; + if FUnloadable then + FLoaded := False; +end; + +function TfrxXMLItem.GetItems(Index: Integer): TfrxXMLItem; +begin + Result := TfrxXMLItem(FItems[Index]); +end; + +function TfrxXMLItem.GetCount: Integer; +begin + if FItems = nil then + Result := 0 else + Result := FItems.Count; +end; + +function TfrxXMLItem.Add: TfrxXMLItem; +begin + Result := TfrxXMLItem.Create; + AddItem(Result); +end; + +procedure TfrxXMLItem.AddItem(Item: TfrxXMLItem); +begin + if FItems = nil then + FItems := TList.Create; + + FItems.Add(Item); + if Item.FParent <> nil then + Item.FParent.FItems.Remove(Item); + Item.FParent := Self; +end; + +procedure TfrxXMLItem.InsertItem(Index: Integer; Item: TfrxXMLItem); +begin + AddItem(Item); + FItems.Delete(FItems.Count - 1); + FItems.Insert(Index, Item); +end; + +function TfrxXMLItem.Find(const Name: String): Integer; +var + i: Integer; +begin + Result := -1; + for i := 0 to Count - 1 do +{$IFDEF Delphi12} +// if AnsiStrComp(PAnsiChar(Items[i].Name), PAnsiChar(Name)) = 0 then + if AnsiCompareText(Items[i].Name, Name) = 0 then +{$ELSE} + if AnsiCompareText(Items[i].Name, Name) = 0 then +{$ENDIF} + begin + Result := i; + break; + end; +end; + +function TfrxXMLItem.FindItem(const Name: String): TfrxXMLItem; +var + i: Integer; +begin + i := Find(Name); + if i = -1 then + begin + Result := Add; + Result.Name := Name; + end + else + Result := Items[i]; +end; + +function TfrxXMLItem.GetOffset: Int64; +begin + Result := Int64(FHiOffset) * $100000000 + Int64(FLoOffset); +end; + +procedure TfrxXMLItem.SetOffset(const Value: Int64); +begin + FHiOffset := Value div $100000000; + FLoOffset := Value mod $100000000; +end; + +function TfrxXMLItem.Root: TfrxXMLItem; +begin + Result := Self; + while Result.Parent <> nil do + Result := Result.Parent; +end; + +function TfrxXMLItem.GetProp(Index: String): String; +var + i: Integer; +begin +{$IFDEF Delphi12} + i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText)); +{$ELSE} + i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText)); +{$ENDIF} + if i <> 0 then + begin +{$IFDEF Delphi12} + Result := Copy(FText, i + Length(Index + '="'), MaxInt); + Result := frxXMLToStr(Copy(Result, 1, Pos('"', Result) - 1)); +{$ELSE} + Result := Copy(FText, i + Length(String(Index) + '="'), MaxInt); + Result := frxXMLToStr(Copy(Result, 1, Pos('"', Result) - 1)); +{$ENDIF} + end + else + Result := ''; +end; + +procedure TfrxXMLItem.SetProp(Index: String; const Value: String); +var + i, j: Integer; + s: String; +begin +{$IFDEF Delphi12} + i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText)); +{$ELSE} + i := Pos(' ' + AnsiUppercase(Index) + '="', AnsiUppercase(' ' + FText)); +{$ENDIF} + if i <> 0 then + begin + j := i + Length(Index + '="'); + while (j <= Length(FText)) and (FText[j] <> '"') do + Inc(j); + Delete(FText, i, j - i + 1); + end + else + i := Length(FText) + 1; + + s := Index + '="' + frxStrToXML(Value) + '"'; + if (i > 1) and (FText[i - 1] <> ' ') then + s := ' ' + s; + Insert(s, FText, i); +end; + +function TfrxXMLItem.PropExists(const Index: String): Boolean; +begin +{$IFDEF Delphi12} + Result := Pos(' ' + AnsiUppercase(String(Index)) + '="', ' ' + AnsiUppercase(String(FText))) > 0; +{$ELSE} + Result := Pos(' ' + AnsiUppercase(Index) + '="', ' ' + AnsiUppercase(FText)) > 0; +{$ENDIF} +end; + +procedure TfrxXMLItem.DeleteProp(const Index: String); +var + i: Integer; +begin +{$IFDEF Delphi12} + i := Pos(' ' + AnsiUppercase(String(Index)) + '="', ' ' + AnsiUppercase(String(FText))); +{$ELSE} + i := Pos(' ' + AnsiUppercase(Index) + '="', ' ' + AnsiUppercase(FText)); +{$ENDIF} + if i > 0 then + begin + SetProp(Index, ''); + Delete(FText, i, Length(Index) + 4); + end; +end; + +function TfrxXMLItem.IndexOf(Item: TfrxXMLItem): Integer; +begin + Result := FItems.IndexOf(Item); +end; + + +{ TfrxXMLDocument } + +constructor TfrxXMLDocument.Create; +begin + FRoot := TfrxXMLItem.Create; +end; + +destructor TfrxXMLDocument.Destroy; +begin + DeleteTempFile; + FRoot.Free; + inherited; +end; + +procedure TfrxXMLDocument.Clear; +begin + FRoot.Clear; + DeleteTempFile; +end; + +procedure TfrxXMLDocument.CreateTempFile; +var +{$IFDEF Delphi12} + Path: WideString; + FileName: WideString; +{$ELSE} + Path: String[64]; + FileName: String[255]; +{$ENDIF} +begin + if FTempFileCreated then Exit; +{$IFDEF Delphi12} + SetLength(FileName, 255); + Path := FTempDir; + if (Path = '') or not DirectoryExists(String(Path)) then + begin + SetLength(Path, 255); + SetLength(Path, GetTempPath(255, @Path[1])); + end + else +{$ELSE} + Path := FTempDir; + if (Path = '') or not DirectoryExists(Path) then + Path[0] := Chr(GetTempPath(64, @Path[1])) else +{$ENDIF} + Path := Path + #0; + if (Path <> '') and (Path[Length(Path)] <> '\') then + Path := Path + '\'; + + GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]); +{$IFDEF Delphi12} + FTempFile := StrPas(PWideChar(@FileName[1])); +{$ELSE} + FTempFile := StrPas(@FileName[1]); +{$ENDIF} + FTempStream := TFileStream.Create(FTempFile, fmOpenReadWrite); + FTempFileCreated := True; +end; + +procedure TfrxXMLDocument.DeleteTempFile; +begin + if FTempFileCreated then + begin + FTempStream.Free; + FTempStream := nil; + DeleteFile(FTempFile); + FTempFileCreated := False; + end; + if FTempStream <> nil then + FTempStream.Free; + FTempStream := nil; +end; + +procedure TfrxXMLDocument.LoadItem(Item: TfrxXMLItem); +var + rd: TfrxXMLReader; + Text: String; +begin + if (FTempStream = nil) or Item.FLoaded or not Item.FUnloadable then Exit; + + rd := TfrxXMLReader.Create(FTempStream); + try + rd.Position := Item.Offset; + Text := Item.Text; + rd.ReadRootItem(Item); + Item.Text := Text; + Item.FLoaded := True; + finally + rd.Free; + end; +end; + +procedure TfrxXMLDocument.UnloadItem(Item: TfrxXMLItem); +var + wr: TfrxXMLWriter; +begin + if not Item.FLoaded or not Item.FUnloadable then Exit; + + CreateTempFile; + FTempStream.Position := FTempStream.Size; + wr := TfrxXMLWriter.Create(FTempStream); + try + Item.Offset := FTempStream.Size; + wr.WriteRootItem(Item); + Item.Clear; + finally + wr.Free; + end; +end; + +procedure TfrxXMLDocument.LoadFromStream(Stream: TStream; + AllowPartialLoading: Boolean = False); +var + rd: TfrxXMLReader; +begin + DeleteTempFile; + + rd := TfrxXMLReader.Create(Stream); + try + FRoot.Clear; + FRoot.Offset := 0; + rd.ReadHeader; + FOldVersion := rd.FOldFormat; + rd.ReadRootItem(FRoot, not AllowPartialLoading); + finally + rd.Free; + end; + + if AllowPartialLoading then + FTempStream := Stream else + FTempStream := nil; +end; + +procedure TfrxXMLDocument.SaveToStream(Stream: TStream); +var + wr: TfrxXMLWriter; +begin + wr := TfrxXMLWriter.Create(Stream); + wr.TempStream := FTempStream; + wr.FAutoIndent := FAutoIndent; + + try + wr.WriteHeader; + wr.WriteRootItem(FRoot); + finally + wr.Free; + end; +end; + +procedure TfrxXMLDocument.LoadFromFile(const FileName: String); +var + s: TFileStream; +begin + s := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + LoadFromStream(s, True); +end; + +procedure TfrxXMLDocument.SaveToFile(const FileName: String); +var + s: TFileStream; +begin + s := TFileStream.Create(FileName + '.tmp', fmCreate); + try + SaveToStream(s); + finally + s.Free; + end; + + DeleteTempFile; + DeleteFile(FileName); + RenameFile(FileName + '.tmp', FileName); + LoadFromFile(FileName); +end; + + +{ TfrxXMLReader } + +constructor TfrxXMLReader.Create(Stream: TStream); +begin + FStream := Stream; + FSize := Stream.Size; + FPosition := Stream.Position; + GetMem(FBuffer, 4096); +end; + +destructor TfrxXMLReader.Destroy; +begin + FreeMem(FBuffer, 4096); + FStream.Position := FPosition; + inherited; +end; + +procedure TfrxXMLReader.ReadBuffer; +begin + FBufEnd := FStream.Read(FBuffer^, 4096); + FBufPos := 0; +end; + +procedure TfrxXMLReader.SetPosition(const Value: Int64); +begin + FPosition := Value; + FStream.Position := Value; + FBufPos := 0; + FBufEnd := 0; +end; + +procedure TfrxXMLReader.RaiseException; +begin + raise TfrxInvalidXMLException.Create('Invalid file format'); +end; + +procedure TfrxXMLReader.ReadHeader; +var + s1, s2: String; + i: Integer; + Ver: String; +begin + ReadItem(s1, s2); + if Pos('?xml', s1) <> 1 then + RaiseException; + i := Pos('version=', s2); + if i <> 0 then + Ver := Copy(s2, i + 9, 3); + i := Pos('standalone=', s2); + if (Ver = '1.0') and (i = 0) then + FOldFormat := True; +end; + +procedure TfrxXMLReader.ReadItem(var {$IFDEF Delphi12}NameS{$ELSE}Name{$ENDIF}, Text: String); +var + c: Integer; + curpos, len: Integer; + state: (FindLeft, FindRight, FindComment, Done); + i, comment: Integer; + ps: PAnsiChar; +{$IFDEF Delphi12} + Name: AnsiString; +{$ENDIF} +begin + Text := ''; + comment := 0; + state := FindLeft; + curpos := 0; + len := 4096; + SetLength(Name, len); + ps := @Name[1]; + + while FPosition < FSize do + begin + if FBufPos = FBufEnd then + ReadBuffer; + c := Ord(FBuffer[FBufPos]); + Inc(FBufPos); + Inc(FPosition); + + if state = FindLeft then + begin + if c = Ord('<') then + state := FindRight + end + else if state = FindRight then + begin + if c = Ord('>') then + begin + state := Done; + break; + end + else if c = Ord('<') then + RaiseException + else + begin + ps[curpos] := AnsiChar(Chr(c)); + Inc(curpos); +{$IFDEF Delphi12} + if (curpos = 3) and (Pos(AnsiString('!--'), Name) = 1) then +{$ELSE} + if (curpos = 3) and (Pos('!--', Name) = 1) then +{$ENDIF} + begin + state := FindComment; + comment := 0; + curpos := 0; + end; + if curpos >= len - 1 then + begin + Inc(len, 4096); + SetLength(Name, len); + ps := @Name[1]; + end; + end; + end + else if State = FindComment then + begin + if comment = 2 then + begin + if c = Ord('>') then + state := FindLeft + else + comment := 0; + end + else begin + if c = Ord('-') then + Inc(comment) + else + comment := 0; + end; + end; + end; + + len := curpos; + SetLength(Name, len); + + if state = FindRight then + RaiseException; + if (Name <> '') and (Name[len] = ' ') then + SetLength(Name, len - 1); + +{$IFDEF Delphi12} + i := Pos(AnsiString(' '), Name); +{$ELSE} + i := Pos(' ', Name); +{$ENDIF} + if i <> 0 then + begin +{$IFDEF Delphi12} +if FOldFormat then + Text := String(Copy(Name, i + 1, len - i)) else + Text := UTF8Decode(Copy(Name, i + 1, len - i)); +{$ELSE} + Text := Copy(Name, i + 1, len - i); +{$ENDIF} + Delete(Name, i, len - i + 1); + end; +{$IFDEF Delphi12} + NameS := String(Name); +{$ENDIF} +{ Text := Copy(Name, i + 1, len - i); + Delete(Name, i, len - i + 1); + end;} +end; + +procedure TfrxXMLReader.ReadRootItem(Item: TfrxXMLItem; ReadChildren: Boolean = True); +var + LastName: String; + + function DoRead(RootItem: TfrxXMLItem): Boolean; + var + n: Integer; + ChildItem: TfrxXMLItem; + Done: Boolean; + CurPos: Int64; + begin + Result := False; + CurPos := Position; + ReadItem(RootItem.FName, RootItem.FText); + LastName := RootItem.FName; + + if (RootItem.Name = '') or (RootItem.Name[1] = '/') then + begin + Result := True; + Exit; + end; + + n := Length(RootItem.Name); + if RootItem.Name[n] = '/' then + begin + SetLength(RootItem.FName, n - 1); + Exit; + end; + + n := Length(RootItem.Text); + if (n > 0) and (RootItem.Text[n] = '/') then + begin + SetLength(RootItem.FText, n - 1); + Exit; + end; + + repeat + ChildItem := TfrxXMLItem.Create; + Done := DoRead(ChildItem); + if not Done then + RootItem.AddItem(ChildItem) else + ChildItem.Free; + until Done; + +{$IFDEF Delphi12} +// if (LastName <> '') and (AnsiStrComp(PAnsiChar(LastName), PAnsiChar(AnsiString('/' + RootItem.Name))) <> 0) then + if (LastName <> '') and (AnsiCompareText(LastName, '/' + RootItem.Name) <> 0) then +{$ELSE} + if (LastName <> '') and (AnsiCompareText(LastName, '/' + RootItem.Name) <> 0) then +{$ENDIF} + RaiseException; + +{$IFDEF Delphi12} +// n := Pos(' ld="0"', LowerCase(String(RootItem.Text))); + n := Pos(' ld="0"', LowerCase(RootItem.Text)); +{$ELSE} + n := Pos(' ld="0"', LowerCase(RootItem.Text)); +{$ENDIF} + if n <> 0 then + Delete(RootItem.FText, n, 7); + if not ReadChildren and (n <> 0) then + begin + RootItem.Clear; + RootItem.Offset := CurPos; + RootItem.FUnloadable := True; + RootItem.FLoaded := False; + end; + end; + +begin + DoRead(Item); +end; + + +{ TfrxXMLWriter } + +constructor TfrxXMLWriter.Create(Stream: TStream); +begin + FStream := Stream; +end; + +procedure TfrxXMLWriter.FlushBuffer; +begin + if FBuffer <> '' then + FStream.Write(FBuffer[1], Length(FBuffer)); + FBuffer := ''; +end; + +procedure TfrxXMLWriter.WriteLn(const s: AnsiString); +begin + if not FAutoIndent then + Insert(s, FBuffer, MaxInt) else + Insert(s + #13#10, FBuffer, MaxInt); + if Length(FBuffer) > 4096 then + FlushBuffer; +end; + +procedure TfrxXMLWriter.WriteHeader; +begin +{$IFDEF Delphi12} + WriteLn(''); +{$ELSE} + WriteLn(''); +{$ENDIF} +end; + +function Dup(n: Integer): AnsiString; +begin + SetLength(Result, n); + FillChar(Result[1], n, ' '); +end; + +procedure TfrxXMLWriter.WriteItem(Item: TfrxXMLItem; Level: Integer = 0); +var + s: AnsiString; +begin + if (Item.FText <> '') or Item.FUnloadable then + begin +{$IFDEF Delphi12} + s := UTF8Encode(Item.FText); +{$ELSE} + s := Item.FText; +{$ENDIF} + if (s = '') or (s[1] <> ' ') then + s := ' ' + s; + if Item.FUnloadable then + s := s + 'ld="0"'; + end + else + s := ''; + + if Item.Count = 0 then + begin + if Item.Value = '' then + s := s + '/>' + else +{$IFDEF Delphi12} + s := s + '>' + UTF8Encode(Item.Value) + '' +{$ELSE} + s := s + '>' + Item.Value + '' +{$ENDIF} + end + else + s := s + '>'; + if not FAutoIndent then + s := '<' + AnsiString(Item.Name) + s else + s := Dup(Level) + '<' + AnsiString(Item.Name) + s; + WriteLn(s); +end; + +procedure TfrxXMLWriter.WriteRootItem(RootItem: TfrxXMLItem); + + procedure DoWrite(RootItem: TfrxXMLItem; Level: Integer = 0); + var + i: Integer; + rd: TfrxXMLReader; + NeedClear: Boolean; + begin + NeedClear := False; + if not FAutoIndent then + Level := 0; + + if (FTempStream <> nil) and RootItem.FUnloadable and not RootItem.FLoaded then + begin + rd := TfrxXMLReader.Create(FTempStream); + try + rd.Position := RootItem.Offset; + rd.ReadRootItem(RootItem); + NeedClear := True; + finally + rd.Free; + end; + end; + + WriteItem(RootItem, Level); + for i := 0 to RootItem.Count - 1 do + DoWrite(RootItem[i], Level + 2); + if RootItem.Count > 0 then + if not FAutoIndent then + WriteLn('') else + WriteLn(Dup(Level) + ''); + + if NeedClear then + RootItem.Clear; + end; + +begin + DoWrite(RootItem); + FlushBuffer; +end; + +end. + + + +// diff --git a/official/4.8.11/Source/frxXMLSerializer.pas b/official/4.8.11/Source/frxXMLSerializer.pas new file mode 100644 index 0000000..77c59d0 --- /dev/null +++ b/official/4.8.11/Source/frxXMLSerializer.pas @@ -0,0 +1,885 @@ + +{******************************************} +{ } +{ FastReport v4.0 } +{ XML serializer } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxXMLSerializer; + +interface + +{$I frx.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + TypInfo, frxXML, frxClass +{$IFDEF Delphi6} +, Variants +{$ENDIF}; + + +type + TfrxGetAncestorEvent = procedure(const ComponentName: String; + var Ancestor: TPersistent) of object; + +{ TfrxXMLSerializer is the XML analogue of the Delphi component streaming - + TReader and TWriter } + + TfrxXMLSerializer = class(TObject) + private + FErrors: TStringList; + FFixups: TList; + FOwner: TfrxComponent; + FReader: TReader; + FReaderStream: TMemoryStream; + FSerializeDefaultValues: Boolean; + FStream: TStream; + FOldFormat: Boolean; + FOnGetAncestor: TfrxGetAncestorEvent; + procedure AddFixup(Obj: TPersistent; p: PPropInfo; Value: String); + procedure ClearFixups; + procedure FixupReferences; + public + constructor Create(Stream: TStream); + destructor Destroy; override; + function ObjToXML(Obj: TPersistent; const Add: String = ''; Ancestor: TPersistent = nil): String; + function ReadComponent(Root: TfrxComponent): TfrxComponent; + function ReadComponentStr(Root: TfrxComponent; s: String; DontFixup: Boolean = False): TfrxComponent; + function WriteComponentStr(c: TfrxComponent): String; + procedure ReadRootComponent(Root: TfrxComponent; XMLItem: TfrxXMLItem = nil); + procedure CopyFixupList(FixList: TList); + procedure ReadPersistentStr(Root: TComponent; Obj: TPersistent; const s: String); + procedure WriteComponent(c: TfrxComponent); + procedure WriteRootComponent(Root: TfrxComponent; SaveChildren: Boolean = True; + XMLItem: TfrxXMLItem = nil; Streaming: Boolean = False); + procedure XMLToObj(const s: String; Obj: TPersistent); + property Errors: TStringList read FErrors; + property Owner: TfrxComponent read FOwner write FOwner; + property Stream: TStream read FStream; + property SerializeDefaultValues: Boolean read FSerializeDefaultValues + write FSerializeDefaultValues; + property OnGetAncestor: TfrxGetAncestorEvent read FOnGetAncestor write FOnGetAncestor; + property OldFormat: Boolean read FOldFormat write FOldFormat; + end; + + TfrxFixupItem = class(TObject) + public + Obj: TPersistent; + PropInfo: PPropInfo; + Value: String; + end; + + +implementation + +uses frxUtils, frxRes, frxUnicodeUtils; + + +type + THackComponent = class(TComponent); + THackPersistent = class(TPersistent); + THackReader = class(TReader); + + +{ TfrxXMLSerializer } + +constructor TfrxXMLSerializer.Create(Stream: TStream); +begin + FErrors := TStringList.Create; + FErrors.Sorted := True; + FErrors.Duplicates := dupIgnore; + FFixups := TList.Create; + FStream := Stream; + FReaderStream := TMemoryStream.Create; + FReader := TReader.Create(FReaderStream, 4096); +{$IFDEF Delphi12} + FOldFormat := False; +{$ELSE} + FOldFormat := True; +{$ENDIF} +end; + +destructor TfrxXMLSerializer.Destroy; +begin + FErrors.Free; + FReader.Free; + FReaderStream.Free; + ClearFixups; + FFixups.Free; + inherited; +end; + +procedure TfrxXMLSerializer.ClearFixups; +begin + while FFixups.Count > 0 do + begin + TfrxFixupItem(FFixups[0]).Free; + FFixups.Delete(0); + end; +end; + +procedure TfrxXMLSerializer.AddFixup(Obj: TPersistent; p: PPropInfo; + Value: String); +var + Item: TfrxFixupItem; +begin + Item := TfrxFixupItem.Create; + Item.Obj := Obj; + Item.PropInfo := p; + Item.Value := Value; + FFixups.Add(Item); +end; + +procedure TfrxXMLSerializer.FixupReferences; +var + i: Integer; + Item: TfrxFixupItem; + Ref: TObject; +begin + for i := 0 to FFixups.Count - 1 do + begin + Item := FFixups[i]; + Ref := nil; + if FOwner <> nil then + Ref := FOwner.FindObject(Item.Value); + if Ref = nil then + Ref := frxFindComponent(FOwner, Item.Value); + if Ref <> nil then + SetOrdProp(Item.Obj, Item.PropInfo, Integer(Ref)); + end; + + FReader.FixupReferences; + FReader.EndReferences; + ClearFixups; +end; + +procedure TfrxXMLSerializer.XMLToObj(const s: String; Obj: TPersistent); +var + i, j, start, len, code: Integer; + i1, start1, len1: Integer; + Name, Value: String; + Obj1: TPersistent; + p: PPropInfo; + ps, ps1: PChar; + + procedure DoNonPublishedProps; + begin + FReaderStream.Clear; + frxStringToStream(Value, FReaderStream); + FReaderStream.Position := 0; + FReader.Position := 0; + + try + while FReader.Position < FReaderStream.Size do + THackReader(FReader).ReadProperty(Obj1); + except + end; + end; + +begin + { speed optimized code. affects the speed of loading prepared page in the preview } + len := Length(s); + i := 1; + ps := PChar(s) - 1; + while i < len do + begin + j := i; + len1 := len; + ps1 := ps; + while (j < len1) and (ps1[j] = ' ') do + Inc(j); + start := j; + while (j < len1) and (ps1[j] <> '=') do + Inc(j); + i := j; + if i < len then + begin + j := i - 1; + while (j > 0) and (ps1[j] = ' ') do + Dec(j); + Name := Copy(s, start, j - start + 1); + if Name = '' then break; + j := i; + len1 := len; + while (j < len1) and (ps1[j] <> '"') do + Inc(j); + start := j + 1; + Inc(j); + while (j < len1) and (ps1[j] <> '"') do + Inc(j); + i := j; + Value := Copy(s, start, i - start); + Inc(i); + + Obj1 := Obj; + + { check multiple properties } + len1 := Length(Name); + start1 := 1; + i1 := 1; + while (i1 < len1) and (Name[i1] <> '.') do + Inc(i1); + if i1 < len1 then + begin + while i1 < len1 do + begin + p := GetPropInfo(Obj1.ClassInfo, Copy(String(Name), start1, i1 - start1)); + if p = nil then + break; + Obj1 := TPersistent(GetOrdProp(Obj1, p)); + start1 := i1 + 1; + Inc(i1); + while (i1 < len1) and (Name[i1] <> '.') do + Inc(i1); + end; + Name := Copy(Name, start1, MaxInt); + end; + + try + if Length(Name) = 1 then + begin + { special properties } + case Name[1] of + 'x': + begin + TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value); + continue; + end; + 'u': + begin +{$IFDEF Delphi12} + if FOldFormat then + TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Utf8Decode(AnsiString(Value))) + else + TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value); +{$ELSE} + TfrxCustomMemoView(Obj1).Text := Utf8Decode(frxXMLToStr(Value)); +{$ENDIF} + continue; + end; + 'l': + begin + TfrxComponent(Obj1).Left := frxStrToFloat(String(Value)); + continue; + end; + 't': + begin + TfrxComponent(Obj1).Top := frxStrToFloat(String(Value)); + continue; + end; + 'w': + begin + TfrxComponent(Obj1).Width := frxStrToFloat(String(Value)); + continue; + end; + 'h': + begin + TfrxComponent(Obj1).Height := frxStrToFloat(String(Value)); + continue; + end; + end; + end + else + begin + if Name = 'Text' then + begin + if Obj1 is TStrings then + begin + {$IFNDEF Delphi12} + if not FOldFormat then + TStrings(Obj1).Text := String(UTF8Decode(frxXMLToStr(Value))) else + {$ENDIF} + TStrings(Obj1).Text := frxXMLToStr(Value); + continue; + end + else if Obj1 is {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF} then + begin + {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}(Obj1).Text := frxXMLToStr(Value); + continue; + end + else if Obj1 is TfrxCustomMemoView then + begin + {$IFDEF Delphi12} + if FOldFormat then + TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Utf8Decode(AnsiString(Value))) + else TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value); + {$ELSE} + TfrxCustomMemoView(Obj1).Text := Utf8Decode(frxXMLToStr(Value)); + {$ENDIF} + continue; + end + end + else if Name = 'PropData' then + begin + DoNonPublishedProps; + continue; + end + else if (Obj1 is TfrxReport) and (Name = 'Name') then + continue; + end; + + p := GetPropInfo(Obj1.ClassInfo, String(Name)); + if (p <> nil) and (p.SetProc <> nil) then + case p.PropType^.Kind of + tkInteger, tkSet, tkChar, tkWChar: + SetOrdProp(Obj1, p, StrToInt(String(Value))); + + tkEnumeration: + begin + Val(String(Value), j, code); + if code = 0 then + SetOrdProp(Obj1, p, j) else + SetOrdProp(Obj1, p, GetEnumValue(p.PropType^, String(Value))); + end; + + tkFloat: + SetFloatProp(Obj1, p, frxStrToFloat(String(Value))); + + tkString, tkLString{$IFDEF Delphi12}{$ELSE}, tkWString{$ENDIF}: +{$IFNDEF Delphi12} + if not FOldFormat then + SetStrProp(Obj1, p, String(UTF8Decode(frxXMLToStr(Value)))) else +{$ENDIF} + SetStrProp(Obj1, p, String(frxXMLToStr(Value))); +{$IFDEF Delphi12} + tkUString, tkWString: + SetStrProp(Obj1, p, frxXMLToStr(Value)); +{$ENDIF} + tkClass: + AddFixup(Obj1, p, String(Value)); + + tkVariant: + SetVariantProp(Obj1, p, frxXMLToStr(Value)); + end; + except + on E: Exception do + FErrors.Add(E.Message); + end; + end; + end; +end; + +function TfrxXMLSerializer.ObjToXML(Obj: TPersistent; const Add: String = ''; + Ancestor: TPersistent = nil): String; +var + TypeInfo: PTypeInfo; + PropCount: Integer; + PropList: PPropList; + i: Integer; + s: String; + ws: WideString; + Flag: Boolean; + + procedure DoOrdProp; + var + Value: Integer; + + function IsDefault: Boolean; + begin + if Ancestor <> nil then + Result := Value = GetOrdProp(Ancestor, PropList[i]) + else + Result := Value = PropList[i].Default; + end; + + begin + Value := GetOrdProp(Obj, PropList[i]); + if not IsDefault or FSerializeDefaultValues then + if PropList[i].PropType^.Kind = tkEnumeration then + s := GetEnumName(PropList[i].PropType^, Value) + else + s := IntToStr(Value); + end; + + procedure DoFloatProp; + var + Value: Extended; + + function IsDefault: Boolean; + begin + if Ancestor <> nil then + Result := Abs(Value - GetFloatProp(Ancestor, PropList[i])) < 1e-6 + else + Result := False; + end; + + begin + Value := GetFloatProp(Obj, PropList[i]); +// commented out due to bug with tfrxmemoview.linespacing=0 + if not IsDefault or FSerializeDefaultValues then + s := FloatToStr(Value); + end; + + procedure DoStrProp; + var + Value: String; + + function IsDefault: Boolean; + begin + if Ancestor <> nil then + Result := Value = GetStrProp(Ancestor, PropList[i]) + else + Result := Value = ''; + end; + + begin + Value := GetStrProp(Obj, PropList[i]); + if not IsDefault or FSerializeDefaultValues then + s := frxStrToXML(Value); + end; + + procedure DoVariantProp; + var + Value: Variant; + + function IsDefault: Boolean; + begin + if Ancestor <> nil then + Result := Value = GetVariantProp(Ancestor, PropList[i]) + else + Result := False; + end; + + begin + Value := GetVariantProp(Obj, PropList[i]); + if not IsDefault or FSerializeDefaultValues then + s := frxStrToXML(VarToStr(Value)); + end; + + procedure DoClassProp; + var + FClass: TClass; + FComp, FAncComp: TComponent; + FObj, FAncObj: TPersistent; + begin + FClass := GetTypeData(PropList[i].PropType^).ClassType; + if FClass.InheritsFrom(TComponent) then + begin + FComp := TComponent(GetOrdProp(Obj, PropList[i])); + if Ancestor <> nil then + FAncComp := TComponent(GetOrdProp(Ancestor, PropList[i])) + else + FAncComp := nil; + + if Ancestor <> nil then + begin + if (FComp = nil) and (FAncComp = nil) then Exit; + if (FComp <> nil) and (FAncComp <> nil) then + if CompareText(FComp.Name, FAncComp.Name) = 0 then Exit; + if (FComp = nil) and (FAncComp <> nil) then + begin + s := 'nil'; + Exit; + end; + end; + + if FComp <> nil then + s := frxGetFullName(FOwner, FComp); + end + else if FClass.InheritsFrom(TPersistent) then + begin + FObj := TPersistent(GetOrdProp(Obj, PropList[i])); + if Ancestor <> nil then + FAncObj := TPersistent(GetOrdProp(Ancestor, PropList[i])) + else + FAncObj := nil; + + if FObj is TStrings then + begin + if Ancestor <> nil then + if TStrings(FObj).Text = TStrings(FAncObj).Text then + Exit; +{$IFDEF Delphi12} +// s := UTF8Encode(TStrings(FObj).Text); + s := TStrings(FObj).Text; +{$ELSE} + s := TStrings(FObj).Text; +{$ENDIF} + if (Length(s) >= 2) and + (s[Length(s) - 1] = #13) and (s[Length(s)] = #10) then + Delete(s, Length(s) - 1, 2); + s := ' ' + Add + String(PropList[i].Name) + '.Text="' + + frxStrToXML(s) + '"'; + + end + else if FObj is {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF} then + begin + // skip, handle separately + end + else + s := ObjToXML(FObj, Add + String(PropList[i].Name) + '.', FAncObj); + Flag := True; + end; + end; + + procedure DoNonPublishedProps; + var + wr: TWriter; + ms, AncMs: TMemoryStream; + begin + ms := TMemoryStream.Create; + try + wr := TWriter.Create(ms, 4096); + wr.Root := FOwner; + + try + THackPersistent(Obj).DefineProperties(wr); + finally + wr.Free; + end; + + if ms.Size > 0 then + begin + if Ancestor <> nil then + begin + AncMs := TMemoryStream.Create; + try + wr := TWriter.Create(AncMs, 4096); + wr.Root := FOwner; + + try + THackPersistent(Ancestor).DefineProperties(wr); + finally + wr.Free; + end; + if frxStreamCRC32(ms) = frxStreamCRC32(AncMs) then + Exit; + finally + AncMs.Free; + end; + end; + + s := frxStreamToString(ms); + Result := Result + ' ' + Add + 'PropData="' + s + '"'; + end; + finally + ms.Free; + end; + end; + +begin + Result := ''; + if Obj = nil then Exit; + + TypeInfo := Obj.ClassInfo; + PropCount := GetTypeData(TypeInfo).PropCount; + GetMem(PropList, PropCount * SizeOf(PPropInfo)); + GetPropInfos(TypeInfo, PropList); + + try + if Obj is TfrxComponent then + begin + TfrxComponent(Obj).IsWriting := True; + if (Ancestor = nil) and Assigned(FOnGetAncestor) then + FOnGetAncestor(TfrxComponent(Obj).Name, Ancestor); + end; + if Ancestor is TfrxComponent then + TfrxComponent(Ancestor).IsWriting := True; + + for i := 0 to PropCount - 1 do + begin + s := ''; + Flag := False; + + if IsStoredProp(Obj, PropList[i]) then + case PropList[i].PropType^.Kind of + tkInteger, tkSet, tkChar, tkWChar, tkEnumeration: + DoOrdProp; + + tkFloat: + DoFloatProp; + + tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}: + DoStrProp; + + tkClass: + DoClassProp; + + tkVariant: + DoVariantProp; + end; + + if s <> '' then + if Flag then + Result := Result + s + else + Result := Result + ' ' + Add + String(PropList[i].Name) + '="' + s + '"'; + end; + + if Obj is TfrxCustomMemoView then + if (Ancestor = nil) or + (TfrxCustomMemoView(Obj).Text <> TfrxCustomMemoView(Ancestor).Text) then + begin + ws := TfrxCustomMemoView(Obj).Text; + if (Length(ws) >= 2) and + (ws[Length(ws) - 1] = #13) and (ws[Length(ws)] = #10) then + Delete(ws, Length(ws) - 1, 2); +{$IFDEF Delphi12} + Result := Result + ' Text="' + frxStrToXML(ws) + '"'; +{$ELSE} + Result := Result + ' Text="' + frxStrToXML(Utf8Encode(ws)) + '"'; +{$ENDIF} + end; + + DoNonPublishedProps; + + finally + if Obj is TfrxComponent then + TfrxComponent(Obj).IsWriting := False; + if Ancestor is TfrxComponent then + TfrxComponent(Ancestor).IsWriting := False; + FreeMem(PropList, PropCount * SizeOf(PPropInfo)); + end; +end; + +procedure TfrxXMLSerializer.ReadRootComponent(Root: TfrxComponent; + XMLItem: TfrxXMLItem = nil); +var + XMLDoc: TfrxXMLDocument; + CompList: TList; + + procedure DoRead(Item: TfrxXMLItem; Owner: TfrxComponent); + var + i: Integer; + c: TfrxComponent; + IsAncestor: Boolean; + begin +{$IFDEF Delphi12} +// IsAncestor := AnsiStrIComp(PAnsiChar(Item.Name), PAnsiChar(AnsiString('inherited'))) = 0; + IsAncestor := CompareText(Item.Name, 'inherited') = 0; +{$ELSE} + IsAncestor := CompareText(Item.Name, 'inherited') = 0; +{$ENDIF} + if not IsAncestor then + try + FindClass(String(Item.Name)); + except + FErrors.Add(frxResources.Get('xrCantFindClass') + ' ' + String(Item.Name)); + Exit; + end; + + if Owner <> nil then + begin + c := FOwner.FindComponent(String(Item.Prop['Name'])) as TfrxComponent; + if not IsAncestor and (c = nil) then + begin + c := TfrxComponent(FindClass(String(Item.Name)).NewInstance); + c.Create(Owner); + end; + end + else + c := Root; + + if c <> nil then + begin + c.IsLoading := True; + XMLToObj(Item.Text, c); + CompList.Add(c); + + for i := 0 to Item.Count - 1 do + DoRead(Item[i], c); + end; + end; + + procedure DoLoaded; + var + i: Integer; + c: TfrxComponent; + begin + for i := 0 to CompList.Count - 1 do + begin + c := CompList[i]; + c.IsLoading := False; + if not (c is TfrxReport) then + THackComponent(c).Loaded; + end; + end; + +begin + if Owner = nil then + Owner := Root; + XMLDoc := nil; + CompList := TList.Create; + + if XMLItem = nil then + begin + XMLDoc := TfrxXMLDocument.Create; + XMLItem := XMLDoc.Root; + try + XMLDoc.LoadFromStream(FStream); + FOldFormat := XMLDoc.OldVersion; + except + XMLDoc.Free; + CompList.Free; + raise; + end; + end; + + FReader.Root := FOwner; + FReader.BeginReferences; + try + DoRead(XMLItem, nil); + FixupReferences; + DoLoaded; + finally + if XMLDoc <> nil then + XMLDoc.Free; + CompList.Free; + end; +end; + +procedure TfrxXMLSerializer.WriteRootComponent(Root: TfrxComponent; + SaveChildren: Boolean = True; XMLItem: TfrxXMLItem = nil; Streaming: Boolean = False); +var + XMLDoc: TfrxXMLDocument; + + procedure DoWrite(Item: TfrxXMLItem; ARoot: TfrxComponent); + var + i: Integer; + begin + if ARoot.IsAncestor and not Streaming then + Item.Name := 'inherited' + else + Item.Name := ARoot.ClassName; + if ARoot = Root then + Item.Text := ObjToXML(ARoot) + else + Item.Text := 'Name="' + ARoot.Name + '"' + ObjToXML(ARoot); + if SaveChildren then + for i := 0 to ARoot.Objects.Count - 1 do + DoWrite(Item.Add, ARoot.Objects[i]); + end; + +begin + if Owner = nil then + Owner := Root; + XMLDoc := nil; + + if XMLItem = nil then + begin + XMLDoc := TfrxXMLDocument.Create; + XMLItem := XMLDoc.Root; + XMLDoc.AutoIndent := True; + end; + + try + DoWrite(XMLItem, Root); + if XMLDoc <> nil then + XMLDoc.SaveToStream(FStream); + finally + if XMLDoc <> nil then + XMLDoc.Free; + end; +end; + +function TfrxXMLSerializer.ReadComponent(Root: TfrxComponent): TfrxComponent; +var + rd: TfrxXMLReader; + RootItem: TfrxXMLItem; +begin + rd := TfrxXMLReader.Create(FStream); + RootItem := TfrxXMLItem.Create; + + try + rd.ReadRootItem(RootItem, False); + Result := ReadComponentStr(Root, RootItem.Name + ' ' + RootItem.Text); + finally + rd.Free; + RootItem.Free; + end; +end; + +procedure TfrxXMLSerializer.WriteComponent(c: TfrxComponent); +var + s: AnsiString; +begin +{$IFDEF Delphi12} + s := '<' + UTF8Encode(WriteComponentStr(c)) + '/>'; +{$ELSE} + s := '<' + WriteComponentStr(c) + '/>'; +{$ENDIF} + FStream.Write(s[1], Length(s)); +end; + +function TfrxXMLSerializer.ReadComponentStr(Root: TfrxComponent; + s: String; DontFixup: Boolean = False): TfrxComponent; +var + n: Integer; + s1: String; +begin + Owner := Root; + if Trim(String(s)) = '' then + Result := nil + else + begin + n := Pos(' ', s); + s1 := Copy(s, n + 1, MaxInt); + Delete(s, n, MaxInt); + + Result := TfrxComponent(FindClass(s).NewInstance); + Result.Create(Root); + + FReader.Root := Root; + FReader.BeginReferences; + try + Result.IsLoading := True; + XMLToObj(s1, Result); + finally + if DontFixup then + begin + FReader.EndReferences; + ClearFixups; + end + else + FixupReferences; + Result.IsLoading := False; + if not (Result is TfrxReport) then + THackComponent(Result).Loaded; + end; + end; +end; + +function TfrxXMLSerializer.WriteComponentStr(c: TfrxComponent): String; +begin + Result := c.ClassName + ObjToXML(c); +end; + +procedure TfrxXMLSerializer.ReadPersistentStr(Root: TComponent; + Obj: TPersistent; const s: String); +begin + FReader.Root := Root; + FReader.BeginReferences; + XMLToObj(s, Obj); + FixupReferences; +end; + +procedure TfrxXMLSerializer.CopyFixupList(FixList: TList); +var + i: Integer; + function CopyItem: TfrxFixupItem; + var + Item: TfrxFixupItem; + begin + Item := TfrxFixupItem(FFixups[i]); + Result := TfrxFixupItem.Create; + Result.Obj := Item.Obj; + Result.PropInfo := Item.PropInfo; + Result.Value := Item.Value; + end; +begin + if FixList = nil then exit; + for i := 0 to FFixups.Count - 1 do + FixList.Add(CopyItem); +end; + +end. + + + +// diff --git a/official/4.8.11/Source/frxZLib.pas b/official/4.8.11/Source/frxZLib.pas new file mode 100644 index 0000000..bb2463f --- /dev/null +++ b/official/4.8.11/Source/frxZLib.pas @@ -0,0 +1,629 @@ +{***************************************************************************** +* ZLibEx.pas (zlib 1.2.1) * +* * +* copyright (c) 2002-2003 Roberto Della Pasqua (www.dellapasqua.com) * +* copyright (c) 2000-2002 base2 technologies (www.base2ti.com) * +* copyright (c) 1997 Borland International (www.borland.com) * +* * +* revision history * +* 2003.12.18 updated with latest zlib 1.2.1 (see www.zlib.org) * +* obj's compiled with fastest speed optimizations (bcc 5.6.4) * +* (hint:see basm newsgroup about a Move RTL fast replacement) * +* Thanks to Cosmin Truta for the pascal zlib reference * +* * +* 2002.11.02 ZSendToBrowser: deflate algorithm for HTTP1.1 compression * +* 2002.10.24 ZFastCompressString and ZFastDecompressString:300% faster * +* 2002.10.15 recompiled zlib 1.1.4 c sources with speed optimizations * +* (and targeting 686+ cpu) and changes to accomodate Borland * +* standards (C++ v5.6 compiler) * +* 2002.10.15 optimized move mem for not aligned structures (strings,etc)* +* 2002.10.15 little changes to avoid system unique string calls * +* * +* 2002.03.15 updated to zlib version 1.1.4 * +* 2001.11.27 enhanced TZDecompressionStream.Read to adjust source * +* stream position upon end of compression data * +* fixed endless loop in TZDecompressionStream.Read when * +* destination count was greater than uncompressed data * +* 2001.10.26 renamed unit to integrate "nicely" with delphi 6 * +* 2000.11.24 added soFromEnd condition to TZDecompressionStream.Seek * +* added ZCompressStream and ZDecompressStream * +* 2000.06.13 optimized, fixed, rewrote, and enhanced the zlib.pas unit * +* included on the delphi cd (zlib version 1.1.3) * +* * +* acknowledgements * +* erik turner Z*Stream routines * +* david bennion finding the nastly little endless loop quirk with the * +* TZDecompressionStream.Read method * +* burak kalayci informing me about the zlib 1.1.4 update * +*****************************************************************************} + +unit frxZLib; + +interface + +{$I frx.inc} + +uses + Windows, + Sysutils, + Classes; + +const + ZLIB_VERSION = '1.2.1'; + +type + TZAlloc = function(opaque: Pointer; items, size: Integer): Pointer; + TZFree = procedure(opaque, block: Pointer); + TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); + + {** TZStreamRec ***********************************************************} + + TZStreamRec = packed record + next_in: PByte;//AnsiChar; // next input byte + avail_in: Longint; // number of bytes available at next_in + total_in: Longint; // total nb of input bytes read so far + next_out: PByte;//AnsiChar; // next output byte should be put here + avail_out: Longint; // remaining free space at next_out + total_out: Longint; // total nb of bytes output so far + msg: PByte;//AnsiChar; // last error message, NULL if no error + state: Pointer; // not visible by applications + zalloc: TZAlloc; // used to allocate the internal state + zfree: TZFree; // used to free the internal state + opaque: Pointer; // private data object passed to zalloc and zfree + data_type: Integer; // best guess about the data type: ascii or binary + adler: Longint; // adler32 value of the uncompressed data + reserved: Longint; // reserved for future use + end; + + {** TCustomZStream ********************************************************} + + TCustomZStream = class(TStream) + private + FStream: TStream; + FStreamPos: Integer; + FOnProgress: TNotifyEvent; + FZStream: TZStreamRec; + FBuffer: array[Word] of Byte;//AnsiChar; + protected + constructor Create(stream: TStream); + procedure DoProgress; dynamic; + property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; + end; + + {** TZCompressionStream ***************************************************} + + TZCompressionStream = class(TCustomZStream) + private + function GetCompressionRate: Single; + public + constructor Create(dest: TStream; compressionLevel: TZCompressionLevel = zcDefault); + destructor Destroy; override; + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + property CompressionRate: Single read GetCompressionRate; + property OnProgress; + end; + + {** TZDecompressionStream *************************************************} + + TZDecompressionStream = class(TCustomZStream) + public + constructor Create(source: TStream); + destructor Destroy; override; + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + property OnProgress; + end; + +{** zlib public routines ****************************************************} + +{***************************************************************************** +* ZCompress * +* * +* pre-conditions * +* inBuffer = pointer to uncompressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* level = compression level * +* * +* post-conditions * +* outBuffer = pointer to compressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel = zcDefault); + +{***************************************************************************** +* ZDecompress * +* * +* pre-conditions * +* inBuffer = pointer to compressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* outEstimate = estimated size of uncompressed data (bytes) * +* * +* post-conditions * +* outBuffer = pointer to decompressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer = 0); + +{** utility routines ********************************************************} + +function adler32(adler: LongInt; const buf: PAnsiChar; len: Integer): LongInt; +function crc32(crc: LongInt; const buf: PAnsiChar; len: Integer): LongInt; +function compressBound(sourceLen: LongInt): LongInt; + +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; + recsize: Integer): Integer; forward; +function inflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function inflateEnd(var strm: TZStreamRec): Integer; forward; +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; + recsize: Integer): Integer; forward; +function deflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function deflateEnd(var strm: TZStreamRec): Integer; forward; +{****************************************************************************} + + +type + EZLibError = class(Exception); + EZCompressionError = class(EZLibError); + EZDecompressionError = class(EZLibError); + +implementation + +{** link zlib 1.2.1 **************************************************************} +{** bcc32 flags: -c -6 -O2 -Ve -X- -pr -a8 -b -d -k- -vi -tWM -r -RT- -DFASTEST **} + +{$L adler32.zobj} +{$L compress.zobj} +{$L crc32.zobj} +{$L deflate.zobj} +{$L infback.zobj} +{$L inffast.zobj} +{$L inflate.zobj} +{$L inftrees.zobj} +{$L trees.zobj} + +{***************************************************************************** +* note: do not reorder the above -- doing so will result in external * +* functions being undefined * +*****************************************************************************} + +const + {** flush constants *******************************************************} + + Z_NO_FLUSH = 0; + Z_FINISH = 4; + + {** return codes **********************************************************} + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); + + {** compression levels ****************************************************} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); + + {** compression methods ***************************************************} + + Z_DEFLATED = 8; + + {** return code messages **************************************************} + + _z_errmsg: array[0..9] of PChar = ( + 'need dictionary', // Z_NEED_DICT (2) + 'stream end', // Z_STREAM_END (1) + '', // Z_OK (0) + 'file error', // Z_ERRNO (-1) + 'stream error', // Z_STREAM_ERROR (-2) + 'data error', // Z_DATA_ERROR (-3) + 'insufficient memory', // Z_MEM_ERROR (-4) + 'buffer error', // Z_BUF_ERROR (-5) + 'incompatible version', // Z_VERSION_ERROR (-6) + '' + ); + + ZLevels: array[TZCompressionLevel] of Shortint = ( + Z_NO_COMPRESSION, + Z_BEST_SPEED, + Z_DEFAULT_COMPRESSION, + Z_BEST_COMPRESSION + ); + + SZInvalid = 'Invalid ZStream operation!'; + +{** deflate routines ********************************************************} + +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; + recsize: Integer): Integer; external; + +function deflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function deflateEnd(var strm: TZStreamRec): Integer; external; + +{** inflate routines ********************************************************} + +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; + recsize: Integer): Integer; external; + +function inflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function inflateEnd(var strm: TZStreamRec): Integer; external; + +function inflateReset(var strm: TZStreamRec): Integer; external; + +{** utility routines *******************************************************} + +function adler32; external; +function crc32; external; +function compressBound; external; + +{** zlib function implementations *******************************************} + +function zcalloc(opaque: Pointer; items, size: Integer): Pointer; +begin + GetMem(result, items * size); +end; + +procedure zcfree(opaque, block: Pointer); +begin + FreeMem(block); +end; + +{** c function implementations **********************************************} + +procedure _memset(p: Pointer; b: Byte; count: Integer); cdecl; +begin + FillChar(p^, count, b); +end; + +procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; +begin + Move(source^, dest^, count); +end; + +{** custom zlib routines ****************************************************} + +function DeflateInit(var stream: TZStreamRec; level: Integer): Integer; +begin + result := DeflateInit_(stream, level, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +function InflateInit(var stream: TZStreamRec): Integer; +begin + result := InflateInit_(stream, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +{****************************************************************************} + +function ZCompressCheck(code: Integer): Integer; +begin + result := code; + + if code < 0 then + begin + raise EZCompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +function ZDecompressCheck(code: Integer): Integer; +begin + Result := code; + + if code < 0 then + begin + raise EZDecompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel); +const + delta = 256; +var + zstream: TZStreamRec; +begin + FillChar(zstream, SizeOf(TZStreamRec), 0); + + outSize := ((inSize + (inSize div 10) + 12) + 255) and not 255; + GetMem(outBuffer, outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZCompressCheck(DeflateInit(zstream, ZLevels[level])); + + try + while ZCompressCheck(deflate(zstream, Z_FINISH)) <> Z_STREAM_END do + begin + Inc(outSize, delta); + ReallocMem(outBuffer, outSize); + + zstream.next_out := PByte{AnsiChar}(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZCompressCheck(deflateEnd(zstream)); + end; + + ReallocMem(outBuffer, zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer); +var + zstream: TZStreamRec; + delta: Integer; +begin + FillChar(zstream, SizeOf(TZStreamRec), 0); + + delta := (inSize + 255) and not 255; + + if outEstimate = 0 then outSize := delta + else outSize := outEstimate; + + GetMem(outBuffer, outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZDecompressCheck(InflateInit(zstream)); + + try + while ZDecompressCheck(inflate(zstream, Z_NO_FLUSH)) <> Z_STREAM_END do + begin + Inc(outSize, delta); + ReallocMem(outBuffer, outSize); + + zstream.next_out := PByte{AnsiChar}(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZDecompressCheck(inflateEnd(zstream)); + end; + + ReallocMem(outBuffer, zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +{** TCustomZStream **********************************************************} + +constructor TCustomZStream.Create(stream: TStream); +begin + inherited Create; + FStream := stream; + FStreamPos := stream.Position; +end; + +procedure TCustomZStream.DoProgress; +begin + if Assigned(FOnProgress) then FOnProgress(Self); +end; + +{** TZCompressionStream *****************************************************} + +constructor TZCompressionStream.Create(dest: TStream; + compressionLevel: TZCompressionLevel); +begin + inherited Create(dest); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + ZCompressCheck(DeflateInit(FZStream, ZLevels[compressionLevel])); +end; + +destructor TZCompressionStream.Destroy; +begin + FZStream.next_in := nil; + FZStream.avail_in := 0; + + try + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while ZCompressCheck(deflate(FZStream, Z_FINISH)) <> Z_STREAM_END do + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer) - FZStream.avail_out); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + end; + + if FZStream.avail_out < SizeOf(FBuffer) then + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer) - FZStream.avail_out); + end; + finally + deflateEnd(FZStream); + end; + + inherited Destroy; +end; + +function TZCompressionStream.Read(var buffer; count: Longint): Longint; +begin + raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.Write(const buffer; count: Longint): Longint; +begin + FZStream.next_in := @buffer; + FZStream.avail_in := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while FZStream.avail_in > 0 do + begin + ZCompressCheck(deflate(FZStream, Z_NO_FLUSH)); + + if FZStream.avail_out = 0 then + begin + FStream.WriteBuffer(FBuffer, SizeOf(FBuffer)); + + FZStream.next_out := @FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + FStreamPos := FStream.Position; + + DoProgress; + end; + end; + + result := Count; +end; + +function TZCompressionStream.Seek(offset: Longint; origin: Word): Longint; +begin + if (offset = 0) and (origin = soFromCurrent) then + begin + result := FZStream.total_in; + end + else raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.GetCompressionRate: Single; +begin + if FZStream.total_in = 0 then result := 0 + else result := (1.0 - (FZStream.total_out / FZStream.total_in)) * 100.0; +end; + +{** TZDecompressionStream ***************************************************} + +constructor TZDecompressionStream.Create(source: TStream); +begin + inherited Create(source); + FZStream.next_in := @FBuffer; + FZStream.avail_in := 0; + ZDecompressCheck(InflateInit(FZStream)); +end; + +destructor TZDecompressionStream.Destroy; +begin + inflateEnd(FZStream); + inherited Destroy; +end; + +function TZDecompressionStream.Read(var buffer; count: Longint): Longint; +var + zresult: Integer; +begin + FZStream.next_out := @buffer; + FZStream.avail_out := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + zresult := Z_OK; + + while (FZStream.avail_out > 0) and (zresult <> Z_STREAM_END) do + begin + if FZStream.avail_in = 0 then + begin + FZStream.avail_in := FStream.Read(FBuffer, SizeOf(FBuffer)); + + if FZStream.avail_in = 0 then + begin + result := count - FZStream.avail_out; + + Exit; + end; + + FZStream.next_in := @FBuffer; + FStreamPos := FStream.Position; + + DoProgress; + end; + + zresult := ZDecompressCheck(inflate(FZStream, Z_NO_FLUSH)); + end; + + if (zresult = Z_STREAM_END) and (FZStream.avail_in > 0) then + begin + FStream.Position := FStream.Position - FZStream.avail_in; + FStreamPos := FStream.Position; + + FZStream.avail_in := 0; + end; + + result := count - FZStream.avail_out; +end; + +function TZDecompressionStream.Write(const Buffer; Count: Longint): Longint; +begin + raise EZDecompressionError.Create(SZInvalid); +end; + +function TZDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; +var + buf: array[0..8191] of AnsiChar; + i: Integer; +begin + if (offset = 0) and (origin = soFromBeginning) then + begin + ZDecompressCheck(inflateReset(FZStream)); + + FZStream.next_in := @FBuffer; + FZStream.avail_in := 0; + + FStream.Position := 0; + FStreamPos := 0; + end + else if ((offset >= 0) and (origin = soFromCurrent)) or + (((offset - FZStream.total_out) > 0) and (origin = soFromBeginning)) then + begin + if origin = soFromBeginning then Dec(offset, FZStream.total_out); + + if offset > 0 then + begin + for i := 1 to offset div SizeOf(buf) do ReadBuffer(buf, SizeOf(buf)); + ReadBuffer(buf, offset mod SizeOf(buf)); + end; + end + else if (offset = 0) and (origin = soFromEnd) then + begin + while Read(buf, SizeOf(buf)) > 0 do ; + end + else raise EZDecompressionError.Create(SZInvalid); + + result := FZStream.total_out; +end; + +end. + + + +// diff --git a/official/4.8.11/Source/frxeReg.dcr b/official/4.8.11/Source/frxeReg.dcr new file mode 100644 index 0000000..e1d31f8 Binary files /dev/null and b/official/4.8.11/Source/frxeReg.dcr differ diff --git a/official/4.8.11/Source/frxpngimage.pas b/official/4.8.11/Source/frxpngimage.pas new file mode 100644 index 0000000..6c07483 --- /dev/null +++ b/official/4.8.11/Source/frxpngimage.pas @@ -0,0 +1,5825 @@ +{Portable Network Graphics Delphi 1.564 (31 July 2006) } + +{This is a full, open sourced implementation of png in Delphi } +{It has native support for most of png features including the } +{partial transparency, gamma and more. } +{For the latest version, please be sure to check my website } +{http://pngdelphi.sourceforge.net } +{Gustavo Huffenbacher Daud (gustavo.daud@terra.com.br) } + + +{ + Version 1.564 + 2006-07-25 BUG 1 - There was one GDI Palette object leak + when assigning from other PNG (fixed) + BUG 2 - Loosing color information when assigning png + to bmp on lower screen depth system + BUG 3 - There was a bug in TStream.GetSize + (fixed thanks to Vladimir Panteleev) + IMPROVE 1 - When assigning png to bmp now alpha information + is drawn (simulated into a white background) + + Version 1.563 + 2006-07-25 BUG 1 - There was a memory bug in the main component + destructor (fixed thanks to Steven L Brenner) + BUG 2 - The packages name contained spaces which was + causing some strange bugs in Delphi + (fixed thanks to Martijn Saly) + BUG 3 - Lots of fixes when handling palettes + (bugs implemented in the last version) + Fixed thanks to Gabriel Corneanu!!! + BUG 4 - CreateAlpha was raising an error because it did + not resized the palette chunk it created; + Fixed thanks to Miha Sokolov + IMPROVE 1 - Renamed the pngzlib.pas unit to zlibpas.pas + as a tentative to all libraries use the same + shared zlib implementation and to avoid including + two or three times the same P-Code. + (Gabriel Corneanu idea) + + + + Version 1.561 + 2006-05-17 BUG 1 - There was a bug in the method that draws semi + transparent images (a memory leak). fixed. + + Version 1.56 + 2006-05-09 - IMPROVE 1 - Delphi standard TCanvas support is now implemented + IMPROVE 2 - The PNG files may now be resized and created from + scratch using CreateBlank, Resize, Width and Height + BUG 1 - Fixed some bugs on handling tRNS transparencies + BUG 2 - Fixed bugs related to palette handling + + Version 1.535 + 2006-04-21 - IMPROVE 1 - Now the library uses the latest ZLIB release (1.2.3) + (thanks to: Roberto Della Pasqua + http://www.dellapasqua.com/delphizlib/) + + Version 1.53 + 2006-04-14 - + BUG 1 - Remove transparency was not working for + RGB Alpha and Grayscale alpha. fixed + BUG 2 - There was a bug were compressed text chunks no keyword + name could not be read + IMPROVE 1 - Add classes and methods to work with the pHYs chunk + (including TPNGObject.DrawUsingPixelInformation) + IMPROVE 3 - Included a property Version to return the library + version + IMPROVE 4 - New polish translation (thanks to Piotr Domanski) + IMPROVE 5 - Now packages for delphi 5, 6, 7, 2005 and 2006 + + Also Martijn Saly (thany) made some improvements in the library: + IMPROVE 1 - SetPixel now works with grayscale + IMPROVE 2 - Palette property now can be written using a + windows handle + Thanks !! + + Version 1.5 + 2005-06-29 - Fixed a lot of bugs using tips from mails that Iґve + being receiving for some time + BUG 1 - Loosing palette when assigning to TBitmap. fixed + BUG 2 - SetPixels and GetPixels worked only with + parameters in range 0..255. fixed + BUG 3 - Force type address off using directive + BUG 4 - TChunkzTXt contained an error + BUG 5 - MaxIdatSize was not working correctly (fixed thanks + to Gabriel Corneanu + BUG 6 - Corrected german translation (thanks to Mael Horz) + And the following improvements: + IMPROVE 1 - Create ImageHandleValue properties as public in + TChunkIHDR to get access to this handle + IMPROVE 2 - Using SetStretchBltMode to improve stretch quality + IMPROVE 3 - Scale is now working for alpha transparent images + IMPROVE 4 - GammaTable propery is now public to support an + article in the help file + + Version 1.4361 + 2003-03-04 - Fixed important bug for simple transparency when using + RGB, Grayscale color modes + + Version 1.436 + 2003-03-04 - * NEW * Property Pixels for direct access to pixels + * IMPROVED * Palette property (TPngObject) (read only) + Slovenian traslation for the component (Miha Petelin) + Help file update (scanline article/png->jpg example) + + Version 1.435 + 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt) + * NEW * New compiler flags to store the extra 8 bits + from 16 bits samples (when saving it is ignored), the + extra data may be acessed using ExtraScanline property + * Fixed * a bug on tIMe chunk + French translation included (Thanks to IBE Software) + Bugs fixed + + Version 1.432 + 2002-08-24 - * NEW * A new method, CreateAlpha will transform the + current image into partial transparency. + Help file updated with a new article on how to handle + partial transparency. + + Version 1.431 + 2002-08-14 - Fixed and tested to work on: + C++ Builder 3 + C++ Builder 5 + Delphi 3 + There was an error when setting TransparentColor, fixed + New method, RemoveTransparency to remove image + BIT TRANSPARENCY + + Version 1.43 + 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3 + Implements mostly some things that were missing, + a few tweaks and fixes. + + Version 1.428 + 2002-07-24 - More minor fixes (thanks to Ian Boyd) + Bit transparency fixes + * NEW * Finally support to bit transparency + (palette / rgb / grayscale -> all) + + Version 1.427 + 2002-07-19 - Lots of bugs and leaks fixed + * NEW * method to easy adding text comments, AddtEXt + * NEW * property for setting bit transparency, + TransparentColor + + Version 1.426 + 2002-07-18 - Clipboard finally fixed and working + Changed UseDelphi trigger to UseDelphi + * NEW * Support for bit transparency bitmaps + when assigning from/to TBitmap objects + Altough it does not support drawing transparent + parts of bit transparency pngs (only partial) + it is closer than ever + + Version 1.425 + 2002-07-01 - Clipboard methods implemented + Lots of bugs fixed + + Version 1.424 + 2002-05-16 - Scanline and AlphaScanline are now working correctly. + New methods for handling the clipboard + + Version 1.423 + 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is + also supported using the tRNS chunk (for palette and + grayscaling). + New bug fixes (Peter Haas). + + Version 1.422 + 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips. + New translation for German (Peter Haas). + + Version 1.421 + 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security + fixes. + LoadFromResourceID and LoadFromResourceName added and + help file updated for that. + The resources strings are now located in pnglang.pas. + New translation for Brazilian Portuguese. + Bugs fixed. + + IMPORTANT: As always Iґm looking for bugs on the library. If + anyone has found one, please send me an email and + I will fix asap. Thanks for all the help and ideas + I'm receiving so far.} + +{My email is : gustavo.daud@terra.com.br} +{Website link : http://pngdelphi.sourceforge.net} +{Gustavo Huffenbacher Daud} + +unit frxpngimage; + +interface +{$I frx.inc} +{Triggers avaliable (edit the fields bellow)} +{$TYPEDADDRESS OFF} + +{$DEFINE UseDelphi} //Disable fat vcl units(perfect for small apps) +{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk +{$DEFINE CheckCRC} //Enables CRC checking +{$DEFINE RegisterGraphic} //Registers TPNGObject to use with TPicture +{$DEFINE PartialTransparentDraw} //Draws partial transparent images +{$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample +{$RANGECHECKS OFF} {$J+} + +uses + Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF}, + frxZlib, frxpnglang; + +const + LibraryVersion = '1.564'; + +{$IFNDEF UseDelphi} + const + soFromBeginning = 0; + soFromCurrent = 1; + soFromEnd = 2; +{$ENDIF} + +const + {ZLIB constants} + ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)', + 'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)', + 'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)', + 'need dictionary (2)'); + Z_NO_FLUSH = 0; + Z_FINISH = 4; + Z_STREAM_END = 1; + + {Avaliable PNG filters for mode 0} + FILTER_NONE = 0; + FILTER_SUB = 1; + FILTER_UP = 2; + FILTER_AVERAGE = 3; + FILTER_PAETH = 4; + + {Avaliable color modes for PNG} + COLOR_GRAYSCALE = 0; + COLOR_RGB = 2; + COLOR_PALETTE = 3; + COLOR_GRAYSCALEALPHA = 4; + COLOR_RGBALPHA = 6; + + +type + {$IFNDEF UseDelphi} + {Custom exception handler} + Exception = class(TObject) + constructor Create(Msg: String); + end; + ExceptClass = class of Exception; + TColor = ColorRef; + {$ENDIF} + + {Error types} + EPNGOutMemory = class(Exception); + EPngError = class(Exception); + EPngUnexpectedEnd = class(Exception); + EPngInvalidCRC = class(Exception); + EPngInvalidIHDR = class(Exception); + EPNGMissingMultipleIDAT = class(Exception); + EPNGZLIBError = class(Exception); + EPNGInvalidPalette = class(Exception); + EPNGInvalidFileHeader = class(Exception); + EPNGIHDRNotFirst = class(Exception); + EPNGNotExists = class(Exception); + EPNGSizeExceeds = class(Exception); + EPNGMissingPalette = class(Exception); + EPNGUnknownCriticalChunk = class(Exception); + EPNGUnknownCompression = class(Exception); + EPNGUnknownInterlace = class(Exception); + EPNGNoImageData = class(Exception); + EPNGCouldNotLoadResource = class(Exception); + EPNGCannotChangeTransparent = class(Exception); + EPNGHeaderNotPresent = class(Exception); + EPNGInvalidNewSize = class(Exception); + EPNGInvalidSpec = class(Exception); + +type + {Direct access to pixels using R,G,B} + TRGBLine = array[word] of TRGBTriple; + pRGBLine = ^TRGBLine; + + {Same as TBitmapInfo but with allocated space for} + {palette entries} + TMAXBITMAPINFO = packed record + bmiHeader: TBitmapInfoHeader; + bmiColors: packed array[0..255] of TRGBQuad; + end; + + {Transparency mode for pngs} + TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial); + {Pointer to a cardinal type} + pCardinal = ^Cardinal; + {Access to a rgb pixel} + pRGBPixel = ^TRGBPixel; + TRGBPixel = packed record + B, G, R: Byte; + end; + + {Pointer to an array of bytes type} + TByteArray = Array[Word] of Byte; + pByteArray = ^TByteArray; + + {Forward} + TPNGObject = class; + pPointerArray = ^TPointerArray; + TPointerArray = Array[Word] of Pointer; + + {Contains a list of objects} + TPNGPointerList = class + private + fOwner: TPNGObject; + fCount : Cardinal; + fMemory: pPointerArray; + function GetItem(Index: Cardinal): Pointer; + procedure SetItem(Index: Cardinal; const Value: Pointer); + protected + {Removes an item} + function Remove(Value: Pointer): Pointer; virtual; + {Inserts an item} + procedure Insert(Value: Pointer; Position: Cardinal); + {Add a new item} + procedure Add(Value: Pointer); + {Returns an item} + property Item[Index: Cardinal]: Pointer read GetItem write SetItem; + {Set the size of the list} + procedure SetSize(const Size: Cardinal); + {Returns owner} + property Owner: TPNGObject read fOwner; + public + {Returns number of items} + property Count: Cardinal read fCount write SetSize; + {Object being either created or destroyed} + constructor Create(AOwner: TPNGObject); + destructor Destroy; override; + end; + + {Forward declaration} + TChunk = class; + TChunkClass = class of TChunk; + + {Same as TPNGPointerList but providing typecasted values} + TPNGList = class(TPNGPointerList) + private + {Used with property Item} + function GetItem(Index: Cardinal): TChunk; + public + {Finds the first item with this class} + function FindChunk(ChunkClass: TChunkClass): TChunk; + {Removes an item} + procedure RemoveChunk(Chunk: TChunk); overload; + {Add a new chunk using the class from the parameter} + function Add(ChunkClass: TChunkClass): TChunk; + {Returns pointer to the first chunk of class} + function ItemFromClass(ChunkClass: TChunkClass): TChunk; + {Returns a chunk item from the list} + property Item[Index: Cardinal]: TChunk read GetItem; + end; + + {$IFNDEF UseDelphi} + {The STREAMs bellow are only needed in case delphi provided ones is not} + {avaliable (UseDelphi trigger not set)} + {Object becomes handles} + TCanvas = THandle; + TBitmap = HBitmap; + {Trick to work} + TPersistent = TObject; + + {Base class for all streams} + TStream = class + protected + {Returning/setting size} + function GetSize: Longint; virtual; + procedure SetSize(const Value: Longint); virtual; abstract; + {Returns/set position} + function GetPosition: Longint; virtual; + procedure SetPosition(const Value: Longint); virtual; + public + {Returns/sets current position} + property Position: Longint read GetPosition write SetPosition; + {Property returns/sets size} + property Size: Longint read GetSize write SetSize; + {Allows reading/writing data} + function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract; + function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract; + {Copies from another Stream} + function CopyFrom(Source: TStream; + Count: Cardinal): Cardinal; virtual; + {Seeks a stream position} + function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract; + end; + + {File stream modes} + TFileStreamMode = (fsmRead, fsmWrite, fsmCreate); + TFileStreamModeSet = set of TFileStreamMode; + + {File stream for reading from files} + TFileStream = class(TStream) + private + {Opened mode} + Filemode: TFileStreamModeSet; + {Handle} + fHandle: THandle; + protected + {Set the size of the file} + procedure SetSize(const Value: Longint); override; + public + {Seeks a file position} + function Seek(Offset: Longint; Origin: Word): Longint; override; + {Reads/writes data from/to the file} + function Read(var Buffer; Count: Longint): Cardinal; override; + function Write(const Buffer; Count: Longint): Cardinal; override; + {Stream being created and destroy} + constructor Create(Filename: String; Mode: TFileStreamModeSet); + destructor Destroy; override; + end; + + {Stream for reading from resources} + TResourceStream = class(TStream) + constructor Create(Instance: HInst; const ResName: String; ResType:PChar); + private + {Variables for reading} + Size: Integer; + Memory: Pointer; + Position: Integer; + protected + {Set the size of the file} + procedure SetSize(const Value: Longint); override; + public + {Stream processing} + function Read(var Buffer; Count: Integer): Cardinal; override; + function Seek(Offset: Integer; Origin: Word): Longint; override; + function Write(const Buffer; Count: Longint): Cardinal; override; + end; + {$ENDIF} + + {Forward} + TChunkIHDR = class; + TChunkpHYs = class; + {Interlace method} + TInterlaceMethod = (imNone, imAdam7); + {Compression level type} + TCompressionLevel = 0..9; + {Filters type} + TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth); + TFilters = set of TFilter; + + {Png implementation object} + TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} + protected + {Inverse gamma table values} + InverseGamma: Array[Byte] of Byte; + procedure InitializeGamma; + private + {Canvas} + {$IFDEF UseDelphi}fCanvas: TCanvas;{$ENDIF} + {Filters to test to encode} + fFilters: TFilters; + {Compression level for ZLIB} + fCompressionLevel: TCompressionLevel; + {Maximum size for IDAT chunks} + fMaxIdatSize: Integer; + {Returns if image is interlaced} + fInterlaceMethod: TInterlaceMethod; + {Chunks object} + fChunkList: TPngList; + {Clear all chunks in the list} + procedure ClearChunks; + {Returns if header is present} + function HeaderPresent: Boolean; + procedure GetPixelInfo(var LineSize, Offset: Cardinal); + {Returns linesize and byte offset for pixels} + procedure SetMaxIdatSize(const Value: Integer); + function GetAlphaScanline(const LineIndex: Integer): pByteArray; + function GetScanline(const LineIndex: Integer): Pointer; + {$IFDEF Store16bits} + function GetExtraScanline(const LineIndex: Integer): Pointer; + {$ENDIF} + function GetPixelInformation: TChunkpHYs; + function GetTransparencyMode: TPNGTransparencyMode; + function GetTransparentColor: TColor; + procedure SetTransparentColor(const Value: TColor); + {Returns the version} + function GetLibraryVersion: String; + protected + {Being created} + BeingCreated: Boolean; + {Returns / set the image palette} + function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} + procedure SetPalette(Value: HPALETTE); {$IFDEF UseDelphi}override;{$ENDIF} + procedure DoSetPalette(Value: HPALETTE; const UpdateColors: Boolean); + {Returns/sets image width and height} + function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF} + function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF} + procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF} + procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF} + {Assigns from another TPNGObject} + procedure AssignPNG(Source: TPNGObject); + {Returns if the image is empty} + function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} + {Used with property Header} + function GetHeader: TChunkIHDR; + {Draws using partial transparency} + procedure DrawPartialTrans(DC: HDC; Rect: TRect); + {$IFDEF UseDelphi} + {Returns if the image is transparent} + function GetTransparent: Boolean; override; + {$ENDIF} + {Returns a pixel} + function GetPixels(const X, Y: Integer): TColor; virtual; + procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual; + public + {Gamma table array} + GammaTable: Array[Byte] of Byte; + {Resizes the PNG image} + procedure Resize(const CX, CY: Integer); + {Generates alpha information} + procedure CreateAlpha; + {Removes the image transparency} + procedure RemoveTransparency; + {Transparent color} + property TransparentColor: TColor read GetTransparentColor write + SetTransparentColor; + {Add text chunk, TChunkTEXT, TChunkzTXT} + procedure AddtEXt(const Keyword, Text: String); + procedure AddzTXt(const Keyword, Text: String); + {$IFDEF UseDelphi} + {Saves to clipboard format (thanks to Antoine Pottern)} + procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; + var APalette: HPalette); override; + procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; + APalette: HPalette); override; + {$ENDIF} + {Calling errors} + procedure RaiseError(ExceptionClass: ExceptClass; Text: String); + {Returns a scanline from png} + property Scanline[const Index: Integer]: Pointer read GetScanline; + {$IFDEF Store16bits} + property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline; + {$ENDIF} + {Used to return pixel information} + function HasPixelInformation: Boolean; + property PixelInformation: TChunkpHYs read GetPixelInformation; + property AlphaScanline[const Index: Integer]: pByteArray read + GetAlphaScanline; + procedure DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); + + {Canvas} + {$IFDEF UseDelphi}property Canvas: TCanvas read fCanvas;{$ENDIF} + {Returns pointer to the header} + property Header: TChunkIHDR read GetHeader; + {Returns the transparency mode used by this png} + property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode; + {Assigns from another object} + procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} + {Assigns to another object} + procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} + {Assigns from a windows bitmap handle} + procedure AssignHandle(Handle: HBitmap; Transparent: Boolean; + TransparentColor: ColorRef); + {Draws the image into a canvas} + procedure Draw(ACanvas: TCanvas; const Rect: TRect); + {$IFDEF UseDelphi}override;{$ENDIF} + {Width and height properties} + property Width: Integer read GetWidth; + property Height: Integer read GetHeight; + {Returns if the image is interlaced} + property InterlaceMethod: TInterlaceMethod read fInterlaceMethod + write fInterlaceMethod; + {Filters to test to encode} + property Filters: TFilters read fFilters write fFilters; + {Maximum size for IDAT chunks, default and minimum is 65536} + property MaxIdatSize: Integer read fMaxIdatSize write SetMaxIdatSize; + {Property to return if the image is empty or not} + property Empty: Boolean read GetEmpty; + {Compression level} + property CompressionLevel: TCompressionLevel read fCompressionLevel + write fCompressionLevel; + {Access to the chunk list} + property Chunks: TPngList read fChunkList; + {Object being created and destroyed} + constructor Create; {$IFDEF UseDelphi}override;{$ENDIF} + constructor CreateBlank(ColorType, Bitdepth: Cardinal; cx, cy: Integer); + destructor Destroy; override; + {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF} + {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF} + procedure LoadFromStream(Stream: TStream); + {$IFDEF UseDelphi}override;{$ENDIF} + procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} + {Loading the image from resources} + procedure LoadFromResourceName(Instance: HInst; const Name: String); + procedure LoadFromResourceID(Instance: HInst; ResID: Integer); + {Access to the png pixels} + property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels; + {Palette property} + {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette write + SetPalette;{$ENDIF} + {Returns the version} + property Version: String read GetLibraryVersion; + end; + + {Chunk name object} + TChunkName = Array[0..3] of Char; + + {Global chunk object} + TChunk = class + private + {Contains data} + fData: Pointer; + fDataSize: Cardinal; + {Stores owner} + fOwner: TPngObject; + {Stores the chunk name} + fName: TChunkName; + {Returns pointer to the TChunkIHDR} + function GetHeader: TChunkIHDR; + {Used with property index} + function GetIndex: Integer; + {Should return chunk class/name} + class function GetName: String; virtual; + {Returns the chunk name} + function GetChunkName: String; + public + {Returns index from list} + property Index: Integer read GetIndex; + {Returns pointer to the TChunkIHDR} + property Header: TChunkIHDR read GetHeader; + {Resize the data} + procedure ResizeData(const NewSize: Cardinal); + {Returns data and size} + property Data: Pointer read fData; + property DataSize: Cardinal read fDataSize; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); virtual; + {Returns owner} + property Owner: TPngObject read fOwner; + {Being destroyed/created} + constructor Create(Owner: TPngObject); virtual; + destructor Destroy; override; + {Returns chunk class/name} + property Name: String read GetChunkName; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; virtual; + {Saves the chunk to a stream} + function SaveData(Stream: TStream): Boolean; + function SaveToStream(Stream: TStream): Boolean; virtual; + end; + + {Chunk classes} + TChunkIEND = class(TChunk); {End chunk} + + {IHDR data} + pIHDRData = ^TIHDRData; + TIHDRData = packed record + Width, Height: Cardinal; + BitDepth, + ColorType, + CompressionMethod, + FilterMethod, + InterlaceMethod: Byte; + end; + + {Information header chunk} + TChunkIHDR = class(TChunk) + private + {Current image} + ImageHandle: HBitmap; + ImageDC: HDC; + ImagePalette: HPalette; + {Output windows bitmap} + HasPalette: Boolean; + BitmapInfo: TMaxBitmapInfo; + {Stores the image bytes} + {$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF} + ImageData: pointer; + ImageAlpha: Pointer; + + {Contains all the ihdr data} + IHDRData: TIHDRData; + protected + BytesPerRow: Integer; + {Creates a grayscale palette} + function CreateGrayscalePalette(Bitdepth: Integer): HPalette; + {Copies the palette to the Device Independent bitmap header} + procedure PaletteToDIB(Palette: HPalette); + {Resizes the image data to fill the color type, bit depth, } + {width and height parameters} + procedure PrepareImageData; + {Release allocated ImageData memory} + procedure FreeImageData; + public + {Access to ImageHandle} + property ImageHandleValue: HBitmap read ImageHandle; + {Properties} + property Width: Cardinal read IHDRData.Width write IHDRData.Width; + property Height: Cardinal read IHDRData.Height write IHDRData.Height; + property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth; + property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType; + property CompressionMethod: Byte read IHDRData.CompressionMethod + write IHDRData.CompressionMethod; + property FilterMethod: Byte read IHDRData.FilterMethod + write IHDRData.FilterMethod; + property InterlaceMethod: Byte read IHDRData.InterlaceMethod + write IHDRData.InterlaceMethod; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + {Destructor/constructor} + constructor Create(Owner: TPngObject); override; + destructor Destroy; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {pHYs chunk} + pUnitType = ^TUnitType; + TUnitType = (utUnknown, utMeter); + TChunkpHYs = class(TChunk) + private + fPPUnitX, fPPUnitY: Cardinal; + fUnit: TUnitType; + public + {Returns the properties} + property PPUnitX: Cardinal read fPPUnitX write fPPUnitX; + property PPUnitY: Cardinal read fPPUnitY write fPPUnitY; + property UnitType: TUnitType read fUnit write fUnit; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {Gamma chunk} + TChunkgAMA = class(TChunk) + private + {Returns/sets the value for the gamma chunk} + function GetValue: Cardinal; + procedure SetValue(const Value: Cardinal); + public + {Returns/sets gamma value} + property Gamma: Cardinal read GetValue write SetValue; + {Loading the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Being created} + constructor Create(Owner: TPngObject); override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {ZLIB Decompression extra information} + TZStreamRec2 = packed record + {From ZLIB} + ZLIB: TZStreamRec; + {Additional info} + Data: Pointer; + fStream : TStream; + end; + + {Palette chunk} + TChunkPLTE = class(TChunk) + protected + {Number of items in the palette} + fCount: Integer; + private + {Contains the palette handle} + function GetPaletteItem(Index: Byte): TRGBQuad; + public + {Returns the color for each item in the palette} + property Item[Index: Byte]: TRGBQuad read GetPaletteItem; + {Returns the number of items in the palette} + property Count: Integer read fCount; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {Transparency information} + TChunktRNS = class(TChunk) + private + fBitTransparency: Boolean; + function GetTransparentColor: ColorRef; + {Returns the transparent color} + procedure SetTransparentColor(const Value: ColorRef); + public + {Palette values for transparency} + PaletteValues: Array[Byte] of Byte; + {Returns if it uses bit transparency} + property BitTransparency: Boolean read fBitTransparency; + {Returns the transparent color} + property TransparentColor: ColorRef read GetTransparentColor write + SetTransparentColor; + {Loads/saves the chunk from/to a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + function SaveToStream(Stream: TStream): Boolean; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {Actual image information} + TChunkIDAT = class(TChunk) + private + {Holds another pointer to the TChunkIHDR} + Header: TChunkIHDR; + {Stores temporary image width and height} + ImageWidth, ImageHeight: Integer; + {Size in bytes of each line and offset} + Row_Bytes, Offset : Cardinal; + {Contains data for the lines} + Encode_Buffer: Array[0..5] of pByteArray; + Row_Buffer: Array[Boolean] of pByteArray; + {Variable to invert the Row_Buffer used} + RowUsed: Boolean; + {Ending position for the current IDAT chunk} + EndPos: Integer; + {Filter the current line} + procedure FilterRow; + {Filter to encode and returns the best filter} + function FilterToEncode: Byte; + {Reads ZLIB compressed data} + function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer; + Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer; + {Compress and writes IDAT data} + procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer; + const Length: Cardinal); + procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2); + {Prepares the palette} + procedure PreparePalette; + protected + {Decode interlaced image} + procedure DecodeInterlacedAdam7(Stream: TStream; + var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); + {Decode non interlaced imaged} + procedure DecodeNonInterlaced(Stream: TStream; + var ZLIBStream: TZStreamRec2; const Size: Integer; + var crcfile: Cardinal); + protected + {Encode non interlaced images} + procedure EncodeNonInterlaced(Stream: TStream; + var ZLIBStream: TZStreamRec2); + {Encode interlaced images} + procedure EncodeInterlacedAdam7(Stream: TStream; + var ZLIBStream: TZStreamRec2); + protected + {Memory copy methods to decode} + procedure CopyNonInterlacedRGB8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedRGB16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedPalette148( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedPalette2( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedGray2( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedGrayscale16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedRGBAlpha8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedRGBAlpha16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedGrayscaleAlpha8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyNonInterlacedGrayscaleAlpha16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedRGB8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedRGB16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedPalette148(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedPalette2(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedGray2(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedGrayscale16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedRGBAlpha8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedRGBAlpha16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); + protected + {Memory copy methods to encode} + procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar); + procedure EncodeInterlacedPalette148(const Pass: Byte; + Src, Dest, Trans: pChar); + procedure EncodeInterlacedGrayscale16(const Pass: Byte; + Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; + Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; + Src, Dest, Trans: pChar); + procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; + Src, Dest, Trans: pChar); + procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; + Src, Dest, Trans: pChar); + public + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + end; + + {Image last modification chunk} + TChunktIME = class(TChunk) + private + {Holds the variables} + fYear: Word; + fMonth, fDay, fHour, fMinute, fSecond: Byte; + public + {Returns/sets variables} + property Year: Word read fYear write fYear; + property Month: Byte read fMonth write fMonth; + property Day: Byte read fDay write fDay; + property Hour: Byte read fHour write fHour; + property Minute: Byte read fMinute write fMinute; + property Second: Byte read fSecond write fSecond; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {Textual data} + TChunktEXt = class(TChunk) + private + fKeyword, fText: String; + public + {Keyword and text} + property Keyword: String read fKeyword write fKeyword; + property Text: String read fText write fText; + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + {Assigns from another TChunk} + procedure Assign(Source: TChunk); override; + end; + + {zTXT chunk} + TChunkzTXt = class(TChunktEXt) + {Loads the chunk from a stream} + function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; override; + {Saves the chunk to a stream} + function SaveToStream(Stream: TStream): Boolean; override; + end; + +{Here we test if it's c++ builder or delphi version 3 or less} +{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF} +{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF} +{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF} +{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF} +{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF} + + +{Registers a new chunk class} +procedure RegisterChunk(ChunkClass: TChunkClass); +{Calculates crc} +function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer + {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; +{Invert bytes using assembly} +function ByteSwap(const a: integer): integer; + +implementation + +var + ChunkClasses: TPngPointerList; + {Table of CRCs of all 8-bit messages} + crc_table: Array[0..255] of Cardinal; + {Flag: has the table been computed? Initially false} + crc_table_computed: Boolean; + +{Draw transparent image using transparent color} +procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer; + var srcHeader: TBitmapInfoHeader; + srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF); +var + cColor: COLORREF; + bmAndBack, bmAndObject, bmAndMem: HBITMAP; + bmBackOld, bmObjectOld, bmMemOld: HBITMAP; + hdcMem, hdcBack, hdcObject, hdcTemp: HDC; + ptSize, orgSize: TPOINT; + OldBitmap, DrawBitmap: HBITMAP; +begin + hdcTemp := CreateCompatibleDC(dc); + {Select the bitmap} + DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^, + DIB_RGB_COLORS); + OldBitmap := SelectObject(hdcTemp, DrawBitmap); + + {Get sizes} + OrgSize.x := abs(srcHeader.biWidth); + OrgSize.y := abs(srcHeader.biHeight); + ptSize.x := Rect.Right - Rect.Left; // Get width of bitmap + ptSize.y := Rect.Bottom - Rect.Top; // Get height of bitmap + + {Create some DCs to hold temporary data} + hdcBack := CreateCompatibleDC(dc); + hdcObject := CreateCompatibleDC(dc); + hdcMem := CreateCompatibleDC(dc); + + // Create a bitmap for each DC. DCs are required for a number of + // GDI functions. + + // Monochrome DCs + bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); + bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); + + bmAndMem := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y); + + // Each DC must select a bitmap object to store pixel data. + bmBackOld := SelectObject(hdcBack, bmAndBack); + bmObjectOld := SelectObject(hdcObject, bmAndObject); + bmMemOld := SelectObject(hdcMem, bmAndMem); + + // Set the background color of the source DC to the color. + // contained in the parts of the bitmap that should be transparent + cColor := SetBkColor(hdcTemp, cTransparentColor); + + // Create the object mask for the bitmap by performing a BitBlt + // from the source bitmap to a monochrome bitmap. + StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, + orgSize.x, orgSize.y, SRCCOPY); + + // Set the background color of the source DC back to the original + // color. + SetBkColor(hdcTemp, cColor); + + // Create the inverse of the object mask. + BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, + NOTSRCCOPY); + + // Copy the background of the main DC to the destination. + BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top, + SRCCOPY); + + // Mask out the places where the bitmap will be placed. + BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND); + + // Mask out the transparent colored pixels on the bitmap. +// BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); + StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0, + PtSize.x, PtSize.y, SRCAND); + + // XOR the bitmap with the background on the destination DC. + StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, + OrgSize.x, OrgSize.y, SRCPAINT); + + // Copy the destination to the screen. + BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0, + SRCCOPY); + + // Delete the memory bitmaps. + DeleteObject(SelectObject(hdcBack, bmBackOld)); + DeleteObject(SelectObject(hdcObject, bmObjectOld)); + DeleteObject(SelectObject(hdcMem, bmMemOld)); + DeleteObject(SelectObject(hdcTemp, OldBitmap)); + + // Delete the memory DCs. + DeleteDC(hdcMem); + DeleteDC(hdcBack); + DeleteDC(hdcObject); + DeleteDC(hdcTemp); +end; + +{Make the table for a fast CRC.} +procedure make_crc_table; +var + c: Cardinal; + n, k: Integer; +begin + + {fill the crc table} + for n := 0 to 255 do + begin + c := Cardinal(n); + for k := 0 to 7 do + begin + if Boolean(c and 1) then + c := $edb88320 xor (c shr 1) + else + c := c shr 1; + end; + crc_table[n] := c; + end; + + {The table has already being computated} + crc_table_computed := true; +end; + +{Update a running CRC with the bytes buf[0..len-1]--the CRC + should be initialized to all 1's, and the transmitted value + is the 1's complement of the final running CRC (see the + crc() routine below)).} +function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer + {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; +var + c: Cardinal; + n: Integer; +begin + c := crc; + + {Create the crc table in case it has not being computed yet} + if not crc_table_computed then make_crc_table; + + {Update} + for n := 0 to len - 1 do + c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8); + + {Returns} + Result := c; +end; + +{$IFNDEF UseDelphi} + function FileExists(Filename: String): Boolean; + var + FindFile: THandle; + FindData: TWin32FindData; + begin + FindFile := FindFirstFile(PChar(Filename), FindData); + Result := FindFile <> INVALID_HANDLE_VALUE; + if Result then Windows.FindClose(FindFile); + end; + + +{$ENDIF} + +{$IFNDEF UseDelphi} + {Exception implementation} + constructor Exception.Create(Msg: String); + begin + end; +{$ENDIF} + +{Calculates the paeth predictor} +function PaethPredictor(a, b, c: Byte): Byte; +var + pa, pb, pc: Integer; +begin + { a = left, b = above, c = upper left } + pa := abs(b - c); { distances to a, b, c } + pb := abs(a - c); + pc := abs(a + b - c * 2); + + { return nearest of a, b, c, breaking ties in order a, b, c } + if (pa <= pb) and (pa <= pc) then + Result := a + else + if pb <= pc then + Result := b + else + Result := c; +end; + +{Invert bytes using assembly} +function ByteSwap(const a: integer): integer; +asm + bswap eax +end; +function ByteSwap16(inp:word): word; +asm + bswap eax + shr eax, 16 +end; + +{Calculates number of bytes for the number of pixels using the} +{color mode in the paramenter} +function BytesForPixels(const Pixels: Integer; const ColorType, + BitDepth: Byte): Integer; +begin + case ColorType of + {Palette and grayscale contains a single value, for palette} + {an value of size 2^bitdepth pointing to the palette index} + {and grayscale the value from 0 to 2^bitdepth with color intesity} + COLOR_GRAYSCALE, COLOR_PALETTE: + Result := (Pixels * BitDepth + 7) div 8; + {RGB contains 3 values R, G, B with size 2^bitdepth each} + COLOR_RGB: + Result := (Pixels * BitDepth * 3) div 8; + {Contains one value followed by alpha value booth size 2^bitdepth} + COLOR_GRAYSCALEALPHA: + Result := (Pixels * BitDepth * 2) div 8; + {Contains four values size 2^bitdepth, Red, Green, Blue and alpha} + COLOR_RGBALPHA: + Result := (Pixels * BitDepth * 4) div 8; + else + Result := 0; + end {case ColorType} +end; + +type + pChunkClassInfo = ^TChunkClassInfo; + TChunkClassInfo = record + ClassName: TChunkClass; + end; + +{Register a chunk type} +procedure RegisterChunk(ChunkClass: TChunkClass); +var + NewClass: pChunkClassInfo; +begin + {In case the list object has not being created yet} + if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil); + + {Add this new class} + new(NewClass); + NewClass^.ClassName := ChunkClass; + ChunkClasses.Add(NewClass); +end; + +{Free chunk class list} +procedure FreeChunkClassList; +var + i: Integer; +begin + if (ChunkClasses <> nil) then + begin + FOR i := 0 TO ChunkClasses.Count - 1 do + Dispose(pChunkClassInfo(ChunkClasses.Item[i])); + ChunkClasses.Free; + end; +end; + +{Registering of common chunk classes} +procedure RegisterCommonChunks; +begin + {Important chunks} + RegisterChunk(TChunkIEND); + RegisterChunk(TChunkIHDR); + RegisterChunk(TChunkIDAT); + RegisterChunk(TChunkPLTE); + RegisterChunk(TChunkgAMA); + RegisterChunk(TChunktRNS); + + {Not so important chunks} + RegisterChunk(TChunkpHYs); + RegisterChunk(TChunktIME); + RegisterChunk(TChunktEXt); + RegisterChunk(TChunkzTXt); +end; + +{Creates a new chunk of this class} +function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk; +var + i : Integer; + NewChunk: TChunkClass; +begin + {Looks for this chunk} + NewChunk := TChunk; {In case there is no registered class for this} + + {Looks for this class in all registered chunks} + if Assigned(ChunkClasses) then + FOR i := 0 TO ChunkClasses.Count - 1 DO + begin + if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then + begin + NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName; + break; + end; + end; + + {Returns chunk class} + Result := NewChunk.Create(Owner); + Result.fName := Name; +end; + +{ZLIB support} + +const + ZLIBAllocate = High(Word); + +{Initializes ZLIB for decompression} +function ZLIBInitInflate(Stream: TStream): TZStreamRec2; +begin + {Fill record} + Fillchar(Result, SIZEOF(TZStreamRec2), #0); + + {Set internal record information} + with Result do + begin + GetMem(Data, ZLIBAllocate); + fStream := Stream; + end; + + {Init decompression} + InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec)); +end; + +{Initializes ZLIB for compression} +function ZLIBInitDeflate(Stream: TStream; + Level: TCompressionlevel; Size: Cardinal): TZStreamRec2; +begin + {Fill record} + Fillchar(Result, SIZEOF(TZStreamRec2), #0); + + {Set internal record information} + with Result, ZLIB do + begin + GetMem(Data, Size); + fStream := Stream; + next_out := Data; + avail_out := Size; + end; + + {Inits compression} + deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec)); +end; + +{Terminates ZLIB for compression} +procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2); +begin + {Terminates decompression} + DeflateEnd(ZLIBStream.zlib); + {Free internal record} + FreeMem(ZLIBStream.Data, ZLIBAllocate); +end; + +{Terminates ZLIB for decompression} +procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2); +begin + {Terminates decompression} + InflateEnd(ZLIBStream.zlib); + {Free internal record} + FreeMem(ZLIBStream.Data, ZLIBAllocate); +end; + +{Decompresses ZLIB into a memory address} +function DecompressZLIB(const Input: Pointer; InputSize: Integer; + var Output: Pointer; var OutputSize: Integer; + var ErrorOutput: String): Boolean; +var + StreamRec : TZStreamRec; + Buffer : Array[Byte] of Byte; + InflateRet: Integer; +begin + with StreamRec do + begin + {Initializes} + Result := True; + OutputSize := 0; + + {Prepares the data to decompress} + FillChar(StreamRec, SizeOf(TZStreamRec), #0); + InflateInit_(StreamRec, zlib_version, SIZEOF(TZStreamRec)); + next_in := Input; + avail_in := InputSize; + + {Decodes data} + repeat + {In case it needs an output buffer} + if (avail_out = 0) then + begin + next_out := @Buffer; + avail_out := SizeOf(Buffer); + end {if (avail_out = 0)}; + + {Decompress and put in output} + InflateRet := inflate(StreamRec, 0); + if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then + begin + {Reallocates output buffer} + inc(OutputSize, total_out); + if Output = nil then + GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); + {Copies the new data} + CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), + @Buffer, total_out); + end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} + {Now tests for errors} + else if InflateRet < 0 then + begin + Result := False; + ErrorOutput := AnsiString(StreamRec.msg); + InflateEnd(StreamRec); + Exit; + end {if InflateRet < 0} + until InflateRet = Z_STREAM_END; + + {Terminates decompression} + InflateEnd(StreamRec); + end {with StreamRec} + +end; + +{Compresses ZLIB into a memory address} +function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; + var Output: Pointer; var OutputSize: Integer; + var ErrorOutput: String): Boolean; +var + StreamRec : TZStreamRec; + Buffer : Array[Byte] of Byte; + DeflateRet: Integer; +begin + with StreamRec do + begin + Result := True; {By default returns TRUE as everything might have gone ok} + OutputSize := 0; {Initialize} + {Prepares the data to compress} + FillChar(StreamRec, SizeOf(TZStreamRec), #0); + DeflateInit_(StreamRec, CompressionLevel,zlib_version, SIZEOF(TZStreamRec)); + + next_in := Input; + avail_in := InputSize; + + while avail_in > 0 do + begin + {When it needs new buffer to stores the compressed data} + if avail_out = 0 then + begin + {Restore buffer} + next_out := @Buffer; + avail_out := SizeOf(Buffer); + end {if avail_out = 0}; + + {Compresses} + DeflateRet := deflate(StreamRec, Z_FINISH); + + if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then + begin + {Updates the output memory} + inc(OutputSize, total_out); + if Output = nil then + GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); + + {Copies the new data} + CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), + @Buffer, total_out); + end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} + {Now tests for errors} + else if DeflateRet < 0 then + begin + Result := False; + ErrorOutput := AnsiString(StreamRec.msg); + DeflateEnd(StreamRec); + Exit; + end {if InflateRet < 0} + + end {while avail_in > 0}; + + {Finishes compressing} + DeflateEnd(StreamRec); + end {with StreamRec} + +end; + +{TPngPointerList implementation} + +{Object being created} +constructor TPngPointerList.Create(AOwner: TPNGObject); +begin + inherited Create; {Let ancestor work} + {Holds owner} + fOwner := AOwner; + {Memory pointer not being used yet} + fMemory := nil; + {No items yet} + fCount := 0; +end; + +{Removes value from the list} +function TPngPointerList.Remove(Value: Pointer): Pointer; +var + I, Position: Integer; +begin + {Gets item position} + Position := -1; + FOR I := 0 TO Count - 1 DO + if Value = Item[I] then Position := I; + {In case a match was found} + if Position >= 0 then + begin + Result := Item[Position]; {Returns pointer} + {Remove item and move memory} + Dec(fCount); + if Position < Integer(FCount) then + System.Move(fMemory^[Position + 1], fMemory^[Position], + (Integer(fCount) - Position) * SizeOf(Pointer)); + end {if Position >= 0} else Result := nil +end; + +{Add a new value in the list} +procedure TPngPointerList.Add(Value: Pointer); +begin + Count := Count + 1; + Item[Count - 1] := Value; +end; + + +{Object being destroyed} +destructor TPngPointerList.Destroy; +begin + {Release memory if needed} + if fMemory <> nil then + FreeMem(fMemory, fCount * sizeof(Pointer)); + + {Free things} + inherited Destroy; +end; + +{Returns one item from the list} +function TPngPointerList.GetItem(Index: Cardinal): Pointer; +begin + if (Index <= Count - 1) then + Result := fMemory[Index] + else + {In case it's out of bounds} + Result := nil; +end; + +{Inserts a new item in the list} +procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal); +begin + if (Position < Count) or (Count = 0) then + begin + {Increase item count} + SetSize(Count + 1); + {Move other pointers} + if Position < Count then + System.Move(fMemory^[Position], fMemory^[Position + 1], + (Count - Position - 1) * SizeOf(Pointer)); + {Sets item} + Item[Position] := Value; + end; +end; + +{Sets one item from the list} +procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer); +begin + {If index is in bounds, set value} + if (Index <= Count - 1) then + fMemory[Index] := Value +end; + +{This method resizes the list} +procedure TPngPointerList.SetSize(const Size: Cardinal); +begin + {Sets the size} + if (fMemory = nil) and (Size > 0) then + GetMem(fMemory, Size * SIZEOF(Pointer)) + else + if Size > 0 then {Only realloc if the new size is greater than 0} + ReallocMem(fMemory, Size * SIZEOF(Pointer)) + else + {In case user is resize to 0 items} + begin + FreeMem(fMemory); + fMemory := nil; + end; + {Update count} + fCount := Size; +end; + +{TPNGList implementation} + +{Finds the first chunk of this class} +function TPNGList.FindChunk(ChunkClass: TChunkClass): TChunk; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if Item[i] is ChunkClass then + begin + Result := Item[i]; + Break + end +end; + + +{Removes an item} +procedure TPNGList.RemoveChunk(Chunk: TChunk); +begin + Remove(Chunk); + Chunk.Free +end; + +{Add a new item} +function TPNGList.Add(ChunkClass: TChunkClass): TChunk; +var + IHDR: TChunkIHDR; + IEND: TChunkIEND; + + IDAT: TChunkIDAT; + PLTE: TChunkPLTE; +begin + Result := nil; {Default result} + {Adding these is not allowed} + if ((ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or + (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND)) and not + (Owner.BeingCreated) then + fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) + {Two of these is not allowed} + else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or + ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) or + ((ChunkClass = TChunkpHYs) and (ItemFromClass(TChunkpHYs) <> nil)) then + fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) + {There must have an IEND and IHDR chunk} + else if ((ItemFromClass(TChunkIEND) = nil) or + (ItemFromClass(TChunkIHDR) = nil)) and not Owner.BeingCreated then + fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText) + else + begin + {Get common chunks} + IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR; + IEND := ItemFromClass(TChunkIEND) as TChunkIEND; + {Create new chunk} + Result := ChunkClass.Create(Owner); + {Add to the list} + if (ChunkClass = TChunkgAMA) or (ChunkClass = TChunkpHYs) or + (ChunkClass = TChunkPLTE) then + Insert(Result, IHDR.Index + 1) + {Header and end} + else if (ChunkClass = TChunkIEND) then + Insert(Result, Count) + else if (ChunkClass = TChunkIHDR) then + Insert(Result, 0) + {Transparency chunk (fix by Ian Boyd)} + else if (ChunkClass = TChunktRNS) then + begin + {Transparecy chunk must be after PLTE; before IDAT} + IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT; + PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE; + + if Assigned(PLTE) then + Insert(Result, PLTE.Index + 1) + else if Assigned(IDAT) then + Insert(Result, IDAT.Index) + else + Insert(Result, IHDR.Index + 1) + end + else {All other chunks} + Insert(Result, IEND.Index); + end {if} +end; + +{Returns item from the list} +function TPNGList.GetItem(Index: Cardinal): TChunk; +begin + Result := inherited GetItem(Index); +end; + +{Returns first item from the list using the class from parameter} +function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk; +var + i: Integer; +begin + Result := nil; {Initial result} + FOR i := 0 TO Count - 1 DO + {Test if this item has the same class} + if Item[i] is ChunkClass then + begin + {Returns this item and exit} + Result := Item[i]; + break; + end {if} +end; + +{$IFNDEF UseDelphi} + + {TStream implementation} + + {Copies all from another stream} + function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal; + const + MaxBytes = $f000; + var + Buffer: PChar; + BufSize, N: Cardinal; + begin + {If count is zero, copy everything from Source} + if Count = 0 then + begin + Source.Seek(0, soFromBeginning); + Count := Source.Size; + end; + + Result := Count; {Returns the number of bytes readed} + {Allocates memory} + if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count; + GetMem(Buffer, BufSize); + + {Copy memory} + while Count > 0 do + begin + if Count > BufSize then N := BufSize else N := Count; + Source.Read(Buffer^, N); + Write(Buffer^, N); + dec(Count, N); + end; + + {Deallocates memory} + FreeMem(Buffer, BufSize); + end; + +{Set current stream position} +procedure TStream.SetPosition(const Value: Longint); +begin + Seek(Value, soFromBeginning); +end; + +{Returns position} +function TStream.GetPosition: Longint; +begin + Result := Seek(0, soFromCurrent); +end; + + {Returns stream size} +function TStream.GetSize: Longint; + var + Pos: Cardinal; + begin + Pos := Seek(0, soFromCurrent); + Result := Seek(0, soFromEnd); + Seek(Pos, soFromBeginning); + end; + + {TFileStream implementation} + + {Filestream object being created} + constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet); + {Makes file mode} + function OpenMode: DWORD; + begin + Result := 0; + if fsmRead in Mode then Result := GENERIC_READ; + if (fsmWrite in Mode) or (fsmCreate in Mode) then + Result := Result OR GENERIC_WRITE; + end; + const + IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS); + begin + {Call ancestor} + inherited Create; + + {Create handle} + fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or + FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0); + {Store mode} + FileMode := Mode; + end; + + {Filestream object being destroyed} + destructor TFileStream.Destroy; + begin + {Terminates file and close} + if FileMode = [fsmWrite] then + SetEndOfFile(fHandle); + CloseHandle(fHandle); + + {Call ancestor} + inherited Destroy; + end; + + {Writes data to the file} + function TFileStream.Write(const Buffer; Count: Longint): Cardinal; + begin + if not WriteFile(fHandle, Buffer, Count, Result, nil) then + Result := 0; + end; + + {Reads data from the file} + function TFileStream.Read(var Buffer; Count: Longint): Cardinal; + begin + if not ReadFile(fHandle, Buffer, Count, Result, nil) then + Result := 0; + end; + + {Seeks the file position} + function TFileStream.Seek(Offset: Integer; Origin: Word): Longint; + begin + Result := SetFilePointer(fHandle, Offset, nil, Origin); + end; + + {Sets the size of the file} + procedure TFileStream.SetSize(const Value: Longint); + begin + Seek(Value, soFromBeginning); + SetEndOfFile(fHandle); + end; + + {TResourceStream implementation} + + {Creates the resource stream} + constructor TResourceStream.Create(Instance: HInst; const ResName: String; + ResType: PChar); + var + ResID: HRSRC; + ResGlobal: HGlobal; + begin + {Obtains the resource ID} + ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA); + if ResID = 0 then raise EPNGError.Create(''); + {Obtains memory and size} + ResGlobal := LoadResource(hInstance, ResID); + Size := SizeOfResource(hInstance, ResID); + Memory := LockResource(ResGlobal); + if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create(''); + end; + + + {Setting resource stream size is not supported} + procedure TResourceStream.SetSize(const Value: Integer); + begin + end; + + {Writing into a resource stream is not supported} + function TResourceStream.Write(const Buffer; Count: Integer): Cardinal; + begin + Result := 0; + end; + + {Reads data from the stream} + function TResourceStream.Read(var Buffer; Count: Integer): Cardinal; + begin + //Returns data + CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count); + //Update position + inc(Position, Count); + //Returns + Result := Count; + end; + + {Seeks data} + function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint; + begin + {Move depending on the origin} + case Origin of + soFromBeginning: Position := Offset; + soFromCurrent: inc(Position, Offset); + soFromEnd: Position := Size + Offset; + end; + + {Returns the current position} + Result := Position; + end; + +{$ENDIF} + +{TChunk implementation} + +{Resizes the data} +procedure TChunk.ResizeData(const NewSize: Cardinal); +begin + fDataSize := NewSize; + ReallocMem(fData, NewSize + 1); +end; + +{Returns index from list} +function TChunk.GetIndex: Integer; +var + i: Integer; +begin + Result := -1; {Avoiding warnings} + {Searches in the list} + FOR i := 0 TO Owner.Chunks.Count - 1 DO + if Owner.Chunks.Item[i] = Self then + begin + {Found match} + Result := i; + exit; + end {for i} +end; + +{Returns pointer to the TChunkIHDR} +function TChunk.GetHeader: TChunkIHDR; +begin + Result := Owner.Chunks.Item[0] as TChunkIHDR; +end; + +{Assigns from another TChunk} +procedure TChunk.Assign(Source: TChunk); +begin + {Copy properties} + fName := Source.fName; + {Set data size and realloc} + ResizeData(Source.fDataSize); + + {Copy data (if there's any)} + if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize); +end; + +{Chunk being created} +constructor TChunk.Create(Owner: TPngObject); +var + ChunkName: String; +begin + {Ancestor create} + inherited Create; + + {If it's a registered class, set the chunk name based on the class} + {name. For instance, if the class name is TChunkgAMA, the GAMA part} + {will become the chunk name} + ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); + if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4); + + {Initialize data holder} + GetMem(fData, 1); + fDataSize := 0; + {Record owner} + fOwner := Owner; +end; + +{Chunk being destroyed} +destructor TChunk.Destroy; +begin + {Free data holder} + FreeMem(fData, fDataSize + 1); + {Let ancestor destroy} + inherited Destroy; +end; + +{Returns the chunk name 1} +function TChunk.GetChunkName: String; +begin + Result := fName +end; + +{Returns the chunk name 2} +class function TChunk.GetName: String; +begin + {For avoid writing GetName for each TChunk descendent, by default for} + {classes which don't declare GetName, it will look for the class name} + {to extract the chunk kind. Example, if the class name is TChunkIEND } + {this method extracts and returns IEND} + Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); +end; + +{Saves the data to the stream} +function TChunk.SaveData(Stream: TStream): Boolean; +var + ChunkSize, ChunkCRC: Cardinal; +begin + {First, write the size for the following data in the chunk} + ChunkSize := ByteSwap(DataSize); + Stream.Write(ChunkSize, 4); + {The chunk name} + Stream.Write(fName, 4); + {If there is data for the chunk, write it} + if DataSize > 0 then Stream.Write(Data^, DataSize); + {Calculates and write CRC} + ChunkCRC := update_crc($ffffffff, @fName[0], 4); + ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff); + Stream.Write(ChunkCRC, 4); + + {Returns that everything went ok} + Result := TRUE; +end; + +{Saves the chunk to the stream} +function TChunk.SaveToStream(Stream: TStream): Boolean; +begin + Result := SaveData(Stream) +end; + + +{Loads the chunk from a stream} +function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; +var + CheckCRC: Cardinal; + {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF} +begin + {Copies data from source} + ResizeData(Size); + if Size > 0 then Stream.Read(fData^, Size); + {Reads CRC} + Stream.Read(CheckCRC, 4); + CheckCrc := ByteSwap(CheckCRC); + + {Check if crc readed is valid} + {$IFDEF CheckCRC} + RightCRC := update_crc($ffffffff, @ChunkName[0], 4); + RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff; + Result := RightCRC = CheckCrc; + + {Handle CRC error} + if not Result then + begin + {In case it coult not load chunk} + Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText); + exit; + end + {$ELSE}Result := TRUE; {$ENDIF} + +end; + +{TChunktIME implementation} + +{Chunk being loaded from a stream} +function TChunktIME.LoadFromStream(Stream: TStream; + const ChunkName: TChunkName; Size: Integer): Boolean; +begin + {Let ancestor load the data} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result or (Size <> 7) then exit; {Size must be 7} + + {Reads data} + fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^); + fMonth := pByte(Longint(Data) + 2)^; + fDay := pByte(Longint(Data) + 3)^; + fHour := pByte(Longint(Data) + 4)^; + fMinute := pByte(Longint(Data) + 5)^; + fSecond := pByte(Longint(Data) + 6)^; +end; + +{Assigns from another TChunk} +procedure TChunktIME.Assign(Source: TChunk); +begin + fYear := TChunktIME(Source).fYear; + fMonth := TChunktIME(Source).fMonth; + fDay := TChunktIME(Source).fDay; + fHour := TChunktIME(Source).fHour; + fMinute := TChunktIME(Source).fMinute; + fSecond := TChunktIME(Source).fSecond; +end; + +{Saving the chunk to a stream} +function TChunktIME.SaveToStream(Stream: TStream): Boolean; +begin + {Update data} + ResizeData(7); {Make sure the size is 7} + pWord(Data)^ := ByteSwap16(Year); + pByte(Longint(Data) + 2)^ := Month; + pByte(Longint(Data) + 3)^ := Day; + pByte(Longint(Data) + 4)^ := Hour; + pByte(Longint(Data) + 5)^ := Minute; + pByte(Longint(Data) + 6)^ := Second; + + {Let inherited save data} + Result := inherited SaveToStream(Stream); +end; + +{TChunkztXt implementation} + +{Loading the chunk from a stream} +function TChunkzTXt.LoadFromStream(Stream: TStream; + const ChunkName: TChunkName; Size: Integer): Boolean; +var + ErrorOutput: String; + CompressionMethod: Byte; + Output: Pointer; + OutputSize: Integer; +begin + {Load data from stream and validate} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result or (Size < 4) then exit; + fKeyword := PChar(Data); {Get keyword and compression method bellow} + if Longint(fKeyword) = 0 then + CompressionMethod := pByte(Data)^ + else + CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^; + fText := ''; + + {In case the compression is 0 (only one accepted by specs), reads it} + if CompressionMethod = 0 then + begin + Output := nil; + if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2), + Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then + begin + SetLength(fText, OutputSize); + CopyMemory(@fText[1], Output, OutputSize); + end {if DecompressZLIB(...}; + FreeMem(Output); + end {if CompressionMethod = 0} + +end; + +{Saving the chunk to a stream} +function TChunkztXt.SaveToStream(Stream: TStream): Boolean; +var + Output: Pointer; + OutputSize: Integer; + ErrorOutput: String; +begin + Output := nil; {Initializes output} + if fText = '' then fText := ' '; + + {Compresses the data} + if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output, + OutputSize, ErrorOutput) then + begin + {Size is length from keyword, plus a null character to divide} + {plus the compression method, plus the length of the text (zlib compressed)} + ResizeData(Length(fKeyword) + 2 + OutputSize); + + Fillchar(Data^, DataSize, #0); + {Copies the keyword data} + if Keyword <> '' then + CopyMemory(Data, @fKeyword[1], Length(Keyword)); + {Compression method 0 (inflate/deflate)} + pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0; + if OutputSize > 0 then + CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize); + + {Let ancestor calculate crc and save} + Result := SaveData(Stream); + end {if CompressZLIB(...} else Result := False; + + {Frees output} + if Output <> nil then FreeMem(Output) +end; + +{TChunktEXt implementation} + +{Assigns from another text chunk} +procedure TChunktEXt.Assign(Source: TChunk); +begin + fKeyword := TChunktEXt(Source).fKeyword; + fText := TChunktEXt(Source).fText; +end; + +{Loading the chunk from a stream} +function TChunktEXt.LoadFromStream(Stream: TStream; + const ChunkName: TChunkName; Size: Integer): Boolean; +begin + {Load data from stream and validate} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result or (Size < 3) then exit; + {Get text} + fKeyword := PChar(Data); + SetLength(fText, Size - Length(fKeyword) - 1); + CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1), + Length(fText)); +end; + +{Saving the chunk to a stream} +function TChunktEXt.SaveToStream(Stream: TStream): Boolean; +begin + {Size is length from keyword, plus a null character to divide} + {plus the length of the text} + ResizeData(Length(fKeyword) + 1 + Length(fText)); + Fillchar(Data^, DataSize, #0); + {Copy data} + if Keyword <> '' then + CopyMemory(Data, @fKeyword[1], Length(Keyword)); + if Text <> '' then + CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1], + Length(Text)); + {Let ancestor calculate crc and save} + Result := inherited SaveToStream(Stream); +end; + + +{TChunkIHDR implementation} + +{Chunk being created} +constructor TChunkIHDR.Create(Owner: TPngObject); +begin + {Prepare pointers} + ImageHandle := 0; + ImagePalette := 0; + ImageDC := 0; + + {Call inherited} + inherited Create(Owner); +end; + +{Chunk being destroyed} +destructor TChunkIHDR.Destroy; +begin + {Free memory} + FreeImageData(); + + {Calls TChunk destroy} + inherited Destroy; +end; + +{Copies the palette} +procedure CopyPalette(Source: HPALETTE; Destination: HPALETTE); +var + PaletteSize: Integer; + Entries: Array[Byte] of TPaletteEntry; +begin + PaletteSize := 0; + if GetObject(Source, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; + if PaletteSize = 0 then Exit; + ResizePalette(Destination, PaletteSize); + GetPaletteEntries(Source, 0, PaletteSize, Entries); + SetPaletteEntries(Destination, 0, PaletteSize, Entries); +end; + +{Assigns from another IHDR chunk} +procedure TChunkIHDR.Assign(Source: TChunk); +begin + {Copy the IHDR data} + if Source is TChunkIHDR then + begin + {Copy IHDR values} + IHDRData := TChunkIHDR(Source).IHDRData; + + {Prepare to hold data by filling BitmapInfo structure and} + {resizing ImageData and ImageAlpha memory allocations} + PrepareImageData(); + + {Copy image data} + CopyMemory(ImageData, TChunkIHDR(Source).ImageData, + BytesPerRow * Integer(Height)); + CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha, + Integer(Width) * Integer(Height)); + + {Copy palette colors} + BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors; + {Copy palette also} + CopyPalette(TChunkIHDR(Source).ImagePalette, ImagePalette); + end + else + Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); +end; + +{Release allocated image data} +procedure TChunkIHDR.FreeImageData; +begin + {Free old image data} + if ImageHandle <> 0 then DeleteObject(ImageHandle); + if ImageDC <> 0 then DeleteDC(ImageDC); + if ImageAlpha <> nil then FreeMem(ImageAlpha); + if ImagePalette <> 0 then DeleteObject(ImagePalette); + {$IFDEF Store16bits} + if ExtraImageData <> nil then FreeMem(ExtraImageData); + {$ENDIF} + ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil; + ImagePalette := 0; ExtraImageData := nil; +end; + +{Chunk being loaded from a stream} +function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; +begin + {Let TChunk load it} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result then Exit; + + {Now check values} + {Note: It's recommended by png specification to make sure that the size} + {must be 13 bytes to be valid, but some images with 14 bytes were found} + {which could be loaded by internet explorer and other tools} + if (fDataSize < SIZEOF(TIHdrData)) then + begin + {Ihdr must always have at least 13 bytes} + Result := False; + Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText); + exit; + end; + + {Everything ok, reads IHDR} + IHDRData := pIHDRData(fData)^; + IHDRData.Width := ByteSwap(IHDRData.Width); + IHDRData.Height := ByteSwap(IHDRData.Height); + + {The width and height must not be larger than 65535 pixels} + if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then + begin + Result := False; + Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText); + exit; + end {if IHDRData.Width > High(Word)}; + {Compression method must be 0 (inflate/deflate)} + if (IHDRData.CompressionMethod <> 0) then + begin + Result := False; + Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText); + exit; + end; + {Interlace must be either 0 (none) or 7 (adam7)} + if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then + begin + Result := False; + Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText); + exit; + end; + + {Updates owner properties} + Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod); + + {Prepares data to hold image} + PrepareImageData(); +end; + +{Saving the IHDR chunk to a stream} +function TChunkIHDR.SaveToStream(Stream: TStream): Boolean; +begin + {Ignore 2 bits images} + if BitDepth = 2 then BitDepth := 4; + + {It needs to do is update the data with the IHDR data} + {structure containing the write values} + ResizeData(SizeOf(TIHDRData)); + pIHDRData(fData)^ := IHDRData; + {..byteswap 4 byte types} + pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width); + pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height); + {..update interlace method} + pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod); + {..and then let the ancestor SaveToStream do the hard work} + Result := inherited SaveToStream(Stream); +end; + +{Creates a grayscale palette} +function TChunkIHDR.CreateGrayscalePalette(Bitdepth: Integer): HPalette; +var + j: Integer; + palEntries: TMaxLogPalette; +begin + {Prepares and fills the strucutre} + if Bitdepth = 16 then Bitdepth := 8; + fillchar(palEntries, sizeof(palEntries), 0); + palEntries.palVersion := $300; + palEntries.palNumEntries := 1 shl Bitdepth; + {Fill it with grayscale colors} + for j := 0 to palEntries.palNumEntries - 1 do + begin + palEntries.palPalEntry[j].peRed := + fOwner.GammaTable[MulDiv(j, 255, palEntries.palNumEntries - 1)]; + palEntries.palPalEntry[j].peGreen := palEntries.palPalEntry[j].peRed; + palEntries.palPalEntry[j].peBlue := palEntries.palPalEntry[j].peRed; + end; + {Creates and returns the palette} + Result := CreatePalette(pLogPalette(@palEntries)^); +end; + +{Copies the palette to the Device Independent bitmap header} +procedure TChunkIHDR.PaletteToDIB(Palette: HPalette); +var + j: Integer; + palEntries: TMaxLogPalette; +begin + {Copy colors} + Fillchar(palEntries, sizeof(palEntries), #0); + BitmapInfo.bmiHeader.biClrUsed := GetPaletteEntries(Palette, 0, 256, palEntries.palPalEntry[0]); + for j := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do + begin + BitmapInfo.bmiColors[j].rgbBlue := palEntries.palPalEntry[j].peBlue; + BitmapInfo.bmiColors[j].rgbRed := palEntries.palPalEntry[j].peRed; + BitmapInfo.bmiColors[j].rgbGreen := palEntries.palPalEntry[j].peGreen; + end; +end; + +{Resizes the image data to fill the color type, bit depth, } +{width and height parameters} +procedure TChunkIHDR.PrepareImageData(); + {Set the bitmap info} + procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean); + begin + + {Copy if the bitmap contain palette entries} + HasPalette := Palette; + {Fill the strucutre} + with BitmapInfo.bmiHeader do + begin + biSize := sizeof(TBitmapInfoHeader); + biHeight := Height; + biWidth := Width; + biPlanes := 1; + biBitCount := BitDepth; + biCompression := BI_RGB; + end {with BitmapInfo.bmiHeader} + end; +begin + {Prepare bitmap info header} + Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0); + {Release old image data} + FreeImageData(); + + {Obtain number of bits for each pixel} + case ColorType of + COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA: + case BitDepth of + {These are supported by windows} + 1, 4, 8: SetInfo(BitDepth, TRUE); + {2 bits for each pixel is not supported by windows bitmap} + 2 : SetInfo(4, TRUE); + {Also 16 bits (2 bytes) for each pixel is not supported} + {and should be transormed into a 8 bit grayscale} + 16 : SetInfo(8, TRUE); + end; + {Only 1 byte (8 bits) is supported} + COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE); + end {case ColorType}; + {Number of bytes for each scanline} + BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31) + and not 31) div 8; + + {Build array for alpha information, if necessary} + if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then + begin + GetMem(ImageAlpha, Integer(Width) * Integer(Height)); + FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0); + end; + + {Build array for extra byte information} + {$IFDEF Store16bits} + if (BitDepth = 16) then + begin + GetMem(ExtraImageData, BytesPerRow * Integer(Height)); + FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0); + end; + {$ENDIF} + + {Creates the image to hold the data, CreateDIBSection does a better} + {work in allocating necessary memory} + ImageDC := CreateCompatibleDC(0); + {$IFDEF UseDelphi}Self.Owner.Canvas.Handle := ImageDC;{$ENDIF} + + {In case it is a palette image, create the palette} + if HasPalette then + begin + {Create a standard palette} + if ColorType = COLOR_PALETTE then + ImagePalette := CreateHalfTonePalette(ImageDC) + else + ImagePalette := CreateGrayscalePalette(Bitdepth); + ResizePalette(ImagePalette, 1 shl BitmapInfo.bmiHeader.biBitCount); + BitmapInfo.bmiHeader.biClrUsed := 1 shl BitmapInfo.bmiHeader.biBitCount; + SelectPalette(ImageDC, ImagePalette, False); + RealizePalette(ImageDC); + PaletteTODIB(ImagePalette); + end; + + {Create the device independent bitmap} + ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^, + DIB_RGB_COLORS, ImageData, 0, 0); + SelectObject(ImageDC, ImageHandle); + + {Build array and allocate bytes for each row} + fillchar(ImageData^, BytesPerRow * Integer(Height), 0); +end; + +{TChunktRNS implementation} + +{$IFNDEF UseDelphi} +function CompareMem(P1, P2: pByte; const Size: Integer): Boolean; +var i: Integer; +begin + Result := True; + for i := 1 to Size do + begin + if P1^ <> P2^ then Result := False; + inc(P1); inc(P2); + end {for i} +end; +{$ENDIF} + +{Sets the transpararent color} +procedure TChunktRNS.SetTransparentColor(const Value: ColorRef); +var + i: Byte; + LookColor: TRGBQuad; +begin + {Clears the palette values} + Fillchar(PaletteValues, SizeOf(PaletteValues), #0); + {Sets that it uses bit transparency} + fBitTransparency := True; + + + {Depends on the color type} + with Header do + case ColorType of + COLOR_GRAYSCALE: + begin + Self.ResizeData(2); + pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); + end; + COLOR_RGB: + begin + Self.ResizeData(6); + pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); + pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value)); + pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value)); + end; + COLOR_PALETTE: + begin + {Creates a RGBQuad to search for the color} + LookColor.rgbRed := GetRValue(Value); + LookColor.rgbGreen := GetGValue(Value); + LookColor.rgbBlue := GetBValue(Value); + {Look in the table for the entry} + for i := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do + if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then + Break; + {Fill the transparency table} + Fillchar(PaletteValues, i, 255); + Self.ResizeData(i + 1) + + end + end {case / with}; + +end; + +{Returns the transparent color for the image} +function TChunktRNS.GetTransparentColor: ColorRef; +var + PaletteChunk: TChunkPLTE; + i: Integer; + Value: Byte; +begin + Result := 0; {Default: Unknown transparent color} + + {Depends on the color type} + with Header do + case ColorType of + COLOR_GRAYSCALE: + begin + Value := BitmapInfo.bmiColors[PaletteValues[1]].rgbRed; + Result := RGB(Value, Value, Value); + end; + COLOR_RGB: + Result := RGB(fOwner.GammaTable[PaletteValues[1]], + fOwner.GammaTable[PaletteValues[3]], + fOwner.GammaTable[PaletteValues[5]]); + COLOR_PALETTE: + begin + {Obtains the palette chunk} + PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE; + + {Looks for an entry with 0 transparency meaning that it is the} + {full transparent entry} + for i := 0 to Self.DataSize - 1 do + if PaletteValues[i] = 0 then + with PaletteChunk.GetPaletteItem(i) do + begin + Result := RGB(rgbRed, rgbGreen, rgbBlue); + break + end + end {COLOR_PALETTE} + end {case Header.ColorType}; +end; + +{Saving the chunk to a stream} +function TChunktRNS.SaveToStream(Stream: TStream): Boolean; +begin + {Copy palette into data buffer} + if DataSize <= 256 then + CopyMemory(fData, @PaletteValues[0], DataSize); + + Result := inherited SaveToStream(Stream); +end; + +{Assigns from another chunk} +procedure TChunktRNS.Assign(Source: TChunk); +begin + CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256); + fBitTransparency := TChunkTrns(Source).fBitTransparency; + inherited Assign(Source); +end; + +{Loads the chunk from a stream} +function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; +var + i, Differ255: Integer; +begin + {Let inherited load} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + + if not Result then Exit; + + {Make sure size is correct} + if Size > 256 then Owner.RaiseError(EPNGInvalidPalette, + EPNGInvalidPaletteText); + + {The unset items should have value 255} + Fillchar(PaletteValues[0], 256, 255); + {Copy the other values} + CopyMemory(@PaletteValues[0], fData, Size); + + {Create the mask if needed} + case Header.ColorType of + {Mask for grayscale and RGB} + COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True; + COLOR_PALETTE: + begin + Differ255 := 0; {Count the entries with a value different from 255} + {Tests if it uses bit transparency} + for i := 0 to Size - 1 do + if PaletteValues[i] <> 255 then inc(Differ255); + + {If it has one value different from 255 it is a bit transparency} + fBitTransparency := (Differ255 = 1); + end {COLOR_PALETTE} + end {case Header.ColorType}; + +end; + +{Prepares the image palette} +procedure TChunkIDAT.PreparePalette; +var + Entries: Word; + j : Integer; + palEntries: TMaxLogPalette; +begin + {In case the image uses grayscale, build a grayscale palette} + with Header do + if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then + begin + {Calculate total number of palette entries} + Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount)); + Fillchar(palEntries, sizeof(palEntries), #0); + palEntries.palVersion := $300; + palEntries.palNumEntries := Entries; + + FOR j := 0 TO Entries - 1 DO + with palEntries.palPalEntry[j] do + begin + + {Calculate each palette entry} + peRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)]; + peGreen := peRed; + peBlue := peRed; + end {with BitmapInfo.bmiColors[j]}; + Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^)); + end {if ColorType = COLOR_GRAYSCALE..., with Header} +end; + +{Reads from ZLIB} +function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; + Buffer: Pointer; Count: Integer; var EndPos: Integer; + var crcfile: Cardinal): Integer; +var + ProcResult : Integer; + IDATHeader : Array[0..3] of char; + IDATCRC : Cardinal; +begin + {Uses internal record pointed by ZLIBStream to gather information} + with ZLIBStream, ZLIBStream.zlib do + begin + {Set the buffer the zlib will read into} + next_out := Buffer; + avail_out := Count; + + {Decode until it reach the Count variable} + while avail_out > 0 do + begin + {In case it needs more data and it's in the end of a IDAT chunk,} + {it means that there are more IDAT chunks} + if (fStream.Position = EndPos) and (avail_out > 0) and + (avail_in = 0) then + begin + {End this chunk by reading and testing the crc value} + fStream.Read(IDATCRC, 4); + + {$IFDEF CheckCRC} + if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then + begin + Result := -1; + Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText); + exit; + end; + {$ENDIF} + + {Start reading the next chunk} + fStream.Read(EndPos, 4); {Reads next chunk size} + fStream.Read(IDATHeader[0], 4); {Next chunk header} + {It must be a IDAT chunk since image data is required and PNG} + {specification says that multiple IDAT chunks must be consecutive} + if IDATHeader <> 'IDAT' then + begin + Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText); + result := -1; + exit; + end; + + {Calculate chunk name part of the crc} + {$IFDEF CheckCRC} + crcfile := update_crc($ffffffff, @IDATHeader[0], 4); + {$ENDIF} + EndPos := fStream.Position + ByteSwap(EndPos); + end; + + + {In case it needs compressed data to read from} + if avail_in = 0 then + begin + {In case it's trying to read more than it is avaliable} + if fStream.Position + ZLIBAllocate > EndPos then + avail_in := fStream.Read(Data^, EndPos - fStream.Position) + else + avail_in := fStream.Read(Data^, ZLIBAllocate); + {Update crc} + {$IFDEF CheckCRC} + crcfile := update_crc(crcfile, Data, avail_in); + {$ENDIF} + + {In case there is no more compressed data to read from} + if avail_in = 0 then + begin + Result := Count - avail_out; + Exit; + end; + + {Set next buffer to read and record current position} + next_in := Data; + + end {if avail_in = 0}; + + ProcResult := inflate(zlib, 0); + + {In case the result was not sucessfull} + if (ProcResult < 0) then + begin + Result := -1; + Owner.RaiseError(EPNGZLIBError, + EPNGZLIBErrorText + zliberrors[procresult]); + exit; + end; + + end {while avail_out > 0}; + + end {with}; + + {If everything gone ok, it returns the count bytes} + Result := Count; +end; + +{TChunkIDAT implementation} + +const + {Adam 7 interlacing values} + RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); + ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); + RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); + ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); + +{Copy interlaced images with 1 byte for R, G, B} +procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col * 3); + repeat + {Copy this row} + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + + {Move to next column} + inc(Src, 3); + inc(Dest, ColumnIncrement[Pass] * 3 - 3); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy interlaced images with 2 bytes for R, G, B} +procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col * 3); + repeat + {Copy this row} + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {$IFDEF Store16bits} + {Copy extra pixel values} + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + {$ENDIF} + + {Move to next column} + inc(Src, 6); + inc(Dest, ColumnIncrement[Pass] * 3 - 3); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy нmages with palette using bit depths 1, 4 or 8} +procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +const + BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); + StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); +var + CurBit, Col: Integer; + Dest2: PChar; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + repeat + {Copy data} + CurBit := StartBit[Header.BitDepth]; + repeat + {Adjust pointer to pixel byte bounds} + Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8); + {Copy data} + Byte(Dest2^) := Byte(Dest2^) or + ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth]) + shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8))); + + {Move to next column} + inc(Col, ColumnIncrement[Pass]); + {Will read next bits} + dec(CurBit, Header.BitDepth); + until CurBit < 0; + + {Move to next byte in source} + inc(Src); + until Col >= ImageWidth; +end; + +{Copy нmages with palette using bit depth 2} +procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, + Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + CurBit, Col: Integer; + Dest2: PChar; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + repeat + {Copy data} + CurBit := 6; + repeat + {Adjust pointer to pixel byte bounds} + Dest2 := pChar(Longint(Dest) + Col div 2); + {Copy data} + Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) + shl (4 - (4 * Col) mod 8)); + {Move to next column} + inc(Col, ColumnIncrement[Pass]); + {Will read next bits} + dec(CurBit, 2); + until CurBit < 0; + + {Move to next byte in source} + inc(Src); + until Col >= ImageWidth; +end; + +{Copy нmages with grayscale using bit depth 2} +procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + CurBit, Col: Integer; + Dest2: PChar; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + repeat + {Copy data} + CurBit := 6; + repeat + {Adjust pointer to pixel byte bounds} + Dest2 := pChar(Longint(Dest) + Col div 2); + {Copy data} + Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F) + shl (4 - (Col*4) mod 8)); + {Move to next column} + inc(Col, ColumnIncrement[Pass]); + {Will read next bits} + dec(CurBit, 2); + until CurBit < 0; + + {Move to next byte in source} + inc(Src); + until Col >= ImageWidth; +end; + +{Copy нmages with palette using 2 bytes for each pixel} +procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col); + repeat + {Copy this row} + Dest^ := Src^; inc(Dest); + {$IFDEF Store16bits} + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); + {$ENDIF} + + {Move to next column} + inc(Src, 2); + inc(Dest, ColumnIncrement[Pass] - 1); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Decodes interlaced RGB alpha with 1 byte for each sample} +procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col * 3); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row and alpha value} + Trans^ := pChar(Longint(Src) + 3)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + + {Move to next column} + inc(Src, 4); + inc(Dest, ColumnIncrement[Pass] * 3 - 3); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Decodes interlaced RGB alpha with 2 bytes for each sample} +procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col * 3); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row and alpha value} + Trans^ := pChar(Longint(Src) + 6)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {$IFDEF Store16bits} + {Copy extra pixel values} + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + {$ENDIF} + + {Move to next column} + inc(Src, 8); + inc(Dest, ColumnIncrement[Pass] * 3 - 3); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Decodes 8 bit grayscale image followed by an alpha sample} +procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column, pointers to the data and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this grayscale value and alpha} + Dest^ := Src^; inc(Src); + Trans^ := Src^; inc(Src); + + {Move to next column} + inc(Dest, ColumnIncrement[Pass]); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Decodes 16 bit grayscale image followed by an alpha sample} +procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + Col: Integer; +begin + {Get first column, pointers to the data and enter in loop} + Col := ColumnStart[Pass]; + Dest := pChar(Longint(Dest) + Col); + Trans := pChar(Longint(Trans) + Col); + repeat + {$IFDEF Store16bits} + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); + {$ENDIF} + {Copy this grayscale value and alpha, transforming 16 bits into 8} + Dest^ := Src^; inc(Src, 2); + Trans^ := Src^; inc(Src, 2); + + {Move to next column} + inc(Dest, ColumnIncrement[Pass]); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Decodes an interlaced image} +procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream; + var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); +var + CurrentPass: Byte; + PixelsThisRow: Integer; + CurrentRow: Integer; + Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; + CopyProc: procedure(const Pass: Byte; Src, Dest, + Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; +begin + + CopyProc := nil; {Initialize} + {Determine method to copy the image data} + case Header.ColorType of + {R, G, B values for each pixel} + COLOR_RGB: + case Header.BitDepth of + 8: CopyProc := CopyInterlacedRGB8; + 16: CopyProc := CopyInterlacedRGB16; + end {case Header.BitDepth}; + {Palette} + COLOR_PALETTE, COLOR_GRAYSCALE: + case Header.BitDepth of + 1, 4, 8: CopyProc := CopyInterlacedPalette148; + 2 : if Header.ColorType = COLOR_PALETTE then + CopyProc := CopyInterlacedPalette2 + else + CopyProc := CopyInterlacedGray2; + 16 : CopyProc := CopyInterlacedGrayscale16; + end; + {RGB followed by alpha} + COLOR_RGBALPHA: + case Header.BitDepth of + 8: CopyProc := CopyInterlacedRGBAlpha8; + 16: CopyProc := CopyInterlacedRGBAlpha16; + end; + {Grayscale followed by alpha} + COLOR_GRAYSCALEALPHA: + case Header.BitDepth of + 8: CopyProc := CopyInterlacedGrayscaleAlpha8; + 16: CopyProc := CopyInterlacedGrayscaleAlpha16; + end; + end {case Header.ColorType}; + + {Adam7 method has 7 passes to make the final image} + FOR CurrentPass := 0 TO 6 DO + begin + {Calculates the number of pixels and bytes for this pass row} + PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] + + ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass]; + Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType, + Header.BitDepth); + {Clear buffer for this pass} + ZeroMemory(Row_Buffer[not RowUsed], Row_Bytes); + + {Get current row index} + CurrentRow := RowStart[CurrentPass]; + {Get a pointer to the current row image data} + Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow * + (ImageHeight - 1 - CurrentRow)); + Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow); + {$IFDEF Store16bits} + Extra := Ptr(Longint(Header.ExtraImageData) + Header.BytesPerRow * + (ImageHeight - 1 - CurrentRow)); + {$ENDIF} + + if Row_Bytes > 0 then {There must have bytes for this interlaced pass} + while CurrentRow < ImageHeight do + begin + {Reads this line and filter} + if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, + EndPos, CRCFile) = 0 then break; + + FilterRow; + {Copy image data} + + CopyProc(CurrentPass, @Row_Buffer[RowUsed][1], Data, Trans + {$IFDEF Store16bits}, Extra{$ENDIF}); + + {Use the other RowBuffer item} + RowUsed := not RowUsed; + + {Move to the next row} + inc(CurrentRow, RowIncrement[CurrentPass]); + {Move pointer to the next line} + dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow); + inc(Trans, RowIncrement[CurrentPass] * ImageWidth); + {$IFDEF Store16bits} + dec(Extra, RowIncrement[CurrentPass] * Header.BytesPerRow); + {$ENDIF} + end {while CurrentRow < ImageHeight}; + + end {FOR CurrentPass}; + +end; + +{Copy 8 bits RGB image} +procedure TChunkIDAT.CopyNonInterlacedRGB8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Copy pixel values} + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {Move to next pixel} + inc(Src, 3); + end {for I} +end; + +{Copy 16 bits RGB image} +procedure TChunkIDAT.CopyNonInterlacedRGB16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + //Since windows does not supports 2 bytes for + //each R, G, B value, the method will read only 1 byte from it + {Copy pixel values} + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {$IFDEF Store16bits} + {Copy extra pixel values} + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + {$ENDIF} + + {Move to next pixel} + inc(Src, 6); + end {for I} +end; + +{Copy types using palettes (1, 4 or 8 bits per pixel)} +procedure TChunkIDAT.CopyNonInterlacedPalette148( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +begin + {It's simple as copying the data} + CopyMemory(Dest, Src, Row_Bytes); +end; + +{Copy grayscale types using 2 bits for each pixel} +procedure TChunkIDAT.CopyNonInterlacedGray2( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + i: Integer; +begin + {2 bits is not supported, this routine will converted into 4 bits} + FOR i := 1 TO Row_Bytes do + begin + Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); + inc(Dest); + Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); + inc(Dest); + inc(Src); + end {FOR i} +end; + +{Copy types using palette with 2 bits for each pixel} +procedure TChunkIDAT.CopyNonInterlacedPalette2( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + i: Integer; +begin + {2 bits is not supported, this routine will converted into 4 bits} + FOR i := 1 TO Row_Bytes do + begin + Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); + inc(Dest); + Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); + inc(Dest); + inc(Src); + end {FOR i} +end; + +{Copy grayscale images with 16 bits} +procedure TChunkIDAT.CopyNonInterlacedGrayscale16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Windows does not supports 16 bits for each pixel in grayscale} + {mode, so reduce to 8} + Dest^ := Src^; inc(Dest); + {$IFDEF Store16bits} + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); + {$ENDIF} + + {Move to next pixel} + inc(Src, 2); + end {for I} +end; + +{Copy 8 bits per sample RGB images followed by an alpha byte} +procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + i: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Copy pixel values and transparency} + Trans^ := pChar(Longint(Src) + 3)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {Move to next pixel} + inc(Src, 4); inc(Trans); + end {for I} +end; + +{Copy 16 bits RGB image with alpha using 2 bytes for each sample} +procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + //Copy rgb and alpha values (transforming from 16 bits to 8 bits) + {Copy pixel values} + Trans^ := pChar(Longint(Src) + 6)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + {$IFDEF Store16bits} + {Copy extra pixel values} + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + {$ENDIF} + {Move to next pixel} + inc(Src, 8); inc(Trans); + end {for I} +end; + +{Copy 8 bits per sample grayscale followed by alpha} +procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Copy alpha value and then gray value} + Dest^ := Src^; inc(Src); + Trans^ := Src^; inc(Src); + inc(Dest); inc(Trans); + end; +end; + +{Copy 16 bits per sample grayscale followed by alpha} +procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Copy alpha value and then gray value} + {$IFDEF Store16bits} + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); + {$ENDIF} + Dest^ := Src^; inc(Src, 2); + Trans^ := Src^; inc(Src, 2); + inc(Dest); inc(Trans); + end; +end; + +{Decode non interlaced image} +procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream; + var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); +var + j: Cardinal; + Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; + CopyProc: procedure( + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; +begin + CopyProc := nil; {Initialize} + {Determines the method to copy the image data} + case Header.ColorType of + {R, G, B values} + COLOR_RGB: + case Header.BitDepth of + 8: CopyProc := CopyNonInterlacedRGB8; + 16: CopyProc := CopyNonInterlacedRGB16; + end; + {Types using palettes} + COLOR_PALETTE, COLOR_GRAYSCALE: + case Header.BitDepth of + 1, 4, 8: CopyProc := CopyNonInterlacedPalette148; + 2 : if Header.ColorType = COLOR_PALETTE then + CopyProc := CopyNonInterlacedPalette2 + else + CopyProc := CopyNonInterlacedGray2; + 16 : CopyProc := CopyNonInterlacedGrayscale16; + end; + {R, G, B followed by alpha} + COLOR_RGBALPHA: + case Header.BitDepth of + 8 : CopyProc := CopyNonInterlacedRGBAlpha8; + 16 : CopyProc := CopyNonInterlacedRGBAlpha16; + end; + {Grayscale followed by alpha} + COLOR_GRAYSCALEALPHA: + case Header.BitDepth of + 8 : CopyProc := CopyNonInterlacedGrayscaleAlpha8; + 16 : CopyProc := CopyNonInterlacedGrayscaleAlpha16; + end; + end; + + {Get the image data pointer} + Longint(Data) := Longint(Header.ImageData) + + Header.BytesPerRow * (ImageHeight - 1); + Trans := Header.ImageAlpha; + {$IFDEF Store16bits} + Longint(Extra) := Longint(Header.ExtraImageData) + + Header.BytesPerRow * (ImageHeight - 1); + {$ENDIF} + {Reads each line} + FOR j := 0 to ImageHeight - 1 do + begin + {Read this line Row_Buffer[RowUsed][0] if the filter type for this line} + if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, EndPos, + CRCFile) = 0 then break; + + {Filter the current row} + FilterRow; + {Copies non interlaced row to image} + CopyProc(@Row_Buffer[RowUsed][1], Data, Trans{$IFDEF Store16bits}, Extra + {$ENDIF}); + + {Invert line used} + RowUsed := not RowUsed; + dec(Data, Header.BytesPerRow); + {$IFDEF Store16bits}dec(Extra, Header.BytesPerRow);{$ENDIF} + inc(Trans, ImageWidth); + end {for I}; + + +end; + +{Filter the current line} +procedure TChunkIDAT.FilterRow; +var + pp: Byte; + vv, left, above, aboveleft: Integer; + Col: Cardinal; +begin + {Test the filter} + case Row_Buffer[RowUsed]^[0] of + {No filtering for this line} + FILTER_NONE: begin end; + {AND 255 serves only to never let the result be larger than one byte} + {Sub filter} + FILTER_SUB: + FOR Col := Offset + 1 to Row_Bytes DO + Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + + Row_Buffer[RowUsed][Col - Offset]) and 255; + {Up filter} + FILTER_UP: + FOR Col := 1 to Row_Bytes DO + Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + + Row_Buffer[not RowUsed][Col]) and 255; + {Average filter} + FILTER_AVERAGE: + FOR Col := 1 to Row_Bytes DO + begin + {Obtains up and left pixels} + above := Row_Buffer[not RowUsed][Col]; + if col - 1 < Offset then + left := 0 + else + Left := Row_Buffer[RowUsed][Col - Offset]; + + {Calculates} + Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + + (left + above) div 2) and 255; + end; + {Paeth filter} + FILTER_PAETH: + begin + {Initialize} + left := 0; + aboveleft := 0; + {Test each byte} + FOR Col := 1 to Row_Bytes DO + begin + {Obtains above pixel} + above := Row_Buffer[not RowUsed][Col]; + {Obtains left and top-left pixels} + if (col - 1 >= offset) Then + begin + left := row_buffer[RowUsed][col - offset]; + aboveleft := row_buffer[not RowUsed][col - offset]; + end; + + {Obtains current pixel and paeth predictor} + vv := row_buffer[RowUsed][Col]; + pp := PaethPredictor(left, above, aboveleft); + + {Calculates} + Row_Buffer[RowUsed][Col] := (pp + vv) and $FF; + end {for}; + end; + + end {case}; +end; + +{Reads the image data from the stream} +function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; +var + ZLIBStream: TZStreamRec2; + CRCCheck, + CRCFile : Cardinal; +begin + {Get pointer to the header chunk} + Header := Owner.Chunks.Item[0] as TChunkIHDR; + {Build palette if necessary} + if Header.HasPalette then PreparePalette(); + + {Copy image width and height} + ImageWidth := Header.Width; + ImageHeight := Header.Height; + + {Initialize to calculate CRC} + {$IFDEF CheckCRC} + CRCFile := update_crc($ffffffff, @ChunkName[0], 4); + {$ENDIF} + + Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information} + ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression} + + {Calculate ending position for the current IDAT chunk} + EndPos := Stream.Position + Size; + + {Allocate memory} + GetMem(Row_Buffer[false], Row_Bytes + 1); + GetMem(Row_Buffer[true], Row_Bytes + 1); + ZeroMemory(Row_Buffer[false], Row_bytes + 1); + {Set the variable to alternate the Row_Buffer item to use} + RowUsed := TRUE; + + {Call special methods for the different interlace methods} + case Owner.InterlaceMethod of + imNone: DecodeNonInterlaced(stream, ZLIBStream, Size, crcfile); + imAdam7: DecodeInterlacedAdam7(stream, ZLIBStream, size, crcfile); + end; + + {Free memory} + ZLIBTerminateInflate(ZLIBStream); {Terminates decompression} + FreeMem(Row_Buffer[False], Row_Bytes + 1); + FreeMem(Row_Buffer[True], Row_Bytes + 1); + + {Now checks CRC} + Stream.Read(CRCCheck, 4); + {$IFDEF CheckCRC} + CRCFile := CRCFile xor $ffffffff; + CRCCheck := ByteSwap(CRCCheck); + Result := CRCCheck = CRCFile; + + {Handle CRC error} + if not Result then + begin + {In case it coult not load chunk} + Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText); + exit; + end; + {$ELSE}Result := TRUE; {$ENDIF} +end; + +const + IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T'); + BUFFER = 5; + +{Saves the IDAT chunk to a stream} +function TChunkIDAT.SaveToStream(Stream: TStream): Boolean; +var + ZLIBStream : TZStreamRec2; +begin + {Get pointer to the header chunk} + Header := Owner.Chunks.Item[0] as TChunkIHDR; + {Copy image width and height} + ImageWidth := Header.Width; + ImageHeight := Header.Height; + Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information} + + {Allocate memory} + GetMem(Encode_Buffer[BUFFER], Row_Bytes); + ZeroMemory(Encode_Buffer[BUFFER], Row_Bytes); + {Allocate buffers for the filters selected} + {Filter none will always be calculated to the other filters to work} + GetMem(Encode_Buffer[FILTER_NONE], Row_Bytes); + ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes); + if pfSub in Owner.Filters then + GetMem(Encode_Buffer[FILTER_SUB], Row_Bytes); + if pfUp in Owner.Filters then + GetMem(Encode_Buffer[FILTER_UP], Row_Bytes); + if pfAverage in Owner.Filters then + GetMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes); + if pfPaeth in Owner.Filters then + GetMem(Encode_Buffer[FILTER_PAETH], Row_Bytes); + + {Initialize ZLIB} + ZLIBStream := ZLIBInitDeflate(Stream, Owner.fCompressionLevel, + Owner.MaxIdatSize); + {Write data depending on the interlace method} + case Owner.InterlaceMethod of + imNone: EncodeNonInterlaced(stream, ZLIBStream); + imAdam7: EncodeInterlacedAdam7(stream, ZLIBStream); + end; + {Terminates ZLIB} + ZLIBTerminateDeflate(ZLIBStream); + + {Release allocated memory} + FreeMem(Encode_Buffer[BUFFER], Row_Bytes); + FreeMem(Encode_Buffer[FILTER_NONE], Row_Bytes); + if pfSub in Owner.Filters then + FreeMem(Encode_Buffer[FILTER_SUB], Row_Bytes); + if pfUp in Owner.Filters then + FreeMem(Encode_Buffer[FILTER_UP], Row_Bytes); + if pfAverage in Owner.Filters then + FreeMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes); + if pfPaeth in Owner.Filters then + FreeMem(Encode_Buffer[FILTER_PAETH], Row_Bytes); + + {Everything went ok} + Result := True; +end; + +{Writes the IDAT using the settings} +procedure WriteIDAT(Stream: TStream; Data: Pointer; const Length: Cardinal); +var + ChunkLen, CRC: Cardinal; +begin + {Writes IDAT header} + ChunkLen := ByteSwap(Length); + Stream.Write(ChunkLen, 4); {Chunk length} + Stream.Write(IDATHeader[0], 4); {Idat header} + CRC := update_crc($ffffffff, @IDATHeader[0], 4); {Crc part for header} + + {Writes IDAT data and calculates CRC for data} + Stream.Write(Data^, Length); + CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff); + {Writes final CRC} + Stream.Write(CRC, 4); +end; + +{Compress and writes IDAT chunk data} +procedure TChunkIDAT.IDATZlibWrite(var ZLIBStream: TZStreamRec2; + Buffer: Pointer; const Length: Cardinal); +begin + with ZLIBStream, ZLIBStream.ZLIB do + begin + {Set data to be compressed} + next_in := Buffer; + avail_in := Length; + + {Compress all the data avaliable to compress} + while avail_in > 0 do + begin + deflate(ZLIB, Z_NO_FLUSH); + + {The whole buffer was used, save data to stream and restore buffer} + if avail_out = 0 then + begin + {Writes this IDAT chunk} + WriteIDAT(fStream, Data, Owner.MaxIdatSize); + + {Restore buffer} + next_out := Data; + avail_out := Owner.MaxIdatSize; + end {if avail_out = 0}; + + end {while avail_in}; + + end {with ZLIBStream, ZLIBStream.ZLIB} +end; + +{Finishes compressing data to write IDAT chunk} +procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2); +begin + with ZLIBStream, ZLIBStream.ZLIB do + begin + {Set data to be compressed} + next_in := nil; + avail_in := 0; + + while deflate(ZLIB,Z_FINISH) <> Z_STREAM_END do + begin + {Writes this IDAT chunk} + WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out); + {Re-update buffer} + next_out := Data; + avail_out := Owner.MaxIdatSize; + end; + + if avail_out < Owner.MaxIdatSize then + {Writes final IDAT} + WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out); + + end {with ZLIBStream, ZLIBStream.ZLIB}; +end; + +{Copy memory to encode RGB image with 1 byte for each color sample} +procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + {Copy pixel values} + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + {Move to next pixel} + inc(Src, 3); + end {for I} +end; + +{Copy memory to encode RGB images with 16 bits for each color sample} +procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word) + //for sample + {Copy pixel values} + pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2); + pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2); + pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2); + {Move to next pixel} + inc(Src, 3); + end {for I} + +end; + +{Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)} +procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); +begin + {It's simple as copying the data} + CopyMemory(Dest, Src, Row_Bytes); +end; + +{Copy memory to encode grayscale images with 2 bytes for each sample} +procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); +var + I: Integer; +begin + FOR I := 1 TO ImageWidth DO + begin + //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word) + //for sample + pWORD(Dest)^ := pByte(Longint(Src))^; inc(Dest, 2); + {Move to next pixel} + inc(Src); + end {for I} +end; + +{Encode images using RGB followed by an alpha value using 1 byte for each} +procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); +var + i: Integer; +begin + {Copy the data to the destination, including data from Trans pointer} + FOR i := 1 TO ImageWidth do + begin + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest); + Dest^ := Trans^; inc(Dest); + inc(Src, 3); inc(Trans); + end {for i}; +end; + +{Encode images using RGB followed by an alpha value using 2 byte for each} +procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); +var + i: Integer; +begin + {Copy the data to the destination, including data from Trans pointer} + FOR i := 1 TO ImageWidth do + begin + pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest, 2); + pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest, 2); + pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest, 2); + pWord(Dest)^ := PByte(Longint(Trans) )^; inc(Dest, 2); + inc(Src, 3); inc(Trans); + end {for i}; +end; + +{Encode grayscale images followed by an alpha value using 1 byte for each} +procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8( + Src, Dest, Trans: pChar); +var + i: Integer; +begin + {Copy the data to the destination, including data from Trans pointer} + FOR i := 1 TO ImageWidth do + begin + Dest^ := Src^; inc(Dest); + Dest^ := Trans^; inc(Dest); + inc(Src); inc(Trans); + end {for i}; +end; + +{Encode grayscale images followed by an alpha value using 2 byte for each} +procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16( + Src, Dest, Trans: pChar); +var + i: Integer; +begin + {Copy the data to the destination, including data from Trans pointer} + FOR i := 1 TO ImageWidth do + begin + pWord(Dest)^ := pByte(Src)^; inc(Dest, 2); + pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); + inc(Src); inc(Trans); + end {for i}; +end; + +{Encode non interlaced images} +procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream; + var ZLIBStream: TZStreamRec2); +var + {Current line} + j: Cardinal; + {Pointers to image data} + Data, Trans: PChar; + {Filter used for this line} + Filter: Byte; + {Method which will copy the data into the buffer} + CopyProc: procedure(Src, Dest, Trans: pChar) of object; +begin + CopyProc := nil; {Initialize to avoid warnings} + {Defines the method to copy the data to the buffer depending on} + {the image parameters} + case Header.ColorType of + {R, G, B values} + COLOR_RGB: + case Header.BitDepth of + 8: CopyProc := EncodeNonInterlacedRGB8; + 16: CopyProc := EncodeNonInterlacedRGB16; + end; + {Palette and grayscale values} + COLOR_GRAYSCALE, COLOR_PALETTE: + case Header.BitDepth of + 1, 4, 8: CopyProc := EncodeNonInterlacedPalette148; + 16: CopyProc := EncodeNonInterlacedGrayscale16; + end; + {RGB with a following alpha value} + COLOR_RGBALPHA: + case Header.BitDepth of + 8: CopyProc := EncodeNonInterlacedRGBAlpha8; + 16: CopyProc := EncodeNonInterlacedRGBAlpha16; + end; + {Grayscale images followed by an alpha} + COLOR_GRAYSCALEALPHA: + case Header.BitDepth of + 8: CopyProc := EncodeNonInterlacedGrayscaleAlpha8; + 16: CopyProc := EncodeNonInterlacedGrayscaleAlpha16; + end; + end {case Header.ColorType}; + + {Get the image data pointer} + Longint(Data) := Longint(Header.ImageData) + + Header.BytesPerRow * (ImageHeight - 1); + Trans := Header.ImageAlpha; + + {Writes each line} + FOR j := 0 to ImageHeight - 1 do + begin + {Copy data into buffer} + CopyProc(Data, @Encode_Buffer[BUFFER][0], Trans); + {Filter data} + Filter := FilterToEncode; + + {Compress data} + IDATZlibWrite(ZLIBStream, @Filter, 1); + IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes); + + {Adjust pointers to the actual image data} + dec(Data, Header.BytesPerRow); + inc(Trans, ImageWidth); + end; + + {Compress and finishes copying the remaining data} + FinishIDATZlib(ZLIBStream); +end; + +{Copy memory to encode interlaced images using RGB value with 1 byte for} +{each color sample} +procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col * 3); + repeat + {Copy this row} + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + + {Move to next column} + inc(Src, ColumnIncrement[Pass] * 3); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy memory to encode interlaced RGB images with 2 bytes each color sample} +procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col * 3); + repeat + {Copy this row} + pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2); + pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2); + pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2); + + {Move to next column} + inc(Src, ColumnIncrement[Pass] * 3); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy memory to encode interlaced images using palettes using bit depths} +{1, 4, 8 (each pixel in the image)} +procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte; + Src, Dest, Trans: pChar); +const + BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); + StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); +var + CurBit, Col: Integer; + Src2: PChar; +begin + {Clean the line} + fillchar(Dest^, Row_Bytes, #0); + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + with Header.BitmapInfo.bmiHeader do + repeat + {Copy data} + CurBit := StartBit[biBitCount]; + repeat + {Adjust pointer to pixel byte bounds} + Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8); + {Copy data} + Byte(Dest^) := Byte(Dest^) or + (((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col) + mod 8))) and (BitTable[biBitCount])) shl CurBit; + + {Move to next column} + inc(Col, ColumnIncrement[Pass]); + {Will read next bits} + dec(CurBit, biBitCount); + until CurBit < 0; + + {Move to next byte in source} + inc(Dest); + until Col >= ImageWidth; +end; + +{Copy to encode interlaced grayscale images using 16 bits for each sample} +procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col); + repeat + {Copy this row} + pWord(Dest)^ := Byte(Src^); inc(Dest, 2); + + {Move to next column} + inc(Src, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy to encode interlaced rgb images followed by an alpha value, all using} +{one byte for each sample} +procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col * 3); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row} + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + Dest^ := Trans^; inc(Dest); + + {Move to next column} + inc(Src, ColumnIncrement[Pass] * 3); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy to encode interlaced rgb images followed by an alpha value, all using} +{two byte for each sample} +procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col * 3); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row} + pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2); + pWord(Dest)^ := pByte(Longint(Src) + 1)^; inc(Dest, 2); + pWord(Dest)^ := pByte(Longint(Src) )^; inc(Dest, 2); + pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); + + {Move to next column} + inc(Src, ColumnIncrement[Pass] * 3); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy to encode grayscale interlaced images followed by an alpha value, all} +{using 1 byte for each sample} +procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row} + Dest^ := Src^; inc(Dest); + Dest^ := Trans^; inc(Dest); + + {Move to next column} + inc(Src, ColumnIncrement[Pass]); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Copy to encode grayscale interlaced images followed by an alpha value, all} +{using 2 bytes for each sample} +procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; + Src, Dest, Trans: pChar); +var + Col: Integer; +begin + {Get first column and enter in loop} + Col := ColumnStart[Pass]; + Src := pChar(Longint(Src) + Col); + Trans := pChar(Longint(Trans) + Col); + repeat + {Copy this row} + pWord(Dest)^ := pByte(Src)^; inc(Dest, 2); + pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); + + {Move to next column} + inc(Src, ColumnIncrement[Pass]); + inc(Trans, ColumnIncrement[Pass]); + inc(Col, ColumnIncrement[Pass]); + until Col >= ImageWidth; +end; + +{Encode interlaced images} +procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream; + var ZLIBStream: TZStreamRec2); +var + CurrentPass, Filter: Byte; + PixelsThisRow: Integer; + CurrentRow : Integer; + Trans, Data: pChar; + CopyProc: procedure(const Pass: Byte; + Src, Dest, Trans: pChar) of object; +begin + CopyProc := nil; {Initialize to avoid warnings} + {Defines the method to copy the data to the buffer depending on} + {the image parameters} + case Header.ColorType of + {R, G, B values} + COLOR_RGB: + case Header.BitDepth of + 8: CopyProc := EncodeInterlacedRGB8; + 16: CopyProc := EncodeInterlacedRGB16; + end; + {Grayscale and palette} + COLOR_PALETTE, COLOR_GRAYSCALE: + case Header.BitDepth of + 1, 4, 8: CopyProc := EncodeInterlacedPalette148; + 16: CopyProc := EncodeInterlacedGrayscale16; + end; + {RGB followed by alpha} + COLOR_RGBALPHA: + case Header.BitDepth of + 8: CopyProc := EncodeInterlacedRGBAlpha8; + 16: CopyProc := EncodeInterlacedRGBAlpha16; + end; + COLOR_GRAYSCALEALPHA: + {Grayscale followed by alpha} + case Header.BitDepth of + 8: CopyProc := EncodeInterlacedGrayscaleAlpha8; + 16: CopyProc := EncodeInterlacedGrayscaleAlpha16; + end; + end {case Header.ColorType}; + + {Compress the image using the seven passes for ADAM 7} + FOR CurrentPass := 0 TO 6 DO + begin + {Calculates the number of pixels and bytes for this pass row} + PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] + + ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass]; + Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType, + Header.BitDepth); + ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes); + + {Get current row index} + CurrentRow := RowStart[CurrentPass]; + {Get a pointer to the current row image data} + Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow * + (ImageHeight - 1 - CurrentRow)); + Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow); + + {Process all the image rows} + if Row_Bytes > 0 then + while CurrentRow < ImageHeight do + begin + {Copy data into buffer} + CopyProc(CurrentPass, Data, @Encode_Buffer[BUFFER][0], Trans); + {Filter data} + Filter := FilterToEncode; + + {Compress data} + IDATZlibWrite(ZLIBStream, @Filter, 1); + IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes); + + {Move to the next row} + inc(CurrentRow, RowIncrement[CurrentPass]); + {Move pointer to the next line} + dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow); + inc(Trans, RowIncrement[CurrentPass] * ImageWidth); + end {while CurrentRow < ImageHeight} + + end {CurrentPass}; + + {Compress and finishes copying the remaining data} + FinishIDATZlib(ZLIBStream); +end; + +{Filters the row to be encoded and returns the best filter} +function TChunkIDAT.FilterToEncode: Byte; +var + Run, LongestRun, ii, jj: Cardinal; + Last, Above, LastAbove: Byte; +begin + {Selecting more filters using the Filters property from TPngObject} + {increases the chances to the file be much smaller, but decreases} + {the performace} + + {This method will creates the same line data using the different} + {filter methods and select the best} + + {Sub-filter} + if pfSub in Owner.Filters then + for ii := 0 to Row_Bytes - 1 do + begin + {There is no previous pixel when it's on the first pixel, so} + {set last as zero when in the first} + if (ii >= Offset) then + last := Encode_Buffer[BUFFER]^[ii - Offset] + else + last := 0; + Encode_Buffer[FILTER_SUB]^[ii] := Encode_Buffer[BUFFER]^[ii] - last; + end; + + {Up filter} + if pfUp in Owner.Filters then + for ii := 0 to Row_Bytes - 1 do + Encode_Buffer[FILTER_UP]^[ii] := Encode_Buffer[BUFFER]^[ii] - + Encode_Buffer[FILTER_NONE]^[ii]; + + {Average filter} + if pfAverage in Owner.Filters then + for ii := 0 to Row_Bytes - 1 do + begin + {Get the previous pixel, if the current pixel is the first, the} + {previous is considered to be 0} + if (ii >= Offset) then + last := Encode_Buffer[BUFFER]^[ii - Offset] + else + last := 0; + {Get the pixel above} + above := Encode_Buffer[FILTER_NONE]^[ii]; + + {Calculates formula to the average pixel} + Encode_Buffer[FILTER_AVERAGE]^[ii] := Encode_Buffer[BUFFER]^[ii] - + (above + last) div 2 ; + end; + + {Paeth filter (the slower)} + if pfPaeth in Owner.Filters then + begin + {Initialize} + last := 0; + lastabove := 0; + for ii := 0 to Row_Bytes - 1 do + begin + {In case this pixel is not the first in the line obtains the} + {previous one and the one above the previous} + if (ii >= Offset) then + begin + last := Encode_Buffer[BUFFER]^[ii - Offset]; + lastabove := Encode_Buffer[FILTER_NONE]^[ii - Offset]; + end; + {Obtains the pixel above} + above := Encode_Buffer[FILTER_NONE]^[ii]; + {Calculate paeth filter for this byte} + Encode_Buffer[FILTER_PAETH]^[ii] := Encode_Buffer[BUFFER]^[ii] - + PaethPredictor(last, above, lastabove); + end; + end; + + {Now calculates the same line using no filter, which is necessary} + {in order to have data to the filters when the next line comes} + CopyMemory(@Encode_Buffer[FILTER_NONE]^[0], + @Encode_Buffer[BUFFER]^[0], Row_Bytes); + + {If only filter none is selected in the filter list, we don't need} + {to proceed and further} + if (Owner.Filters = [pfNone]) or (Owner.Filters = []) then + begin + Result := FILTER_NONE; + exit; + end {if (Owner.Filters = [pfNone...}; + + {Check which filter is the best by checking which has the larger} + {sequence of the same byte, since they are best compressed} + LongestRun := 0; Result := FILTER_NONE; + for ii := FILTER_NONE TO FILTER_PAETH do + {Check if this filter was selected} + if TFilter(ii) in Owner.Filters then + begin + Run := 0; + {Check if it's the only filter} + if Owner.Filters = [TFilter(ii)] then + begin + Result := ii; + exit; + end; + + {Check using a sequence of four bytes} + for jj := 2 to Row_Bytes - 1 do + if (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-1]) or + (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-2]) then + inc(Run); {Count the number of sequences} + + {Check if this one is the best so far} + if (Run > LongestRun) then + begin + Result := ii; + LongestRun := Run; + end {if (Run > LongestRun)}; + + end {if TFilter(ii) in Owner.Filters}; +end; + +{TChunkPLTE implementation} + +{Returns an item in the palette} +function TChunkPLTE.GetPaletteItem(Index: Byte): TRGBQuad; +begin + {Test if item is valid, if not raise error} + if Index > Count - 1 then + Owner.RaiseError(EPNGError, EPNGUnknownPalEntryText) + else + {Returns the item} + Result := Header.BitmapInfo.bmiColors[Index]; +end; + +{Loads the palette chunk from a stream} +function TChunkPLTE.LoadFromStream(Stream: TStream; + const ChunkName: TChunkName; Size: Integer): Boolean; +type + pPalEntry = ^PalEntry; + PalEntry = record + r, g, b: Byte; + end; +var + j : Integer; {For the FOR} + PalColor : pPalEntry; + palEntries: TMaxLogPalette; +begin + {Let ancestor load data and check CRC} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result then exit; + + {This chunk must be divisible by 3 in order to be valid} + if (Size mod 3 <> 0) or (Size div 3 > 256) then + begin + {Raise error} + Result := FALSE; + Owner.RaiseError(EPNGInvalidPalette, EPNGInvalidPaletteText); + exit; + end {if Size mod 3 <> 0}; + + {Fill array with the palette entries} + fCount := Size div 3; + Fillchar(palEntries, sizeof(palEntries), #0); + palEntries.palVersion := $300; + palEntries.palNumEntries := fCount; + PalColor := Data; + FOR j := 0 TO fCount - 1 DO + with palEntries.palPalEntry[j] do + begin + peRed := Owner.GammaTable[PalColor.r]; + peGreen := Owner.GammaTable[PalColor.g]; + peBlue := Owner.GammaTable[PalColor.b]; + peFlags := 0; + {Move to next palette entry} + inc(PalColor); + end; + Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^)); +end; + +{Saves the PLTE chunk to a stream} +function TChunkPLTE.SaveToStream(Stream: TStream): Boolean; +var + J: Integer; + DataPtr: pByte; + BitmapInfo: TMAXBITMAPINFO; + palEntries: TMaxLogPalette; +begin + {Adjust size to hold all the palette items} + if fCount = 0 then fCount := Header.BitmapInfo.bmiHeader.biClrUsed; + ResizeData(fCount * 3); + {Get all the palette entries} + fillchar(palEntries, sizeof(palEntries), #0); + GetPaletteEntries(Header.ImagePalette, 0, 256, palEntries.palPalEntry[0]); + {Copy pointer to data} + DataPtr := fData; + + {Copy palette items} + BitmapInfo := Header.BitmapInfo; + FOR j := 0 TO fCount - 1 DO + with palEntries.palPalEntry[j] do + begin + DataPtr^ := Owner.InverseGamma[peRed]; inc(DataPtr); + DataPtr^ := Owner.InverseGamma[peGreen]; inc(DataPtr); + DataPtr^ := Owner.InverseGamma[peBlue]; inc(DataPtr); + end {with BitmapInfo}; + + {Let ancestor do the rest of the work} + Result := inherited SaveToStream(Stream); +end; + +{Assigns from another PLTE chunk} +procedure TChunkPLTE.Assign(Source: TChunk); +begin + {Copy the number of palette items} + if Source is TChunkPLTE then + fCount := TChunkPLTE(Source).fCount + else + Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); +end; + +{TChunkgAMA implementation} + +{Assigns from another chunk} +procedure TChunkgAMA.Assign(Source: TChunk); +begin + {Copy the gamma value} + if Source is TChunkgAMA then + Gamma := TChunkgAMA(Source).Gamma + else + Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); +end; + +{Gamma chunk being created} +constructor TChunkgAMA.Create(Owner: TPngObject); +begin + {Call ancestor} + inherited Create(Owner); + Gamma := 1; {Initial value} +end; + +{Returns gamma value} +function TChunkgAMA.GetValue: Cardinal; +begin + {Make sure that the size is four bytes} + if DataSize <> 4 then + begin + {Adjust size and returns 1} + ResizeData(4); + Result := 1; + end + {If it's right, read the value} + else Result := Cardinal(ByteSwap(pCardinal(Data)^)) +end; + +function Power(Base, Exponent: Extended): Extended; +begin + if Exponent = 0.0 then + Result := 1.0 {Math rule} + else if (Base = 0) or (Exponent = 0) then Result := 0 + else + Result := Exp(Exponent * Ln(Base)); +end; + +{Loading the chunk from a stream} +function TChunkgAMA.LoadFromStream(Stream: TStream; + const ChunkName: TChunkName; Size: Integer): Boolean; +var + i: Integer; + Value: Cardinal; +begin + {Call ancestor and test if it went ok} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result then exit; + Value := Gamma; + {Build gamma table and inverse table for saving} + if Value <> 0 then + with Owner do + FOR i := 0 TO 255 DO + begin + GammaTable[I] := Round(Power((I / 255), 1 / + (Value / 100000 * 2.2)) * 255); + InverseGamma[Round(Power((I / 255), 1 / + (Value / 100000 * 2.2)) * 255)] := I; + end +end; + +{Sets the gamma value} +procedure TChunkgAMA.SetValue(const Value: Cardinal); +begin + {Make sure that the size is four bytes} + if DataSize <> 4 then ResizeData(4); + {If it's right, set the value} + pCardinal(Data)^ := ByteSwap(Value); +end; + +{TPngObject implementation} + +{Assigns from another object} +procedure TPngObject.Assign(Source: TPersistent); +begin + {Being cleared} + if Source = nil then + ClearChunks + {Assigns contents from another TPNGObject} + else if Source is TPNGObject then + AssignPNG(Source as TPNGObject) + {Copy contents from a TBitmap} + {$IFDEF UseDelphi}else if Source is TBitmap then + with Source as TBitmap do + AssignHandle(Handle, Transparent, + ColorToRGB(TransparentColor)){$ENDIF} + {Unknown source, let ancestor deal with it} + else + inherited; +end; + +{Clear all the chunks in the list} +procedure TPngObject.ClearChunks; +var + i: Integer; +begin + {Initialize gamma} + InitializeGamma(); + {Free all the objects and memory (0 chunks Bug fixed by Noel Sharpe)} + for i := 0 TO Integer(Chunks.Count) - 1 do + TChunk(Chunks.Item[i]).Free; + Chunks.Count := 0; +end; + +{Portable Network Graphics object being created as a blank image} +constructor TPNGObject.CreateBlank(ColorType, BitDepth: Cardinal; + cx, cy: Integer); +var NewIHDR: TChunkIHDR; +begin + {Calls creator} + Create; + {Checks if the parameters are ok} + if not (ColorType in [COLOR_GRAYSCALE, COLOR_RGB, COLOR_PALETTE, + COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA]) or not (BitDepth in + [1,2,4,8, 16]) or ((ColorType = COLOR_PALETTE) and (BitDepth = 16)) or + ((ColorType = COLOR_RGB) and (BitDepth < 8)) then + begin + RaiseError(EPNGInvalidSpec, EInvalidSpec); + exit; + end; + if Bitdepth = 2 then Bitdepth := 4; + + {Add the basis chunks} + InitializeGamma; + BeingCreated := True; + Chunks.Add(TChunkIEND); + NewIHDR := Chunks.Add(TChunkIHDR) as TChunkIHDR; + NewIHDR.IHDRData.ColorType := ColorType; + NewIHDR.IHDRData.BitDepth := BitDepth; + NewIHDR.IHDRData.Width := cx; + NewIHDR.IHDRData.Height := cy; + NewIHDR.PrepareImageData; + if NewIHDR.HasPalette then + TChunkPLTE(Chunks.Add(TChunkPLTE)).fCount := 1 shl BitDepth; + Chunks.Add(TChunkIDAT); + BeingCreated := False; +end; + +{Portable Network Graphics object being created} +constructor TPngObject.Create; +begin + {Let it be created} + inherited Create; + + {Initial properties} + {$IFDEF UseDelphi}fCanvas := TCanvas.Create;{$ENDIF} + fFilters := [pfSub]; + fCompressionLevel := 7; + fInterlaceMethod := imNone; + fMaxIdatSize := High(Word); + {Create chunklist object} + fChunkList := TPngList.Create(Self); + +end; + +{Portable Network Graphics object being destroyed} +destructor TPngObject.Destroy; +begin + {Free object list} + ClearChunks; + fChunkList.Free; + {$IFDEF UseDelphi}if fCanvas <> nil then + fCanvas.Free;{$ENDIF} + + {Call ancestor destroy} + inherited Destroy; +end; + +{Returns linesize and byte offset for pixels} +procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal); +begin + {There must be an Header chunk to calculate size} + if HeaderPresent then + begin + {Calculate number of bytes for each line} + LineSize := BytesForPixels(Header.Width, Header.ColorType, Header.BitDepth); + + {Calculates byte offset} + Case Header.ColorType of + {Grayscale} + COLOR_GRAYSCALE: + If Header.BitDepth = 16 Then + Offset := 2 + Else + Offset := 1 ; + {It always smaller or equal one byte, so it occupes one byte} + COLOR_PALETTE: + offset := 1; + {It might be 3 or 6 bytes} + COLOR_RGB: + offset := 3 * Header.BitDepth Div 8; + {It might be 2 or 4 bytes} + COLOR_GRAYSCALEALPHA: + offset := 2 * Header.BitDepth Div 8; + {4 or 8 bytes} + COLOR_RGBALPHA: + offset := 4 * Header.BitDepth Div 8; + else + Offset := 0; + End ; + + end + else + begin + {In case if there isn't any Header chunk} + Offset := 0; + LineSize := 0; + end; + +end; + +{Returns image height} +function TPngObject.GetHeight: Integer; +begin + {There must be a Header chunk to get the size, otherwise returns 0} + if HeaderPresent then + Result := TChunkIHDR(Chunks.Item[0]).Height + else Result := 0; +end; + +{Returns image width} +function TPngObject.GetWidth: Integer; +begin + {There must be a Header chunk to get the size, otherwise returns 0} + if HeaderPresent then + Result := Header.Width + else Result := 0; +end; + +{Returns if the image is empty} +function TPngObject.GetEmpty: Boolean; +begin + Result := (Chunks.Count = 0); +end; + +{Raises an error} +procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String); +begin + raise ExceptionClass.Create(Text); +end; + +{Set the maximum size for IDAT chunk} +procedure TPngObject.SetMaxIdatSize(const Value: Integer); +begin + {Make sure the size is at least 65535} + if Value < High(Word) then + fMaxIdatSize := High(Word) else fMaxIdatSize := Value; +end; + +{Draws the image using pixel information from TChunkpHYs} +procedure TPNGObject.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); + function Rect(Left, Top, Right, Bottom: Integer): TRect; + begin + Result.Left := Left; + Result.Top := Top; + Result.Right := Right; + Result.Bottom := Bottom; + end; +var + PPMeterY, PPMeterX: Double; + NewSizeX, NewSizeY: Integer; + DC: HDC; +begin + {Get system information} + DC := GetDC(0); + PPMeterY := GetDeviceCaps(DC, LOGPIXELSY) / 0.0254; + PPMeterX := GetDeviceCaps(DC, LOGPIXELSX) / 0.0254; + ReleaseDC(0, DC); + + {In case it does not has pixel information} + if not HasPixelInformation then + Draw(Canvas, Rect(Point.X, Point.Y, Point.X + Width, + Point.Y + Height)) + else + with PixelInformation do + begin + NewSizeX := Trunc(Self.Width / (PPUnitX / PPMeterX)); + NewSizeY := Trunc(Self.Height / (PPUnitY / PPMeterY)); + Draw(Canvas, Rect(Point.X, Point.Y, Point.X + NewSizeX, + Point.Y + NewSizeY)); + end; +end; + +{$IFNDEF UseDelphi} + {Creates a file stream reading from the filename in the parameter and load} + procedure TPngObject.LoadFromFile(const Filename: String); + var + FileStream: TFileStream; + begin + {Test if the file exists} + if not FileExists(Filename) then + begin + {In case it does not exists, raise error} + RaiseError(EPNGNotExists, EPNGNotExistsText); + exit; + end; + + {Creates the file stream to read} + FileStream := TFileStream.Create(Filename, [fsmRead]); + LoadFromStream(FileStream); {Loads the data} + FileStream.Free; {Free file stream} + end; + + {Saves the current png image to a file} + procedure TPngObject.SaveToFile(const Filename: String); + var + FileStream: TFileStream; + begin + {Creates the file stream to write} + FileStream := TFileStream.Create(Filename, [fsmWrite]); + SaveToStream(FileStream); {Saves the data} + FileStream.Free; {Free file stream} + end; + +{$ENDIF} + +{Returns if it has the pixel information chunk} +function TPngObject.HasPixelInformation: Boolean; +begin + Result := (Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs) <> nil; +end; + +{Returns the pixel information chunk} +function TPngObject.GetPixelInformation: TChunkpHYs; +begin + Result := Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs; + if not Assigned(Result) then + begin + Result := Chunks.Add(tChunkpHYs) as tChunkpHYs; + Result.fUnit := utMeter; + end; +end; + +{Returns pointer to the chunk TChunkIHDR which should be the first} +function TPngObject.GetHeader: TChunkIHDR; +begin + {If there is a TChunkIHDR returns it, otherwise returns nil} + if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then + Result := Chunks.Item[0] as TChunkIHDR + else + begin + {No header, throw error message} + RaiseError(EPNGHeaderNotPresent, EPNGHeaderNotPresentText); + Result := nil + end +end; + +{Draws using partial transparency} +procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect); + {Adjust the rectangle structure} + procedure AdjustRect(var Rect: TRect); + var + t: Integer; + begin + if Rect.Right < Rect.Left then + begin + t := Rect.Right; + Rect.Right := Rect.Left; + Rect.Left := t; + end; + if Rect.Bottom < Rect.Top then + begin + t := Rect.Bottom; + Rect.Bottom := Rect.Top; + Rect.Top := t; + end + end; + +type + {Access to pixels} + TPixelLine = Array[Word] of TRGBQuad; + pPixelLine = ^TPixelLine; +const + {Structure used to create the bitmap} + BitmapInfoHeader: TBitmapInfoHeader = + (biSize: sizeof(TBitmapInfoHeader); + biWidth: 100; + biHeight: 100; + biPlanes: 1; + biBitCount: 32; + biCompression: BI_RGB; + biSizeImage: 0; + biXPelsPerMeter: 0; + biYPelsPerMeter: 0; + biClrUsed: 0; + biClrImportant: 0); +var + {Buffer bitmap creation} + BitmapInfo : TBitmapInfo; + BufferDC : HDC; + BufferBits : Pointer; + OldBitmap, + BufferBitmap: HBitmap; + Header: TChunkIHDR; + + {Transparency/palette chunks} + TransparencyChunk: TChunktRNS; + PaletteChunk: TChunkPLTE; + TransValue, PaletteIndex: Byte; + CurBit: Integer; + Data: PByte; + + {Buffer bitmap modification} + BytesPerRowDest, + BytesPerRowSrc, + BytesPerRowAlpha: Integer; + ImageSource, ImageSourceOrg, + AlphaSource : pByteArray; + ImageData : pPixelLine; + i, j, i2, j2 : Integer; + + {For bitmap stretching} + W, H : Cardinal; + Stretch : Boolean; + FactorX, FactorY: Double; +begin + {Prepares the rectangle structure to stretch draw} + if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit; + AdjustRect(Rect); + {Gets the width and height} + W := Rect.Right - Rect.Left; + H := Rect.Bottom - Rect.Top; + Header := Self.Header; {Fast access to header} + Stretch := (W <> Header.Width) or (H <> Header.Height); + if Stretch then FactorX := W / Header.Width else FactorX := 1; + if Stretch then FactorY := H / Header.Height else FactorY := 1; + + {Prepare to create the bitmap} + Fillchar(BitmapInfo, sizeof(BitmapInfo), #0); + BitmapInfoHeader.biWidth := W; + BitmapInfoHeader.biHeight := -Integer(H); + BitmapInfo.bmiHeader := BitmapInfoHeader; + + {Create the bitmap which will receive the background, the applied} + {alpha blending and then will be painted on the background} + BufferDC := CreateCompatibleDC(0); + {In case BufferDC could not be created} + if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText); + BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS, + BufferBits, 0, 0); + {In case buffer bitmap could not be created} + if (BufferBitmap = 0) or (BufferBits = Nil) then + begin + if BufferBitmap <> 0 then DeleteObject(BufferBitmap); + DeleteDC(BufferDC); + RaiseError(EPNGOutMemory, EPNGOutMemoryText); + end; + + {Selects new bitmap and release old bitmap} + OldBitmap := SelectObject(BufferDC, BufferBitmap); + + {Draws the background on the buffer image} + BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY); + + {Obtain number of bytes for each row} + BytesPerRowAlpha := Header.Width; + BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31) + and not 31) div 8; {Number of bytes for each image row in destination} + BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) + + 31) and not 31) div 8; {Number of bytes for each image row in source} + + {Obtains image pointers} + ImageData := BufferBits; + AlphaSource := Header.ImageAlpha; + Longint(ImageSource) := Longint(Header.ImageData) + + Header.BytesPerRow * Longint(Header.Height - 1); + ImageSourceOrg := ImageSource; + + case Header.BitmapInfo.bmiHeader.biBitCount of + {R, G, B images} + 24: + FOR j := 1 TO H DO + begin + {Process all the pixels in this line} + FOR i := 0 TO W - 1 DO + begin + if Stretch then i2 := trunc(i / FactorX) else i2 := i; + {Optmize when we donґt have transparency} + if (AlphaSource[i2] <> 0) then + if (AlphaSource[i2] = 255) then + ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^ + else + with ImageData[i] do + begin + rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed * + (not AlphaSource[i2])) shr 8; + rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] + + rgbGreen * (not AlphaSource[i2])) shr 8; + rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue * + (not AlphaSource[i2])) shr 8; + end; + end; + + {Move pointers} + inc(Longint(ImageData), BytesPerRowDest); + if Stretch then j2 := trunc(j / FactorY) else j2 := j; + Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; + Longint(AlphaSource) := Longint(Header.ImageAlpha) + + BytesPerRowAlpha * j2; + end; + {Palette images with 1 byte for each pixel} + 1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then + FOR j := 1 TO H DO + begin + {Process all the pixels in this line} + FOR i := 0 TO W - 1 DO + with ImageData[i], Header.BitmapInfo do begin + if Stretch then i2 := trunc(i / FactorX) else i2 := i; + rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbRed * (255 - AlphaSource[i2])) shr 8; + rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbGreen * (255 - AlphaSource[i2])) shr 8; + rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbBlue * (255 - AlphaSource[i2])) shr 8; + end; + + {Move pointers} + Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; + if Stretch then j2 := trunc(j / FactorY) else j2 := j; + Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; + Longint(AlphaSource) := Longint(Header.ImageAlpha) + + BytesPerRowAlpha * j2; + end + else {Palette images} + begin + {Obtain pointer to the transparency chunk} + TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS)); + PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE)); + + FOR j := 1 TO H DO + begin + {Process all the pixels in this line} + i := 0; + repeat + CurBit := 0; + if Stretch then i2 := trunc(i / FactorX) else i2 := i; + Data := @ImageSource[i2]; + + repeat + {Obtains the palette index} + case Header.BitDepth of + 1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1; + 2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F; + else PaletteIndex := Data^; + end; + + {Updates the image with the new pixel} + with ImageData[i] do + begin + TransValue := TransparencyChunk.PaletteValues[PaletteIndex]; + rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed * + TransValue + rgbRed * (255 - TransValue)) shr 8; + rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen * + TransValue + rgbGreen * (255 - TransValue)) shr 8; + rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue * + TransValue + rgbBlue * (255 - TransValue)) shr 8; + end; + + {Move to next data} + inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount); + until CurBit >= 8; + {Move to next source data} + //inc(Data); + until i >= Integer(W); + + {Move pointers} + Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; + if Stretch then j2 := trunc(j / FactorY) else j2 := j; + Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; + end + end {Palette images} + end {case Header.BitmapInfo.bmiHeader.biBitCount}; + + {Draws the new bitmap on the foreground} + BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY); + + {Free bitmap} + SelectObject(BufferDC, OldBitmap); + DeleteObject(BufferBitmap); + DeleteDC(BufferDC); +end; + +{Draws the image into a canvas} +procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect); +var + Header: TChunkIHDR; +begin + {Quit in case there is no header, otherwise obtain it} + if Empty then Exit; + Header := Chunks.GetItem(0) as TChunkIHDR; + + {Copy the data to the canvas} + case Self.TransparencyMode of + {$IFDEF PartialTransparentDraw} + ptmPartial: + DrawPartialTrans(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect); + {$ENDIF} + ptmBit: DrawTransparentBitmap(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, + Header.ImageData, Header.BitmapInfo.bmiHeader, + pBitmapInfo(@Header.BitmapInfo), Rect, + {$IFDEF UseDelphi}ColorToRGB({$ENDIF}TransparentColor) + {$IFDEF UseDelphi}){$ENDIF} + else + begin + SetStretchBltMode(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, COLORONCOLOR); + StretchDiBits(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect.Left, + Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0, + Header.Width, Header.Height, Header.ImageData, + pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY) + end + end {case} +end; + +{Characters for the header} +const + PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10); + +{Loads the image from a stream of data} +procedure TPngObject.LoadFromStream(Stream: TStream); +var + Header : Array[0..7] of Char; + HasIDAT : Boolean; + + {Chunks reading} + ChunkCount : Cardinal; + ChunkLength: Cardinal; + ChunkName : TChunkName; +begin + {Initialize before start loading chunks} + ChunkCount := 0; + ClearChunks(); + {Reads the header} + Stream.Read(Header[0], 8); + + {Test if the header matches} + if Header <> PngHeader then + begin + RaiseError(EPNGInvalidFileHeader, EPNGInvalidFileHeaderText); + Exit; + end; + + + HasIDAT := FALSE; + Chunks.Count := 10; + + {Load chunks} + repeat + inc(ChunkCount); {Increment number of chunks} + if Chunks.Count < ChunkCount then {Resize the chunks list if needed} + Chunks.Count := Chunks.Count + 10; + + {Reads chunk length and invert since it is in network order} + {also checks the Read method return, if it returns 0, it} + {means that no bytes was readed, probably because it reached} + {the end of the file} + if Stream.Read(ChunkLength, 4) = 0 then + begin + {In case it found the end of the file here} + Chunks.Count := ChunkCount - 1; + RaiseError(EPNGUnexpectedEnd, EPNGUnexpectedEndText); + end; + + ChunkLength := ByteSwap(ChunkLength); + {Reads chunk name} + Stream.Read(Chunkname, 4); + + {Here we check if the first chunk is the Header which is necessary} + {to the file in order to be a valid Portable Network Graphics image} + if (ChunkCount = 1) and (ChunkName <> 'IHDR') then + begin + Chunks.Count := ChunkCount - 1; + RaiseError(EPNGIHDRNotFirst, EPNGIHDRNotFirstText); + exit; + end; + + {Has a previous IDAT} + if (HasIDAT and (ChunkName = 'IDAT')) or (ChunkName = 'cHRM') then + begin + dec(ChunkCount); + Stream.Seek(ChunkLength + 4, soFromCurrent); + Continue; + end; + {Tell it has an IDAT chunk} + if ChunkName = 'IDAT' then HasIDAT := TRUE; + + {Creates object for this chunk} + Chunks.SetItem(ChunkCount - 1, CreateClassChunk(Self, ChunkName)); + + {Check if the chunk is critical and unknown} + {$IFDEF ErrorOnUnknownCritical} + if (TChunk(Chunks.Item[ChunkCount - 1]).ClassType = TChunk) and + ((Byte(ChunkName[0]) AND $20) = 0) and (ChunkName <> '') then + begin + Chunks.Count := ChunkCount; + RaiseError(EPNGUnknownCriticalChunk, EPNGUnknownCriticalChunkText); + end; + {$ENDIF} + + {Loads it} + try if not TChunk(Chunks.Item[ChunkCount - 1]).LoadFromStream(Stream, + ChunkName, ChunkLength) then break; + except + Chunks.Count := ChunkCount; + raise; + end; + + {Terminates when it reaches the IEND chunk} + until (ChunkName = 'IEND'); + + {Resize the list to the appropriate size} + Chunks.Count := ChunkCount; + + {Check if there is data} + if not HasIDAT then + RaiseError(EPNGNoImageData, EPNGNoImageDataText); +end; + +{Changing height is not supported} +procedure TPngObject.SetHeight(Value: Integer); +begin + Resize(Width, Value) +end; + +{Changing width is not supported} +procedure TPngObject.SetWidth(Value: Integer); +begin + Resize(Value, Height) +end; + +{$IFDEF UseDelphi} +{Saves to clipboard format (thanks to Antoine Pottern)} +procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word; + var AData: THandle; var APalette: HPalette); +begin + with TBitmap.Create do + try + Width := Self.Width; + Height := Self.Height; + Self.Draw(Canvas, Rect(0, 0, Width, Height)); + SaveToClipboardFormat(AFormat, AData, APalette); + finally + Free; + end {try} +end; + +{Loads data from clipboard} +procedure TPngObject.LoadFromClipboardFormat(AFormat: Word; + AData: THandle; APalette: HPalette); +begin + with TBitmap.Create do + try + LoadFromClipboardFormat(AFormat, AData, APalette); + Self.AssignHandle(Handle, False, 0); + finally + Free; + end {try} +end; + +{Returns if the image is transparent} +function TPngObject.GetTransparent: Boolean; +begin + Result := (TransparencyMode <> ptmNone); +end; + +{$ENDIF} + +{Saving the PNG image to a stream of data} +procedure TPngObject.SaveToStream(Stream: TStream); +var + j: Integer; +begin + {Reads the header} + Stream.Write(PNGHeader[0], 8); + {Write each chunk} + FOR j := 0 TO Chunks.Count - 1 DO + Chunks.Item[j].SaveToStream(Stream) +end; + +{Prepares the Header chunk} +procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap); +var + DC: HDC; +begin + {Set width and height} + Header.Width := Info.bmWidth; + Header.Height := abs(Info.bmHeight); + {Set bit depth} + if Info.bmBitsPixel >= 16 then + Header.BitDepth := 8 else Header.BitDepth := Info.bmBitsPixel; + {Set color type} + if Info.bmBitsPixel >= 16 then + Header.ColorType := COLOR_RGB else Header.ColorType := COLOR_PALETTE; + {Set other info} + Header.CompressionMethod := 0; {deflate/inflate} + Header.InterlaceMethod := 0; {no interlace} + + {Prepares bitmap headers to hold data} + Header.PrepareImageData(); + {Copy image data} + DC := CreateCompatibleDC(0); + GetDIBits(DC, Handle, 0, Header.Height, Header.ImageData, + pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS); + + DeleteDC(DC); +end; + +{Loads the image from a resource} +procedure TPngObject.LoadFromResourceName(Instance: HInst; + const Name: String); +var + ResStream: TResourceStream; +begin + {Creates an especial stream to load from the resource} + try ResStream := TResourceStream.Create(Instance, Name, RT_RCDATA); + except RaiseError(EPNGCouldNotLoadResource, EPNGCouldNotLoadResourceText); + exit; end; + + {Loads the png image from the resource} + try + LoadFromStream(ResStream); + finally + ResStream.Free; + end; +end; + +{Loads the png from a resource ID} +procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer); +begin + LoadFromResourceName(Instance, String(ResID)); +end; + +{Assigns this tpngobject to another object} +procedure TPngObject.AssignTo(Dest: TPersistent); +{$IFDEF UseDelphi} + function DetectPixelFormat: TPixelFormat; + begin + with Header do + begin + {Always use 24bits for partial transparency} + if TransparencyMode = ptmPartial then + DetectPixelFormat := pf24bit + else + case BitDepth of + {Only supported by COLOR_PALETTE} + 1: DetectPixelFormat := pf1bit; + 2, 4: DetectPixelFormat := pf4bit; + {8 may be palette or r, g, b values} + 8, 16: + case ColorType of + COLOR_RGB, COLOR_GRAYSCALE: DetectPixelFormat := pf24bit; + COLOR_PALETTE: DetectPixelFormat := pf8bit; + else raise Exception.Create(''); + end {case ColorFormat of} + else raise Exception.Create(''); + end {case BitDepth of} + end {with Header} + end; +var + TRNS: TChunkTRNS; +{$ENDIF} +begin + {If the destination is also a TPNGObject make it assign} + {this one} + if Dest is TPNGObject then + TPNGObject(Dest).AssignPNG(Self) + {$IFDEF UseDelphi} + {In case the destination is a bitmap} + else if (Dest is TBitmap) and HeaderPresent then + begin + {Copies the handle using CopyImage API} + TBitmap(Dest).PixelFormat := DetectPixelFormat; + TBitmap(Dest).Width := Width; + TBitmap(Dest).Height := Height; + TBitmap(Dest).Canvas.Draw(0, 0, Self); + + {Copy transparency mode} + if (TransparencyMode = ptmBit) then + begin + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + TBitmap(Dest).TransparentColor := TRNS.TransparentColor; + TBitmap(Dest).Transparent := True + end {if (TransparencyMode = ptmBit)} + + end + else + {Unknown destination kind} + inherited AssignTo(Dest); + {$ENDIF} +end; + +{Assigns from a bitmap object} +procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean; + TransparentColor: ColorRef); +var + BitmapInfo: Windows.TBitmap; + {Chunks} + Header: TChunkIHDR; + PLTE: TChunkPLTE; + IDAT: TChunkIDAT; + IEND: TChunkIEND; + TRNS: TChunkTRNS; + i: Integer; + palEntries : TMaxLogPalette; +begin + {Obtain bitmap info} + GetObject(Handle, SizeOf(BitmapInfo), @BitmapInfo); + + {Clear old chunks and prepare} + ClearChunks(); + + {Create the chunks} + Header := TChunkIHDR.Create(Self); + + {This method will fill the Header chunk with bitmap information} + {and copy the image data} + BuildHeader(Header, Handle, @BitmapInfo); + + if Header.HasPalette then PLTE := TChunkPLTE.Create(Self) else PLTE := nil; + if Transparent then TRNS := TChunkTRNS.Create(Self) else TRNS := nil; + IDAT := TChunkIDAT.Create(Self); + IEND := TChunkIEND.Create(Self); + + {Add chunks} + TPNGPointerList(Chunks).Add(Header); + if Header.HasPalette then TPNGPointerList(Chunks).Add(PLTE); + if Transparent then TPNGPointerList(Chunks).Add(TRNS); + TPNGPointerList(Chunks).Add(IDAT); + TPNGPointerList(Chunks).Add(IEND); + + {In case there is a image data, set the PLTE chunk fCount variable} + {to the actual number of palette colors which is 2^(Bits for each pixel)} + if Header.HasPalette then + begin + PLTE.fCount := 1 shl BitmapInfo.bmBitsPixel; + + {Create and set palette} + fillchar(palEntries, sizeof(palEntries), 0); + palEntries.palVersion := $300; + palEntries.palNumEntries := 1 shl BitmapInfo.bmBitsPixel; + for i := 0 to palEntries.palNumEntries - 1 do + begin + palEntries.palPalEntry[i].peRed := Header.BitmapInfo.bmiColors[i].rgbRed; + palEntries.palPalEntry[i].peGreen := Header.BitmapInfo.bmiColors[i].rgbGreen; + palEntries.palPalEntry[i].peBlue := Header.BitmapInfo.bmiColors[i].rgbBlue; + end; + DoSetPalette(CreatePalette(pLogPalette(@palEntries)^), false); + end; + + {In case it is a transparent bitmap, prepares it} + if Transparent then TRNS.TransparentColor := TransparentColor; +end; + +{Assigns from another PNG} +procedure TPngObject.AssignPNG(Source: TPNGObject); +var + J: Integer; +begin + {Copy properties} + InterlaceMethod := Source.InterlaceMethod; + MaxIdatSize := Source.MaxIdatSize; + CompressionLevel := Source.CompressionLevel; + Filters := Source.Filters; + + {Clear old chunks and prepare} + ClearChunks(); + Chunks.Count := Source.Chunks.Count; + {Create chunks and makes a copy from the source} + FOR J := 0 TO Chunks.Count - 1 DO + with Source.Chunks do + begin + Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self)); + TChunk(Chunks.Item[J]).Assign(TChunk(Item[J])); + end {with}; +end; + +{Returns a alpha data scanline} +function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray; +begin + with Header do + if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then + Longint(Result) := Longint(ImageAlpha) + (LineIndex * Longint(Width)) + else Result := nil; {In case the image does not use alpha information} +end; + +{$IFDEF Store16bits} +{Returns a png data extra scanline} +function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer; +begin + with Header do + Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) * + BytesPerRow)) - (LineIndex * BytesPerRow); +end; +{$ENDIF} + +{Returns a png data scanline} +function TPngObject.GetScanline(const LineIndex: Integer): Pointer; +begin + with Header do + Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) * + BytesPerRow)) - (LineIndex * BytesPerRow); +end; + +{Initialize gamma table} +procedure TPngObject.InitializeGamma; +var + i: Integer; +begin + {Build gamma table as if there was no gamma} + FOR i := 0 to 255 do + begin + GammaTable[i] := i; + InverseGamma[i] := i; + end {for i} +end; + +{Returns the transparency mode used by this png} +function TPngObject.GetTransparencyMode: TPNGTransparencyMode; +var + TRNS: TChunkTRNS; +begin + with Header do + begin + Result := ptmNone; {Default result} + {Gets the TRNS chunk pointer} + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + + {Test depending on the color type} + case ColorType of + {This modes are always partial} + COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Result := ptmPartial; + {This modes support bit transparency} + COLOR_RGB, COLOR_GRAYSCALE: if TRNS <> nil then Result := ptmBit; + {Supports booth translucid and bit} + COLOR_PALETTE: + {A TRNS chunk must be present, otherwise it won't support transparency} + if TRNS <> nil then + if TRNS.BitTransparency then + Result := ptmBit else Result := ptmPartial + end {case} + + end {with Header} +end; + +{Add a text chunk} +procedure TPngObject.AddtEXt(const Keyword, Text: String); +var + TextChunk: TChunkTEXT; +begin + TextChunk := Chunks.Add(TChunkText) as TChunkTEXT; + TextChunk.Keyword := Keyword; + TextChunk.Text := Text; +end; + +{Add a text chunk} +procedure TPngObject.AddzTXt(const Keyword, Text: String); +var + TextChunk: TChunkzTXt; +begin + TextChunk := Chunks.Add(TChunkzTXt) as TChunkzTXt; + TextChunk.Keyword := Keyword; + TextChunk.Text := Text; +end; + +{Removes the image transparency} +procedure TPngObject.RemoveTransparency; +var + TRNS: TChunkTRNS; +begin + {Removes depending on the color type} + with Header do + case ColorType of + {Palette uses the TChunktRNS to store alpha} + COLOR_PALETTE: + begin + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + if TRNS <> nil then Chunks.RemoveChunk(TRNS) + end; + {Png allocates different memory space to hold alpha information} + {for these types} + COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA: + begin + {Transform into the appropriate color type} + if ColorType = COLOR_GRAYSCALEALPHA then + ColorType := COLOR_GRAYSCALE + else ColorType := COLOR_RGB; + {Free the pointer data} + if ImageAlpha <> nil then FreeMem(ImageAlpha); + ImageAlpha := nil + end + end +end; + +{Generates alpha information} +procedure TPngObject.CreateAlpha; +var + TRNS: TChunkTRNS; +begin + {Generates depending on the color type} + with Header do + case ColorType of + {Png allocates different memory space to hold alpha information} + {for these types} + COLOR_GRAYSCALE, COLOR_RGB: + begin + {Transform into the appropriate color type} + if ColorType = COLOR_GRAYSCALE then + ColorType := COLOR_GRAYSCALEALPHA + else ColorType := COLOR_RGBALPHA; + {Allocates memory to hold alpha information} + GetMem(ImageAlpha, Integer(Width) * Integer(Height)); + FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #255); + end; + {Palette uses the TChunktRNS to store alpha} + COLOR_PALETTE: + begin + {Gets/creates TRNS chunk} + if Chunks.ItemFromClass(TChunkTRNS) = nil then + TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS + else + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + + {Prepares the TRNS chunk} + with TRNS do + begin + ResizeData(256); + Fillchar(PaletteValues[0], 256, 255); + fDataSize := 1 shl Header.BitDepth; + fBitTransparency := False + end {with Chunks.Add}; + end; + end {case Header.ColorType} + +end; + +{Returns transparent color} +function TPngObject.GetTransparentColor: TColor; +var + TRNS: TChunkTRNS; +begin + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + {Reads the transparency chunk to get this info} + if Assigned(TRNS) then Result := TRNS.TransparentColor + else Result := 0 +end; + +{$OPTIMIZATION OFF} +procedure TPngObject.SetTransparentColor(const Value: TColor); +var + TRNS: TChunkTRNS; +begin + if HeaderPresent then + {Tests the ColorType} + case Header.ColorType of + {Not allowed for this modes} + COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Self.RaiseError( + EPNGCannotChangeTransparent, EPNGCannotChangeTransparentText); + {Allowed} + COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE: + begin + TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; + if not Assigned(TRNS) then TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS; + + {Sets the transparency value from TRNS chunk} + TRNS.TransparentColor := {$IFDEF UseDelphi}ColorToRGB({$ENDIF}Value + {$IFDEF UseDelphi}){$ENDIF} + end {COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE)} + end {case} +end; + +{Returns if header is present} +function TPngObject.HeaderPresent: Boolean; +begin + Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR)) +end; + +{Returns pixel for png using palette and grayscale} +function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor; +var + ByteData: Byte; + DataDepth: Byte; +begin + with png, Header do + begin + {Make sure the bitdepth is not greater than 8} + DataDepth := BitDepth; + if DataDepth > 8 then DataDepth := 8; + {Obtains the byte containing this pixel} + ByteData := pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)]; + {Moves the bits we need to the right} + ByteData := (ByteData shr ((8 - DataDepth) - + (X mod (8 div DataDepth)) * DataDepth)); + {Discard the unwanted pixels} + ByteData:= ByteData and ($FF shr (8 - DataDepth)); + + {For palette mode map the palette entry and for grayscale convert and + returns the intensity} + case ColorType of + COLOR_PALETTE: + with TChunkPLTE(png.Chunks.ItemFromClass(TChunkPLTE)).Item[ByteData] do + Result := rgb(GammaTable[rgbRed], GammaTable[rgbGreen], + GammaTable[rgbBlue]); + COLOR_GRAYSCALE: + begin + if BitDepth = 1 + then ByteData := GammaTable[Byte(ByteData * 255)] + else ByteData := GammaTable[Byte(ByteData * ((1 shl DataDepth) + 1))]; + Result := rgb(ByteData, ByteData, ByteData); + end; + else Result := 0; + end {case}; + end {with} +end; + +{In case vcl units are not being used} +{$IFNDEF UseDelphi} +function ColorToRGB(const Color: TColor): COLORREF; +begin + Result := Color +end; +{$ENDIF} + +{Sets a pixel for grayscale and palette pngs} +procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer; + const Value: TColor); +const + ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF); +var + ByteData: pByte; + DataDepth: Byte; + ValEntry: Byte; +begin + with png.Header do + begin + {Map into a palette entry} + ValEntry := GetNearestPaletteIndex(Png.Palette, ColorToRGB(Value)); + + {16 bits grayscale extra bits are discarted} + DataDepth := BitDepth; + if DataDepth > 8 then DataDepth := 8; + {Gets a pointer to the byte we intend to change} + ByteData := @pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)]; + {Clears the old pixel data} + ByteData^ := ByteData^ and not (ClearFlag[DataDepth] shl ((8 - DataDepth) - + (X mod (8 div DataDepth)) * DataDepth)); + + {Setting the new pixel} + ByteData^ := ByteData^ or (ValEntry shl ((8 - DataDepth) - + (X mod (8 div DataDepth)) * DataDepth)); + end {with png.Header} +end; + +{Returns pixel when png uses RGB} +function GetRGBLinePixel(const png: TPngObject; + const X, Y: Integer): TColor; +begin + with pRGBLine(png.Scanline[Y])^[X] do + Result := RGB(rgbtRed, rgbtGreen, rgbtBlue) +end; + +{Sets pixel when png uses RGB} +procedure SetRGBLinePixel(const png: TPngObject; + const X, Y: Integer; Value: TColor); +begin + with pRGBLine(png.Scanline[Y])^[X] do + begin + rgbtRed := GetRValue(Value); + rgbtGreen := GetGValue(Value); + rgbtBlue := GetBValue(Value) + end +end; + +{Returns pixel when png uses grayscale} +function GetGrayLinePixel(const png: TPngObject; + const X, Y: Integer): TColor; +var + B: Byte; +begin + B := PByteArray(png.Scanline[Y])^[X]; + Result := RGB(B, B, B); +end; + +{Sets pixel when png uses grayscale} +procedure SetGrayLinePixel(const png: TPngObject; + const X, Y: Integer; Value: TColor); +begin + PByteArray(png.Scanline[Y])^[X] := GetRValue(Value); +end; + +{Resizes the PNG image} +procedure TPngObject.Resize(const CX, CY: Integer); + function Min(const A, B: Integer): Integer; + begin + if A < B then Result := A else Result := B; + end; +var + Header: TChunkIHDR; + Line, NewBytesPerRow: Integer; + NewHandle: HBitmap; + NewDC: HDC; + NewImageData: Pointer; + NewImageAlpha: Pointer; + NewImageExtra: Pointer; +begin + if (CX > 0) and (CY > 0) then + begin + {Gets some actual information} + Header := Self.Header; + + {Creates the new image} + NewDC := CreateCompatibleDC(Header.ImageDC); + Header.BitmapInfo.bmiHeader.biWidth := cx; + Header.BitmapInfo.bmiHeader.biHeight := cy; + NewHandle := CreateDIBSection(NewDC, pBitmapInfo(@Header.BitmapInfo)^, + DIB_RGB_COLORS, NewImageData, 0, 0); + SelectObject(NewDC, NewHandle); + {$IFDEF UseDelphi}Canvas.Handle := NewDC;{$ENDIF} + NewBytesPerRow := (((Header.BitmapInfo.bmiHeader.biBitCount * cx) + 31) + and not 31) div 8; + + {Copies the image data} + for Line := 0 to Min(CY - 1, Height - 1) do + CopyMemory(Ptr(Longint(NewImageData) + (Longint(CY) - 1) * + NewBytesPerRow - (Line * NewBytesPerRow)), Scanline[Line], + Min(NewBytesPerRow, Header.BytesPerRow)); + + {Build array for alpha information, if necessary} + if (Header.ColorType = COLOR_RGBALPHA) or + (Header.ColorType = COLOR_GRAYSCALEALPHA) then + begin + GetMem(NewImageAlpha, CX * CY); + Fillchar(NewImageAlpha^, CX * CY, 255); + for Line := 0 to Min(CY - 1, Height - 1) do + CopyMemory(Ptr(Longint(NewImageAlpha) + (Line * CX)), + AlphaScanline[Line], Min(CX, Width)); + FreeMem(Header.ImageAlpha); + Header.ImageAlpha := NewImageAlpha; + end; + + {$IFDEF Store16bits} + if (Header.BitDepth = 16) then + begin + GetMem(NewImageExtra, CX * CY); + Fillchar(NewImageExtra^, CX * CY, 0); + for Line := 0 to Min(CY - 1, Height - 1) do + CopyMemory(Ptr(Longint(NewImageExtra) + (Line * CX)), + ExtraScanline[Line], Min(CX, Width)); + FreeMem(Header.ExtraImageData); + Header.ExtraImageData := NewImageExtra; + end; + {$ENDIF} + + {Deletes the old image} + DeleteObject(Header.ImageHandle); + DeleteDC(Header.ImageDC); + + {Prepares the header to get the new image} + Header.BytesPerRow := NewBytesPerRow; + Header.IHDRData.Width := CX; + Header.IHDRData.Height := CY; + Header.ImageData := NewImageData; + + {Replaces with the new image} + Header.ImageHandle := NewHandle; + Header.ImageDC := NewDC; + end + else + {The new size provided is invalid} + RaiseError(EPNGInvalidNewSize, EInvalidNewSize) + +end; + +{Sets a pixel} +procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor); +begin + if ((X >= 0) and (X <= Width - 1)) and + ((Y >= 0) and (Y <= Height - 1)) then + with Header do + begin + if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then + SetByteArrayPixel(Self, X, Y, Value) + else if ColorType in [COLOR_GRAYSCALEALPHA] then + SetGrayLinePixel(Self, X, Y, Value) + else + SetRGBLinePixel(Self, X, Y, Value) + end {with} +end; + + +{Returns a pixel} +function TPngObject.GetPixels(const X, Y: Integer): TColor; +begin + if ((X >= 0) and (X <= Width - 1)) and + ((Y >= 0) and (Y <= Height - 1)) then + with Header do + begin + if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then + Result := GetByteArrayPixel(Self, X, Y) + else if ColorType in [COLOR_GRAYSCALEALPHA] then + Result := GetGrayLinePixel(Self, X, Y) + else + Result := GetRGBLinePixel(Self, X, Y) + end {with} + else Result := 0 +end; + +{Returns the image palette} +function TPngObject.GetPalette: HPALETTE; +begin + Result := Header.ImagePalette; +end; + +{Assigns from another TChunk} +procedure TChunkpHYs.Assign(Source: TChunk); +begin + fPPUnitY := TChunkpHYs(Source).fPPUnitY; + fPPUnitX := TChunkpHYs(Source).fPPUnitX; + fUnit := TChunkpHYs(Source).fUnit; +end; + +{Loads the chunk from a stream} +function TChunkpHYs.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; + Size: Integer): Boolean; +begin + {Let ancestor load the data} + Result := inherited LoadFromStream(Stream, ChunkName, Size); + if not Result or (Size <> 9) then exit; {Size must be 9} + + {Reads data} + fPPUnitX := ByteSwap(pCardinal(Longint(Data))^); + fPPUnitY := ByteSwap(pCardinal(Longint(Data) + 4)^); + fUnit := pUnitType(Longint(Data) + 8)^; +end; + +{Saves the chunk to a stream} +function TChunkpHYs.SaveToStream(Stream: TStream): Boolean; +begin + {Update data} + ResizeData(9); {Make sure the size is 9} + pCardinal(Data)^ := ByteSwap(fPPUnitX); + pCardinal(Longint(Data) + 4)^ := ByteSwap(fPPUnitY); + pUnitType(Longint(Data) + 8)^ := fUnit; + + {Let inherited save data} + Result := inherited SaveToStream(Stream); +end; + +procedure TPngObject.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); +begin + if (Header.HasPalette) then + begin + {Update the palette entries} + if UpdateColors then + Header.PaletteToDIB(Value); + + {Resize the new palette} + SelectPalette(Header.ImageDC, Value, False); + RealizePalette(Header.ImageDC); + + {Replaces} + DeleteObject(Header.ImagePalette); + Header.ImagePalette := Value; + end +end; + +{Set palette based on a windows palette handle} +procedure TPngObject.SetPalette(Value: HPALETTE); +begin + DoSetPalette(Value, true); +end; + +{Returns the library version} +function TPNGObject.GetLibraryVersion: String; +begin + Result := LibraryVersion +end; + +initialization + {Initialize} + ChunkClasses := nil; + {crc table has not being computed yet} + crc_table_computed := FALSE; + {Register the necessary chunks for png} + RegisterCommonChunks; + {Registers TPNGObject to use with TPicture} + {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} + if GraphicExtension(TPNGObject) = '' then + TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject); + {$ENDIF}{$ENDIF} +finalization + {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} + TPicture.UnregisterGraphicClass(TPNGObject); + {$ENDIF}{$ENDIF} + {Free chunk classes} + FreeChunkClassList; +end. + + + +// diff --git a/official/4.8.11/Source/frxpnglang.pas b/official/4.8.11/Source/frxpnglang.pas new file mode 100644 index 0000000..f47f955 --- /dev/null +++ b/official/4.8.11/Source/frxpnglang.pas @@ -0,0 +1,358 @@ +{Portable Network Graphics Delphi Language Info (24 July 2002)} + +{Feel free to change the text bellow to adapt to your language} +{Also if you have a translation to other languages and want to} +{share it, send me: gubadaud@terra.com.br } +unit frxpnglang; + +interface + +{$DEFINE English} +{.$DEFINE Polish} +{.$DEFINE Portuguese} +{.$DEFINE German} +{.$DEFINE French} +{.$DEFINE Slovenian} + +{Language strings for english} +resourcestring + {$IFDEF Polish} + EPngInvalidCRCText = 'Ten obraz "Portable Network Graphics" jest nieprawidіowy ' + + 'poniewaї zawiera on nieprawidіowe czкњci danych (bі№d crc)'; + EPNGInvalidIHDRText = 'Obraz "Portable Network Graphics" nie moїe zostaж ' + + 'wgrany poniewaї jedna z czкњci danych (ihdr) moїe byж uszkodzona'; + EPNGMissingMultipleIDATText = 'Obraz "Portable Network Graphics" jest ' + + 'nieprawidіowy poniewaї brakuje w nim czкњci obrazu.'; + EPNGZLIBErrorText = 'Nie moїna zdekompresowaж obrazu poniewaї zawiera ' + + 'bікdnie zkompresowane dane.'#13#10 + ' Opis bікdu: '; + EPNGInvalidPaletteText = 'Obraz "Portable Network Graphics" zawiera ' + + 'niewіaњciw№ paletк.'; + EPNGInvalidFileHeaderText = 'Plik ktуry jest odczytywany jest nieprawidіowym '+ + 'obrazem "Portable Network Graphics" poniewaї zawiera nieprawidіowy nagіуwek.' + + ' Plik moїк byж uszkodzony, sprуbuj pobraж go ponownie.'; + EPNGIHDRNotFirstText = 'Obraz "Portable Network Graphics" nie jest ' + + 'obsіugiwany lub moїe byж niewіaњciwy.'#13#10 + '(stopka IHDR nie jest pierwsza)'; + EPNGNotExistsText = 'Plik png nie moїe zostaж wgrany poniewaї nie ' + + 'istnieje.'; + EPNGSizeExceedsText = 'Obraz "Portable Network Graphics" nie jest ' + + 'obsіugiwany poniewaї jego szerokoњж lub wysokoњж przekracza maksimum ' + + 'rozmiaru, ktуry wynosi 65535 pikseli dіugoњci.'; + EPNGUnknownPalEntryText = 'Nie znaleziono wpisуw palety.'; + EPNGMissingPaletteText = 'Obraz "Portable Network Graphics" nie moїe zostaж ' + + 'wgrany poniewaї uїywa tabeli kolorуw ktуrej brakuje.'; + EPNGUnknownCriticalChunkText = 'Obraz "Portable Network Graphics" ' + + 'zawiera nieznan№ krytyczn№ czкњж ktуra nie moїe zostaж odkodowana.'; + EPNGUnknownCompressionText = 'Obraz "Portable Network Graphics" jest ' + + 'skompresowany nieznanym schemat ktуry nie moїe zostaж odszyfrowany.'; + EPNGUnknownInterlaceText = 'Obraz "Portable Network Graphics" uїywa ' + + 'nie znany schamat przeplatania ktуry nie moїe zostaж odszyfrowany.'; + EPNGCannotAssignChunkText = 'Stopka mysi byж kompatybilna aby zostaіa wyznaczona.'; + EPNGUnexpectedEndText = 'Obraz "Portable Network Graphics" jest nieprawidіowy ' + + 'poniewaї dekoder znalazі niespodziewanie koniec pliku.'; + EPNGNoImageDataText = 'Obraz "Portable Network Graphics" nie zawiera' + + 'danych.'; + EPNGCannotAddChunkText = 'Program prуbuje dodaж krytyczn№ ' + + 'stopkк do aktualnego obrazu co jest niedozwolone.'; + EPNGCannotAddInvalidImageText = 'Nie moїna dodaж nowej stopki ' + + 'poniewaї aktualny obraz jest nieprawidіowy.'; + EPNGCouldNotLoadResourceText = 'Obraz png nie moїe zostaж zaіadowany z' + + 'zasobуw o podanym ID.'; + EPNGOutMemoryText = 'Niektуre operacje nie mog№ zostaж zrealizowane poniewaї ' + + 'systemowi brakuje zasobуw. Zamknij kilka okien i sprуbuj ponownie.'; + EPNGCannotChangeTransparentText = 'Ustawienie bitu przezroczystego koloru jest ' + + 'zabronione dla obrazуw png zawieraj№cych wartoњж alpha dla kaїdego piksela ' + + '(COLOR_RGBALPHA i COLOR_GRAYSCALEALPHA)'; + EPNGHeaderNotPresentText = 'Ta operacja jest niedozwolona poniewaї ' + + 'aktualny obraz zawiera niewіaњciwy nagіуwek.'; + EInvalidNewSize = 'The new size provided for image resizing is invalid.'; + EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + + 'because invalid image type parameters have being provided.'; + {$ENDIF} + + {$IFDEF English} + EPngInvalidCRCText = 'This "Portable Network Graphics" image is not valid ' + + 'because it contains invalid pieces of data (crc error)'; + EPNGInvalidIHDRText = 'The "Portable Network Graphics" image could not be ' + + 'loaded because one of its main piece of data (ihdr) might be corrupted'; + EPNGMissingMultipleIDATText = 'This "Portable Network Graphics" image is ' + + 'invalid because it has missing image parts.'; + EPNGZLIBErrorText = 'Could not decompress the image because it contains ' + + 'invalid compressed data.'#13#10 + ' Description: '; + EPNGInvalidPaletteText = 'The "Portable Network Graphics" image contains ' + + 'an invalid palette.'; + EPNGInvalidFileHeaderText = 'The file being readed is not a valid '+ + '"Portable Network Graphics" image because it contains an invalid header.' + + ' This file may be corruped, try obtaining it again.'; + EPNGIHDRNotFirstText = 'This "Portable Network Graphics" image is not ' + + 'supported or it might be invalid.'#13#10 + '(IHDR chunk is not the first)'; + EPNGNotExistsText = 'The png file could not be loaded because it does not ' + + 'exists.'; + EPNGSizeExceedsText = 'This "Portable Network Graphics" image is not ' + + 'supported because either it''s width or height exceeds the maximum ' + + 'size, which is 65535 pixels length.'; + EPNGUnknownPalEntryText = 'There is no such palette entry.'; + EPNGMissingPaletteText = 'This "Portable Network Graphics" could not be ' + + 'loaded because it uses a color table which is missing.'; + EPNGUnknownCriticalChunkText = 'This "Portable Network Graphics" image ' + + 'contains an unknown critical part which could not be decoded.'; + EPNGUnknownCompressionText = 'This "Portable Network Graphics" image is ' + + 'encoded with an unknown compression scheme which could not be decoded.'; + EPNGUnknownInterlaceText = 'This "Portable Network Graphics" image uses ' + + 'an unknown interlace scheme which could not be decoded.'; + EPNGCannotAssignChunkText = 'The chunks must be compatible to be assigned.'; + EPNGUnexpectedEndText = 'This "Portable Network Graphics" image is invalid ' + + 'because the decoder found an unexpected end of the file.'; + EPNGNoImageDataText = 'This "Portable Network Graphics" image contains no ' + + 'data.'; + EPNGCannotAddChunkText = 'The program tried to add a existent critical ' + + 'chunk to the current image which is not allowed.'; + EPNGCannotAddInvalidImageText = 'It''s not allowed to add a new chunk ' + + 'because the current image is invalid.'; + EPNGCouldNotLoadResourceText = 'The png image could not be loaded from the ' + + 'resource ID.'; + EPNGOutMemoryText = 'Some operation could not be performed because the ' + + 'system is out of resources. Close some windows and try again.'; + EPNGCannotChangeTransparentText = 'Setting bit transparency color is not ' + + 'allowed for png images containing alpha value for each pixel ' + + '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; + EPNGHeaderNotPresentText = 'This operation is not valid because the ' + + 'current image contains no valid header.'; + EInvalidNewSize = 'The new size provided for image resizing is invalid.'; + EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + + 'because invalid image type parameters have being provided.'; + {$ENDIF} + {$IFDEF Portuguese} + EPngInvalidCRCText = 'Essa imagem "Portable Network Graphics" nгo й vбlida ' + + 'porque contйm chunks invбlidos de dados (erro crc)'; + EPNGInvalidIHDRText = 'A imagem "Portable Network Graphics" nгo pode ser ' + + 'carregada porque um dos seus chunks importantes (ihdr) pode estar '+ + 'invбlido'; + EPNGMissingMultipleIDATText = 'Essa imagem "Portable Network Graphics" й ' + + 'invбlida porque tem chunks de dados faltando.'; + EPNGZLIBErrorText = 'Nгo foi possнvel descomprimir os dados da imagem ' + + 'porque ela contйm dados invбlidos.'#13#10 + ' Descriзгo: '; + EPNGInvalidPaletteText = 'A imagem "Portable Network Graphics" contйm ' + + 'uma paleta invбlida.'; + EPNGInvalidFileHeaderText = 'O arquivo sendo lido nгo й uma imagem '+ + '"Portable Network Graphics" vбlida porque contйm um cabeзalho invбlido.' + + ' O arquivo pode estar corrompida, tente obter ela novamente.'; + EPNGIHDRNotFirstText = 'Essa imagem "Portable Network Graphics" nгo й ' + + 'suportada ou pode ser invбlida.'#13#10 + '(O chunk IHDR nгo й o ' + + 'primeiro)'; + EPNGNotExistsText = 'A imagem png nгo pode ser carregada porque ela nгo ' + + 'existe.'; + EPNGSizeExceedsText = 'Essa imagem "Portable Network Graphics" nгo й ' + + 'suportada porque a largura ou a altura ultrapassam o tamanho mбximo, ' + + 'que й de 65535 pixels de diвmetro.'; + EPNGUnknownPalEntryText = 'Nгo existe essa entrada de paleta.'; + EPNGMissingPaletteText = 'Essa imagem "Portable Network Graphics" nгo pode ' + + 'ser carregada porque usa uma paleta que estб faltando.'; + EPNGUnknownCriticalChunkText = 'Essa imagem "Portable Network Graphics" ' + + 'contйm um chunk crнtico desconheзido que nгo pode ser decodificado.'; + EPNGUnknownCompressionText = 'Essa imagem "Portable Network Graphics" estб ' + + 'codificada com um esquema de compressгo desconheзido e nгo pode ser ' + + 'decodificada.'; + EPNGUnknownInterlaceText = 'Essa imagem "Portable Network Graphics" usa um ' + + 'um esquema de interlace que nгo pode ser decodificado.'; + EPNGCannotAssignChunkText = 'Os chunk devem ser compatнveis para serem ' + + 'copiados.'; + EPNGUnexpectedEndText = 'Essa imagem "Portable Network Graphics" й ' + + 'invбlida porque o decodificador encontrou um fim inesperado.'; + EPNGNoImageDataText = 'Essa imagem "Portable Network Graphics" nгo contйm ' + + 'dados.'; + EPNGCannotAddChunkText = 'O programa tentou adicionar um chunk crнtico ' + + 'jб existente para a imagem atual, oque nгo й permitido.'; + EPNGCannotAddInvalidImageText = 'Nгo й permitido adicionar um chunk novo ' + + 'porque a imagem atual й invбlida.'; + EPNGCouldNotLoadResourceText = 'A imagem png nгo pode ser carregada apartir' + + ' do resource.'; + EPNGOutMemoryText = 'Uma operaзгo nгo pode ser completada porque o sistema ' + + 'estб sem recursos. Fecha algumas janelas e tente novamente.'; + EPNGCannotChangeTransparentText = 'Definir transparкncia booleana nгo й ' + + 'permitido para imagens png contendo informaзгo alpha para cada pixel ' + + '(COLOR_RGBALPHA e COLOR_GRAYSCALEALPHA)'; + EPNGHeaderNotPresentText = 'Essa operaзгo nгo й vбlida porque a ' + + 'imagem atual nгo contйm um cabeзalho vбlido.'; + EInvalidNewSize = 'O novo tamanho fornecido para o redimensionamento de ' + + 'imagem й invбlido.'; + EInvalidSpec = 'A imagem "Portable Network Graphics" nгo pode ser criada ' + + 'porque parвmetros de tipo de imagem invбlidos foram usados.'; + {$ENDIF} + {Language strings for German} + {$IFDEF German} + EPngInvalidCRCText = 'Dieses "Portable Network Graphics" Bild ist ' + + 'ungьltig, weil Teile der Daten fehlerhaft sind (CRC-Fehler)'; + EPNGInvalidIHDRText = 'Dieses "Portable Network Graphics" Bild konnte ' + + 'nicht geladen werden, weil wahrscheinlich einer der Hauptdatenbreiche ' + + '(IHDR) beschдdigt ist'; + EPNGMissingMultipleIDATText = 'Dieses "Portable Network Graphics" Bild ' + + 'ist ungьltig, weil Grafikdaten fehlen.'; + EPNGZLIBErrorText = 'Die Grafik konnte nicht entpackt werden, weil Teile der ' + + 'komprimierten Daten fehlerhaft sind.'#13#10 + ' Beschreibung: '; + EPNGInvalidPaletteText = 'Das "Portable Network Graphics" Bild enthдlt ' + + 'eine ungьltige Palette.'; + EPNGInvalidFileHeaderText = 'Die Datei, die gelesen wird, ist kein ' + + 'gьltiges "Portable Network Graphics" Bild, da es keinen gьltigen ' + + 'Header enthдlt. Die Datei kцnnte beschдdigt sein, versuchen Sie, ' + + 'eine neue Kopie zu bekommen.'; + EPNGIHDRNotFirstText = 'Dieses "Portable Network Graphics" Bild wird ' + + 'nicht unterstьtzt oder ist ungьltig.'#13#10 + + '(Der IHDR-Abschnitt ist nicht der erste Abschnitt in der Datei).'; + EPNGNotExistsText = 'Die PNG Datei konnte nicht geladen werden, da sie ' + + 'nicht existiert.'; + EPNGSizeExceedsText = 'Dieses "Portable Network Graphics" Bild wird nicht ' + + 'unterstьtzt, weil entweder seine Breite oder seine Hцhe das Maximum von ' + + '65535 Pixeln ьberschreitet.'; + EPNGUnknownPalEntryText = 'Es gibt keinen solchen Palettenwert.'; + EPNGMissingPaletteText = 'Dieses "Portable Network Graphics" Bild konnte ' + + 'nicht geladen werden, weil die benцtigte Farbtabelle fehlt.'; + EPNGUnknownCriticalChunkText = 'Dieses "Portable Network Graphics" Bild ' + + 'enhдlt einen unbekannten aber notwendigen Teil, welcher nicht entschlьsselt ' + + 'werden kann.'; + EPNGUnknownCompressionText = 'Dieses "Portable Network Graphics" Bild ' + + 'wurde mit einem unbekannten Komprimierungsalgorithmus kodiert, welcher ' + + 'nicht entschlьsselt werden kann.'; + EPNGUnknownInterlaceText = 'Dieses "Portable Network Graphics" Bild ' + + 'benutzt ein unbekanntes Interlace-Schema, welches nicht entschlьsselt ' + + 'werden kann.'; + EPNGCannotAssignChunkText = 'Die Abschnitte mьssen kompatibel sein, damit ' + + 'sie zugewiesen werden kцnnen.'; + EPNGUnexpectedEndText = 'Dieses "Portable Network Graphics" Bild ist ' + + 'ungьltig: Der Dekoder ist unerwartete auf das Ende der Datei gestoЯen.'; + EPNGNoImageDataText = 'Dieses "Portable Network Graphics" Bild enthдlt ' + + 'keine Daten.'; + EPNGCannotAddChunkText = 'Das Programm versucht einen existierenden und ' + + 'notwendigen Abschnitt zum aktuellen Bild hinzuzufьgen. Dies ist nicht ' + + 'zulдssig.'; + EPNGCannotAddInvalidImageText = 'Es ist nicht zulдssig, einem ungьltigen ' + + 'Bild einen neuen Abschnitt hinzuzufьgen.'; + EPNGCouldNotLoadResourceText = 'Das PNG Bild konnte nicht aus den ' + + 'Resourcendaten geladen werden.'; + EPNGOutMemoryText = 'Es stehen nicht genьgend Resourcen im System zur ' + + 'Verfьgung, um die Operation auszufьhren. SchlieЯen Sie einige Fenster '+ + 'und versuchen Sie es erneut.'; + EPNGCannotChangeTransparentText = 'Das Setzen der Bit-' + + 'Transparent-Farbe ist fьr PNG-Images die Alpha-Werte fьr jedes ' + + 'Pixel enthalten (COLOR_RGBALPHA und COLOR_GRAYSCALEALPHA) nicht ' + + 'zulдssig'; + EPNGHeaderNotPresentText = 'Die Datei, die gelesen wird, ist kein ' + + 'gьltiges "Portable Network Graphics" Bild, da es keinen gьltigen ' + + 'Header enthдlt.'; + EInvalidNewSize = 'The new size provided for image resizing is invalid.'; + EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + + 'because invalid image type parameters have being provided.'; + {$ENDIF} + {Language strings for French} + {$IFDEF French} + EPngInvalidCRCText = 'Cette image "Portable Network Graphics" n''est pas valide ' + + 'car elle contient des donnйes invalides (erreur crc)'; + EPNGInvalidIHDRText = 'Cette image "Portable Network Graphics" n''a pu кtre ' + + 'chargйe car l''une de ses principale donnйe (ihdr) doit кtre corrompue'; + EPNGMissingMultipleIDATText = 'Cette image "Portable Network Graphics" est ' + + 'invalide car elle contient des parties d''image manquantes.'; + EPNGZLIBErrorText = 'Impossible de dйcompresser l''image car elle contient ' + + 'des donnйes compressйes invalides.'#13#10 + ' Description: '; + EPNGInvalidPaletteText = 'L''image "Portable Network Graphics" contient ' + + 'une palette invalide.'; + EPNGInvalidFileHeaderText = 'Le fichier actuellement lu est une image '+ + '"Portable Network Graphics" invalide car elle contient un en-tкte invalide.' + + ' Ce fichier doit кtre corrompu, essayer de l''obtenir а nouveau.'; + EPNGIHDRNotFirstText = 'Cette image "Portable Network Graphics" n''est pas ' + + 'supportйe ou doit кtre invalide.'#13#10 + '(la partie IHDR n''est pas la premiиre)'; + EPNGNotExistsText = 'Le fichier png n''a pu кtre chargй car il n''йxiste pas.'; + EPNGSizeExceedsText = 'Cette image "Portable Network Graphics" n''est pas supportйe ' + + 'car sa longueur ou sa largeur excиde la taille maximale, qui est de 65535 pixels.'; + EPNGUnknownPalEntryText = 'Il n''y a aucune entrйe pour cette palette.'; + EPNGMissingPaletteText = 'Cette image "Portable Network Graphics" n''a pu кtre ' + + 'chargйe car elle utilise une table de couleur manquante.'; + EPNGUnknownCriticalChunkText = 'Cette image "Portable Network Graphics" ' + + 'contient une partie critique inconnue qui n'' pu кtre dйcodйe.'; + EPNGUnknownCompressionText = 'Cette image "Portable Network Graphics" est ' + + 'encodйe а l''aide d''un schйmas de compression inconnu qui ne peut кtre dйcodй.'; + EPNGUnknownInterlaceText = 'Cette image "Portable Network Graphics" utilise ' + + 'un schйmas d''entrelacement inconnu qui ne peut кtre dйcodй.'; + EPNGCannotAssignChunkText = 'Ce morceau doit кtre compatible pour кtre assignй.'; + EPNGUnexpectedEndText = 'Cette image "Portable Network Graphics" est invalide ' + + 'car le decodeur est arrivй а une fin de fichier non attendue.'; + EPNGNoImageDataText = 'Cette image "Portable Network Graphics" ne contient pas de ' + + 'donnйes.'; + EPNGCannotAddChunkText = 'Le programme a essayй d''ajouter un morceau critique existant ' + + 'а l''image actuelle, ce qui n''est pas autorisй.'; + EPNGCannotAddInvalidImageText = 'Il n''est pas permis d''ajouter un nouveau morceau ' + + 'car l''image actuelle est invalide.'; + EPNGCouldNotLoadResourceText = 'L''image png n''a pu кtre chargйe depuis ' + + 'l''ID ressource.'; + EPNGOutMemoryText = 'Certaines opйrations n''ont pu кtre effectuйe car le ' + + 'systиme n''a plus de ressources. Fermez quelques fenкtres et essayez а nouveau.'; + EPNGCannotChangeTransparentText = 'Dйfinir le bit de transparence n''est pas ' + + 'permis pour des images png qui contiennent une valeur alpha pour chaque pixel ' + + '(COLOR_RGBALPHA et COLOR_GRAYSCALEALPHA)'; + EPNGHeaderNotPresentText = 'Cette opйration n''est pas valide car l''image ' + + 'actuelle ne contient pas de header valide.'; + EPNGAlphaNotSupportedText = 'Le type de couleur de l''image "Portable Network Graphics" actuelle ' + + 'contient dйjа des informations alpha ou il ne peut кtre converti.'; + EInvalidNewSize = 'The new size provided for image resizing is invalid.'; + EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + + 'because invalid image type parameters have being provided.'; + {$ENDIF} + {Language strings for slovenian} + {$IFDEF Slovenian} + EPngInvalidCRCText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + + 'ker vsebuje neveljavne dele podatkov (CRC napaka).'; + EPNGInvalidIHDRText = 'Slike "Portable Network Graphics" ni bilo moћno ' + + 'naloћiti, ker je eden od glavnih delov podatkov (IHDR) verjetno pokvarjen.'; + EPNGMissingMultipleIDATText = 'Ta "Portable Network Graphics" slika je ' + + 'naveljavna, ker manjkajo deli slike.'; + EPNGZLIBErrorText = 'Ne morem raztegniti slike, ker vsebuje ' + + 'neveljavne stisnjene podatke.'#13#10 + ' Opis: '; + EPNGInvalidPaletteText = 'Slika "Portable Network Graphics" vsebuje ' + + 'neveljavno barvno paleto.'; + EPNGInvalidFileHeaderText = 'Datoteka za branje ni veljavna '+ + '"Portable Network Graphics" slika, ker vsebuje neveljavno glavo.' + + ' Datoteka je verjetno pokvarjena, poskusite jo ponovno naloћiti.'; + EPNGIHDRNotFirstText = 'Ta "Portable Network Graphics" slika ni ' + + 'podprta ali pa je neveljavna.'#13#10 + '(IHDR del datoteke ni prvi).'; + EPNGNotExistsText = 'Ne morem naloћiti png datoteke, ker ta ne ' + + 'obstaja.'; + EPNGSizeExceedsText = 'Ta "Portable Network Graphics" slika ni ' + + 'podprta, ker ali njena љirina ali viљina presega najvecjo moћno vrednost ' + + '65535 pik.'; + EPNGUnknownPalEntryText = 'Slika nima vneљene take barvne palete.'; + EPNGMissingPaletteText = 'Te "Portable Network Graphics" ne morem ' + + 'naloћiti, ker uporablja manjkajoco barvno paleto.'; + EPNGUnknownCriticalChunkText = 'Ta "Portable Network Graphics" slika ' + + 'vsebuje neznan kriticni del podatkov, ki ga ne morem prebrati.'; + EPNGUnknownCompressionText = 'Ta "Portable Network Graphics" slika je ' + + 'kodirana z neznano kompresijsko shemo, ki je ne morem prebrati.'; + EPNGUnknownInterlaceText = 'Ta "Portable Network Graphics" slika uporablja ' + + 'neznano shemo za preliv, ki je ne morem prebrati.'; + EPNGCannotAssignChunkText = 'Koљcki morajo biti med seboj kompatibilni za prireditev vrednosti.'; + EPNGUnexpectedEndText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + + 'ker je bralnik priљel do nepricakovanega konca datoteke.'; + EPNGNoImageDataText = 'Ta "Portable Network Graphics" ne vsebuje nobenih ' + + 'podatkov.'; + EPNGCannotAddChunkText = 'Program je poskusil dodati obstojeci kriticni ' + + 'kos podatkov k trenutni sliki, kar ni dovoljeno.'; + EPNGCannotAddInvalidImageText = 'Ni dovoljeno dodati nov kos podatkov, ' + + 'ker trenutna slika ni veljavna.'; + EPNGCouldNotLoadResourceText = 'Ne morem naloћiti png slike iz ' + + 'skladiљca.'; + EPNGOutMemoryText = 'Ne morem izvesti operacije, ker je ' + + 'sistem ostal brez resorjev. Zaprite nekaj oken in poskusite znova.'; + EPNGCannotChangeTransparentText = 'Ni dovoljeno nastaviti prosojnosti posamezne barve ' + + 'za png slike, ki vsebujejo alfa prosojno vrednost za vsako piko ' + + '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; + EPNGHeaderNotPresentText = 'Ta operacija ni veljavna, ker ' + + 'izbrana slika ne vsebuje veljavne glave.'; + EInvalidNewSize = 'The new size provided for image resizing is invalid.'; + EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + + 'because invalid image type parameters have being provided.'; + {$ENDIF} + + +implementation + +end. + + +// diff --git a/official/4.8.11/Source/frxrcClass.pas b/official/4.8.11/Source/frxrcClass.pas new file mode 100644 index 0000000..0e0ab58 --- /dev/null +++ b/official/4.8.11/Source/frxrcClass.pas @@ -0,0 +1,83 @@ +{******************************************} +{ } +{ FastReport v4.0 } +{ Language resource file } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxrcClass; + +interface + +implementation + +uses frxRes; + +const resXML = +'<' + +'StrRes Name="SForError" Text="Los bucles For necesitan una variable numГ©rica"/>' + +'' + +' '; + +initialization + frxResources.AddXML(resXML); + +end. diff --git a/official/4.8.11/Source/frxrcDesgn.pas b/official/4.8.11/Source/frxrcDesgn.pas new file mode 100644 index 0000000..9585f6f --- /dev/null +++ b/official/4.8.11/Source/frxrcDesgn.pas @@ -0,0 +1,297 @@ +{******************************************} +{ } +{ FastReport v4.0 } +{ Language resource file } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxrcDesgn; + +interface + +implementation + +uses frxRes; + +const resXML = +'<' + +'StrRes Name="2427" Text="Vista Previa"/><' + +'StrRes Name="dbNotAssigned" Text="[no asignado]"/><' + +'StrRes Name="3309" Text="Texto"/>' + +'<' + +'StrRes Name="4712" Text="Imagen"/><' + +'StrRes Name="5209" Text="Sin marco"/>' + +'<' + +'StrRes Name="obFIBDB" Text="FIB Database"/>' + +' '; + +initialization + frxResources.AddXML(resXML); + +end. diff --git a/official/4.8.11/Source/frxrcExports.pas b/official/4.8.11/Source/frxrcExports.pas new file mode 100644 index 0000000..5626494 --- /dev/null +++ b/official/4.8.11/Source/frxrcExports.pas @@ -0,0 +1,86 @@ +{******************************************} +{ } +{ FastReport v4.0 } +{ Language resource file } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxrcExports; + +interface + +implementation + +uses frxRes; + +const resXML = +'' + +' '; + +initialization + frxResources.AddXML(resXML); + +end. diff --git a/official/4.8.11/Source/frxrcInsp.pas b/official/4.8.11/Source/frxrcInsp.pas new file mode 100644 index 0000000..8dd8f6a --- /dev/null +++ b/official/4.8.11/Source/frxrcInsp.pas @@ -0,0 +1,177 @@ +{******************************************} +{ } +{ FastReport v4.0 } +{ Language resource file } +{ } +{ Copyright (c) 1998-2008 } +{ by Alexander Tzyganenko, } +{ Fast Reports Inc. } +{ } +{******************************************} + +unit frxrcInsp; + +interface + +implementation + +uses frxRes; + +const resXML = +'<' + +'StrRes Name="propSessionName" Text="Nombre de la sesiГіn del BDE"/>' + +' '; + +initialization + frxResources.AddXML(resXML); + +end. diff --git a/official/4.8.11/Source/infback.zobj b/official/4.8.11/Source/infback.zobj new file mode 100644 index 0000000..de48b33 Binary files /dev/null and b/official/4.8.11/Source/infback.zobj differ diff --git a/official/4.8.11/Source/inffast.zobj b/official/4.8.11/Source/inffast.zobj new file mode 100644 index 0000000..7deab05 Binary files /dev/null and b/official/4.8.11/Source/inffast.zobj differ diff --git a/official/4.8.11/Source/inflate.zobj b/official/4.8.11/Source/inflate.zobj new file mode 100644 index 0000000..6274e31 Binary files /dev/null and b/official/4.8.11/Source/inflate.zobj differ diff --git a/official/4.8.11/Source/inftrees.zobj b/official/4.8.11/Source/inftrees.zobj new file mode 100644 index 0000000..44a5708 Binary files /dev/null and b/official/4.8.11/Source/inftrees.zobj differ diff --git a/official/4.8.11/Source/printers.xml b/official/4.8.11/Source/printers.xml new file mode 100644 index 0000000..30e07c0 --- /dev/null +++ b/official/4.8.11/Source/printers.xml @@ -0,0 +1,20 @@ + + + + + + + + diff --git a/official/4.8.11/Source/rc_AlgRef.pas b/official/4.8.11/Source/rc_AlgRef.pas new file mode 100644 index 0000000..3de3d9a --- /dev/null +++ b/official/4.8.11/Source/rc_AlgRef.pas @@ -0,0 +1,573 @@ +{* rijndael-alg-ref.c v2.0 August '99 *} +(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * --------------------------------- * + * DELPHI * + * Rijndael algorithm implementation * + * --------------------------------- * + * December 2000 * + * * + * Authors: Paulo Barreto * + * Vincent Rijmen * + * * + * Delphi translation by Sergey Kirichenko (ksv@cheerful.com) * + * Home Page: http://rcolonel.tripod.com * + * Adapted to FastReport: Alexander Tzyganenko * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *) + +unit rc_AlgRef; + +{$I frx.inc} + +interface + +const + MAXBC = (256 div 32); + MAXKC = (256 div 32); + MAXROUNDS = 14; + +type + word8 = byte; // unsigned 8-bit + word16 = word; // unsigned 16-bit + word32 = longword; // unsigned 32-bit + + TArrayK = array [0..4-1, 0..MAXKC-1] of word8; + PArrayK = ^TArrayK; + TArrayRK = array [0..MAXROUNDS+1-1, 0..4-1, 0..MAXBC-1] of word8; + TArrayBox= array [0..256-1] of word8; + + +{ Calculate the necessary round keys + The number of calculations depends on keyBits and blockBits } +function rijndaelKeySched(k: TArrayK; keyBits, blockBits: integer; + var W: TArrayRK): integer; + +{ Encryption of one block. } +function rijndaelEncrypt(var a: TArrayK; keyBits, blockBits: integer; rk: TArrayRK): integer; + +{ Encrypt only a certain number of rounds. + Only used in the Intermediate Value Known Answer Test. } +function rijndaelEncryptRound(var a: TArrayK; keyBits, blockBits: integer; + rk: TArrayRK; var irounds: integer): integer; + +{ Decryption of one block. } +function rijndaelDecrypt(var a: TArrayK; keyBits, blockBits: integer; rk: TArrayRK): integer; + +{ Decrypt only a certain number of rounds. + Only used in the Intermediate Value Known Answer Test. + Operations rearranged such that the intermediate values + of decryption correspond with the intermediate values + of encryption. } +function rijndaelDecryptRound(var a: TArrayK; keyBits, blockBits: integer; + rk: TArrayRK; var irounds: integer): integer; + + +implementation + + +{ + Tables that are needed by the reference implementation. + The tables implement the S-box and its inverse, and also + some temporary tables needed for multiplying in the finite field GF(2^8) +} + +const + Logtable: array [0..256-1] of word8 = ( + 0, 0, 25, 1, 50, 2, 26, 198, 75, 199, 27, 104, 51, 238, 223, 3, + 100, 4, 224, 14, 52, 141, 129, 239, 76, 113, 8, 200, 248, 105, 28, 193, + 125, 194, 29, 181, 249, 185, 39, 106, 77, 228, 166, 114, 154, 201, 9, 120, + 101, 47, 138, 5, 33, 15, 225, 36, 18, 240, 130, 69, 53, 147, 218, 142, + 150, 143, 219, 189, 54, 208, 206, 148, 19, 92, 210, 241, 64, 70, 131, 56, + 102, 221, 253, 48, 191, 6, 139, 98, 179, 37, 226, 152, 34, 136, 145, 16, + 126, 110, 72, 195, 163, 182, 30, 66, 58, 107, 40, 84, 250, 133, 61, 186, + 43, 121, 10, 21, 155, 159, 94, 202, 78, 212, 172, 229, 243, 115, 167, 87, + 175, 88, 168, 80, 244, 234, 214, 116, 79, 174, 233, 213, 231, 230, 173, 232, + 44, 215, 117, 122, 235, 22, 11, 245, 89, 203, 95, 176, 156, 169, 81, 160, + 127, 12, 246, 111, 23, 196, 73, 236, 216, 67, 31, 45, 164, 118, 123, 183, + 204, 187, 62, 90, 251, 96, 177, 134, 59, 82, 161, 108, 170, 85, 41, 157, + 151, 178, 135, 144, 97, 190, 220, 252, 188, 149, 207, 205, 55, 63, 91, 209, + 83, 57, 132, 60, 65, 162, 109, 71, 20, 42, 158, 93, 86, 242, 211, 171, + 68, 17, 146, 217, 35, 32, 46, 137, 180, 124, 184, 38, 119, 153, 227, 165, + 103, 74, 237, 222, 197, 49, 254, 24, 13, 99, 140, 128, 192, 247, 112, 7 ); + + Alogtable: array [0..256-1] of word8 = ( + 1, 3, 5, 15, 17, 51, 85, 255, 26, 46, 114, 150, 161, 248, 19, 53, + 95, 225, 56, 72, 216, 115, 149, 164, 247, 2, 6, 10, 30, 34, 102, 170, + 229, 52, 92, 228, 55, 89, 235, 38, 106, 190, 217, 112, 144, 171, 230, 49, + 83, 245, 4, 12, 20, 60, 68, 204, 79, 209, 104, 184, 211, 110, 178, 205, + 76, 212, 103, 169, 224, 59, 77, 215, 98, 166, 241, 8, 24, 40, 120, 136, + 131, 158, 185, 208, 107, 189, 220, 127, 129, 152, 179, 206, 73, 219, 118, 154, + 181, 196, 87, 249, 16, 48, 80, 240, 11, 29, 39, 105, 187, 214, 97, 163, + 254, 25, 43, 125, 135, 146, 173, 236, 47, 113, 147, 174, 233, 32, 96, 160, + 251, 22, 58, 78, 210, 109, 183, 194, 93, 231, 50, 86, 250, 21, 63, 65, + 195, 94, 226, 61, 71, 201, 64, 192, 91, 237, 44, 116, 156, 191, 218, 117, + 159, 186, 213, 100, 172, 239, 42, 126, 130, 157, 188, 223, 122, 142, 137, 128, + 155, 182, 193, 88, 232, 35, 101, 175, 234, 37, 111, 177, 200, 67, 197, 84, + 252, 31, 33, 99, 165, 244, 7, 9, 27, 45, 119, 153, 176, 203, 70, 202, + 69, 207, 74, 222, 121, 139, 134, 145, 168, 227, 62, 66, 198, 81, 243, 14, + 18, 54, 90, 238, 41, 123, 141, 140, 143, 138, 133, 148, 167, 242, 13, 23, + 57, 75, 221, 124, 132, 151, 162, 253, 28, 36, 108, 180, 199, 82, 246, 1 ); + + S: TArrayBox{array [0..256-1] of word8} = ( + 99, 124, 119, 123, 242, 107, 111, 197, 48, 1, 103, 43, 254, 215, 171, 118, + 202, 130, 201, 125, 250, 89, 71, 240, 173, 212, 162, 175, 156, 164, 114, 192, + 183, 253, 147, 38, 54, 63, 247, 204, 52, 165, 229, 241, 113, 216, 49, 21, + 4, 199, 35, 195, 24, 150, 5, 154, 7, 18, 128, 226, 235, 39, 178, 117, + 9, 131, 44, 26, 27, 110, 90, 160, 82, 59, 214, 179, 41, 227, 47, 132, + 83, 209, 0, 237, 32, 252, 177, 91, 106, 203, 190, 57, 74, 76, 88, 207, + 208, 239, 170, 251, 67, 77, 51, 133, 69, 249, 2, 127, 80, 60, 159, 168, + 81, 163, 64, 143, 146, 157, 56, 245, 188, 182, 218, 33, 16, 255, 243, 210, + 205, 12, 19, 236, 95, 151, 68, 23, 196, 167, 126, 61, 100, 93, 25, 115, + 96, 129, 79, 220, 34, 42, 144, 136, 70, 238, 184, 20, 222, 94, 11, 219, + 224, 50, 58, 10, 73, 6, 36, 92, 194, 211, 172, 98, 145, 149, 228, 121, + 231, 200, 55, 109, 141, 213, 78, 169, 108, 86, 244, 234, 101, 122, 174, 8, + 186, 120, 37, 46, 28, 166, 180, 198, 232, 221, 116, 31, 75, 189, 139, 138, + 112, 62, 181, 102, 72, 3, 246, 14, 97, 53, 87, 185, 134, 193, 29, 158, + 225, 248, 152, 17, 105, 217, 142, 148, 155, 30, 135, 233, 206, 85, 40, 223, + 140, 161, 137, 13, 191, 230, 66, 104, 65, 153, 45, 15, 176, 84, 187, 22 ); + + Si: TArrayBox{array [0..256-1] of word8} = ( + 82, 9, 106, 213, 48, 54, 165, 56, 191, 64, 163, 158, 129, 243, 215, 251, + 124, 227, 57, 130, 155, 47, 255, 135, 52, 142, 67, 68, 196, 222, 233, 203, + 84, 123, 148, 50, 166, 194, 35, 61, 238, 76, 149, 11, 66, 250, 195, 78, + 8, 46, 161, 102, 40, 217, 36, 178, 118, 91, 162, 73, 109, 139, 209, 37, + 114, 248, 246, 100, 134, 104, 152, 22, 212, 164, 92, 204, 93, 101, 182, 146, + 108, 112, 72, 80, 253, 237, 185, 218, 94, 21, 70, 87, 167, 141, 157, 132, + 144, 216, 171, 0, 140, 188, 211, 10, 247, 228, 88, 5, 184, 179, 69, 6, + 208, 44, 30, 143, 202, 63, 15, 2, 193, 175, 189, 3, 1, 19, 138, 107, + 58, 145, 17, 65, 79, 103, 220, 234, 151, 242, 207, 206, 240, 180, 230, 115, + 150, 172, 116, 34, 231, 173, 53, 133, 226, 249, 55, 232, 28, 117, 223, 110, + 71, 241, 26, 113, 29, 41, 197, 137, 111, 183, 98, 14, 170, 24, 190, 27, + 252, 86, 62, 75, 198, 210, 121, 32, 154, 219, 192, 254, 120, 205, 90, 244, + 31, 221, 168, 51, 136, 7, 199, 49, 177, 18, 16, 89, 39, 128, 236, 95, + 96, 81, 127, 169, 25, 181, 74, 13, 45, 229, 122, 159, 147, 201, 156, 239, + 160, 224, 59, 77, 174, 42, 245, 176, 200, 235, 187, 60, 131, 83, 153, 97, + 23, 43, 4, 126, 186, 119, 214, 38, 225, 105, 20, 99, 85, 33, 12, 125 ); + + rcon: array [0..30-1] of word32 = ( + $01,$02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, + $d8, $ab, $4d, $9a, $2f, $5e, $bc, $63, $c6, $97, $35, + $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91 ); + + shifts: array [0..3-1, 0..4-1, 0..2-1] of word8 = ( + ((0, 0),(1, 3),(2, 2),(3, 1)), + ((0, 0),(1, 5),(2, 4),(3, 3)), + ((0, 0),(1, 7),(3, 5),(4, 4))); + +function iif(bExpression: boolean; iResTrue,iResFalse: integer): integer; +begin + if bExpression then + result:= iResTrue + else + result:= iResFalse; +end; + +function mul(a, b: word8): word8; +{ multiply two elements of GF(2^m) + needed for MixColumn and InvMixColumn } +begin + if (a<>0) and (b<>0) then + result:= Alogtable[(Logtable[a] + Logtable[b]) mod 255] + else + result:= 0; +end; + +procedure KeyAddition(var a: TArrayK; rk: PArrayK; BC:word8); +{ Exor corresponding text input and round key input bytes } +var + i, j: integer; +begin + for i:= 0 to 4-1 do + for j:= 0 to BC-1 do + a[i][j]:= a[i][j] xor rk[i][j]; +end; + +procedure ShiftRow(var a: TArrayK; d, BC: word8); +{ Row 0 remains unchanged + The other three rows are shifted a variable amount } +var + tmp: array [0..MAXBC-1] of word8; + i, j: integer; +begin + for i:= 1 to 4-1 do + begin + for j:= 0 to BC-1 do + tmp[j]:= a[i][(j + shifts[((BC - 4) shr 1)][i][d]) mod BC]; + for j:= 0 to BC-1 do + a[i][j]:= tmp[j]; + end; +end; + +procedure Substitution(var a: TArrayK; const box: TArrayBox; BC: word8); +{ Replace every byte of the input by the byte at that place + in the nonlinear S-box } +var + i, j: integer; +begin + for i:= 0 to 4-1 do + for j:= 0 to BC-1 do + a[i][j]:= box[a[i][j]]; +end; + +procedure MixColumn(var a: TArrayK; BC: word8); +{ Mix the four bytes of every column in a linear way } +var + b: TArrayK; + i, j: integer; +begin + for j:= 0 to BC-1 do + for i:= 0 to 4-1 do + b[i][j]:= mul(2,a[i][j]) + xor mul(3,a[(i + 1) mod 4][j]) + xor a[(i + 2) mod 4][j] + xor a[(i + 3) mod 4][j]; + for i:= 0 to 4-1 do + for j:= 0 to BC-1 do + a[i][j]:= b[i][j]; +end; + +procedure InvMixColumn(var a: TArrayK; BC: word8); +{ Mix the four bytes of every column in a linear way + This is the opposite operation of Mixcolumn } +var + b: TArrayK; + i, j: integer; +begin + for j:= 0 to BC-1 do + for i:= 0 to 4-1 do + b[i][j]:= mul($e,a[i][j]) + xor mul($b,a[(i + 1) mod 4][j]) + xor mul($d,a[(i + 2) mod 4][j]) + xor mul($9,a[(i + 3) mod 4][j]); + for i:= 0 to 4-1 do + for j:= 0 to BC-1 do + a[i][j]:= b[i][j]; +end; + +function rijndaelKeySched(k: TArrayK; keyBits, blockBits: integer; + var W: TArrayRK): integer; +{ Calculate the necessary round keys + The number of calculations depends on keyBits and blockBits } +var + KC, BC, ROUNDS: integer; + i, j, t, rconpointer: integer; + tk: array [0..4-1, 0..MAXKC-1] of word8; +begin + rconpointer:= 0; + case (keyBits) of + 128: KC:= 4; + 192: KC:= 6; + 256: KC:= 8; + else + begin + result:= -1; + exit; + end; + end; + + case (blockBits) of + 128: BC:= 4; + 192: BC:= 6; + 256: BC:= 8; + else + begin + result:= -2; + exit; + end; + end; + + case iif(keyBits >= blockBits, keyBits, blockBits) of + 128: ROUNDS:= 10; + 192: ROUNDS:= 12; + 256: ROUNDS:= 14; + else + begin + result:= -3; {* this cannot happen *} + exit; + end; + end; + + for j:= 0 to KC-1 do + for i:= 0 to 4-1 do + tk[i][j]:= k[i][j]; + + { copy values into round key array } + t:= 0; + j:= 0; + while ((j < KC) and (t < (ROUNDS+1)*BC)) do + begin + for i:= 0 to 4-1 do + W[t div BC][i][t mod BC]:= tk[i][j]; + inc(j); + inc(t); + end; + + while (t < (ROUNDS+1)*BC) do { while not enough round key material calculated } + begin + { calculate new values } + for i:= 0 to 4-1 do + tk[i][0]:= tk[i][0] xor S[tk[(i+1) mod 4][KC-1]]; + tk[0][0]:= tk[0][0] xor rcon[rconpointer]; + inc(rconpointer); + if (KC <> 8) then + begin + for j:= 1 to KC-1 do + for i:= 0 to 4-1 do + tk[i][j]:= tk[i][j] xor tk[i][j-1]; + end + else + begin + j:= 1; + while j < KC/2 do + begin + for i:= 0 to 4-1 do + tk[i][j]:= tk[i][j] xor tk[i][j-1]; + inc(j); + end; + for i:= 0 to 4-1 do + tk[i][KC div 2]:= tk[i][KC div 2] xor S[tk[i][(KC div 2) - 1]]; + j:= (KC div 2) + 1; + while j < KC do + begin + for i:= 0 to 4-1 do + tk[i][j]:= tk[i][j] xor tk[i][j-1]; + inc(j); + end; + end; + + { copy values into round key array } + j:= 0; + while ((j < KC) and (t < (ROUNDS+1)*BC)) do + begin + for i:= 0 to 4-1 do + W[t div BC][i][t mod BC]:= tk[i][j]; + inc(j); + inc(t); + end; + end; + result:= 0; +end; + +function rijndaelEncrypt(var a: TArrayK; keyBits, blockBits: integer; rk: TArrayRK): integer; +{ Encryption of one block. } +var + r, BC, ROUNDS: integer; +begin + case (blockBits) of + 128: BC:= 4; + 192: BC:= 6; + 256: BC:= 8; + else + begin + result:= -2; + exit; + end; + end; + + case iif(keyBits >= blockBits, keyBits, blockBits) of + 128: ROUNDS:= 10; + 192: ROUNDS:= 12; + 256: ROUNDS:= 14; + else + begin + result:= -3; { this cannot happen } + exit; + end; + end; + + { begin with a key addition } + KeyAddition(a,addr(rk[0]),BC); + + { ROUNDS-1 ordinary rounds } + for r:= 1 to ROUNDS-1 do + begin + Substitution(a,S,BC); + ShiftRow(a,0,BC); + MixColumn(a,BC); + KeyAddition(a,addr(rk[r]),BC); + end; + + { Last round is special: there is no MixColumn } + Substitution(a,S,BC); + ShiftRow(a,0,BC); + KeyAddition(a,addr(rk[ROUNDS]),BC); + result:= 0; +end; + +function rijndaelEncryptRound(var a: TArrayK; keyBits, blockBits: integer; + rk: TArrayRK; var irounds: integer): integer; +{ Encrypt only a certain number of rounds. + Only used in the Intermediate Value Known Answer Test. } +var + r, BC, ROUNDS: integer; +begin + case (blockBits) of + 128: BC:= 4; + 192: BC:= 6; + 256: BC:= 8; + else + begin + result:= -2; + exit; + end; + end; + + case iif(keyBits >= blockBits, keyBits, blockBits) of + 128: ROUNDS:= 10; + 192: ROUNDS:= 12; + 256: ROUNDS:= 14; + else + begin + result:= -3; { this cannot happen } + exit; + end; + end; + + { make number of rounds sane } + if (irounds > ROUNDS) then + irounds:= ROUNDS; + + { begin with a key addition } + KeyAddition(a,addr(rk[0]),BC); + + { at most ROUNDS-1 ordinary rounds } + r:= 1; + while (r <= irounds) and (r < ROUNDS) do + begin + Substitution(a,S,BC); + ShiftRow(a,0,BC); + MixColumn(a,BC); + KeyAddition(a,addr(rk[r]),BC); + inc(r); + end; + + { if necessary, do the last, special, round: } + if (irounds = ROUNDS) then + begin + Substitution(a,S,BC); + ShiftRow(a,0,BC); + KeyAddition(a,addr(rk[ROUNDS]),BC); + end; + + result:= 0; +end; + +function rijndaelDecrypt(var a: TArrayK; keyBits, blockBits: integer; rk: TArrayRK): integer; +var + r, BC, ROUNDS: integer; +begin + + case (blockBits) of + 128: BC:= 4; + 192: BC:= 6; + 256: BC:= 8; + else + begin + result:= -2; + exit; + end; + end; + + case iif(keyBits >= blockBits, keyBits, blockBits) of + 128: ROUNDS:= 10; + 192: ROUNDS:= 12; + 256: ROUNDS:= 14; + else + begin + result:= -3; { this cannot happen } + exit; + end; + end; + + { To decrypt: apply the inverse operations of the encrypt routine, + in opposite order + + (KeyAddition is an involution: it 's equal to its inverse) + (the inverse of Substitution with table S is Substitution with the inverse table of S) + (the inverse of Shiftrow is Shiftrow over a suitable distance) } + + { First the special round: + without InvMixColumn + with extra KeyAddition } + KeyAddition(a,addr(rk[ROUNDS]),BC); + Substitution(a,Si,BC); + ShiftRow(a,1,BC); + + { ROUNDS-1 ordinary rounds } + for r:= ROUNDS-1 downto 0+1 do + begin + KeyAddition(a,addr(rk[r]),BC); + InvMixColumn(a,BC); + Substitution(a,Si,BC); + ShiftRow(a,1,BC); + end; + + { End with the extra key addition } + + KeyAddition(a,addr(rk[0]),BC); + result:= 0; +end; + +function rijndaelDecryptRound(var a: TArrayK; keyBits, blockBits: integer; + rk: TArrayRK; var irounds: integer): integer; +{ Decrypt only a certain number of rounds. + Only used in the Intermediate Value Known Answer Test. + Operations rearranged such that the intermediate values + of decryption correspond with the intermediate values + of encryption. } +var + r, BC, ROUNDS: integer; +begin + case (blockBits) of + 128: BC:= 4; + 192: BC:= 6; + 256: BC:= 8; + else + begin + result:= -2; + exit; + end; + end; + + case iif(keyBits >= blockBits, keyBits, blockBits) of + 128: ROUNDS:= 10; + 192: ROUNDS:= 12; + 256: ROUNDS:= 14; + else + begin + result:= -3; { this cannot happen } + exit; + end; + end; + + { make number of rounds sane } + if (irounds > ROUNDS) then + irounds:= ROUNDS; + + { First the special round: + without InvMixColumn + with extra KeyAddition } + + KeyAddition(a,addr(rk[ROUNDS]),BC); + Substitution(a,Si,BC); + ShiftRow(a,1,BC); + + { ROUNDS-1 ordinary rounds } + for r:= ROUNDS-1 downto irounds+1 do + begin + KeyAddition(a,addr(rk[r]),BC); + InvMixColumn(a,BC); + Substitution(a,Si,BC); + ShiftRow(a,1,BC); + end; + + if (irounds = 0) then + { End with the extra key addition } + KeyAddition(a,addr(rk[0]),BC); + + result:= 0; +end; + +end. + + +// diff --git a/official/4.8.11/Source/rc_ApiRef.pas b/official/4.8.11/Source/rc_ApiRef.pas new file mode 100644 index 0000000..ae525c1 --- /dev/null +++ b/official/4.8.11/Source/rc_ApiRef.pas @@ -0,0 +1,459 @@ +{* rijndael-api-ref.c v2.0 August '99 *} +(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * --------------------------------- * + * DELPHI * + * Rijndael API * + * --------------------------------- * + * December 2000 * + * * + * Authors: Paulo Barreto * + * Vincent Rijmen * + * * + * Delphi translation by Sergey Kirichenko (ksv@cheerful.com) * + * Home Page: http://rcolonel.tripod.com * + * Adapted to FastReport: Alexander Tzyganenko * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *) + +unit rc_ApiRef; + +{$I frx.inc} + +interface + +uses rc_AlgRef; + +const + MAXBC = (256 div 32); + MAXKC = (256 div 32); + MAXROUNDS = 14; + + DIR_ENCRYPT = 0; { Are we encrpyting? } + DIR_DECRYPT = 1; { Are we decrpyting? } + MODE_ECB = 1; { Are we ciphering in ECB mode? } + MODE_CBC = 2; { Are we ciphering in CBC mode? } + MODE_CFB1 = 3; { Are we ciphering in 1-bit CFB mode? } + rTRUE = 1; { integer(true) } + rFALSE = 0; { integer(false) } + BITSPERBLOCK = 128; { Default number of bits in a cipher block } + +{ Error Codes - CHANGE POSSIBLE: inclusion of additional error codes } + BAD_KEY_DIR = -1; { Key direction is invalid, e.g., unknown value } + BAD_KEY_MAT = -2; { Key material not of correct length } + BAD_KEY_INSTANCE = -3; { Key passed is not valid } + BAD_CIPHER_MODE = -4; { Params struct passed to cipherInit invalid } + BAD_CIPHER_STATE = -5; { Cipher in wrong state (e.g., not initialized) } + BAD_CIPHER_INSTANCE = -7; + +{ CHANGE POSSIBLE: inclusion of algorithm specific defines } + MAX_KEY_SIZE = 64; { # of ASCII char's needed to represent a key } + MAX_IV_SIZE = (BITSPERBLOCK div 8); { # bytes needed to represent an IV } + +type +{ Typedef'ed data storage elements. Add any algorithm specific + parameters at the bottom of the structs as appropriate. } + + word8 = byte; // unsigned 8-bit + word16 = word; // unsigned 16-bit + word32 = longword; // unsigned 32-bit + TByteArray = array [0..MaxInt div sizeof(Byte)-1] of Byte; + PByte = ^TByteArray; + +{ The structure for key information } + PkeyInstance = ^keyInstance; + keyInstance = packed record + direction: Byte; { Key used for encrypting or decrypting? } + keyLen: integer; { Length of the key } + keyMaterial: array [0..MAX_KEY_SIZE+1-1] of Ansichar; { Raw key data in ASCII, e.g., user input or KAT values } + { The following parameters are algorithm dependent, replace or add as necessary } + blockLen: integer; { block length } + keySched: TArrayRK; { key schedule } + end; {* keyInstance *} + TkeyInstance = keyInstance; + +{ The structure for cipher information } + PcipherInstance = ^cipherInstance; + cipherInstance = packed record + mode: Byte; // MODE_ECB, MODE_CBC, or MODE_CFB1 + IV: array [0..MAX_IV_SIZE-1] of Byte; // A possible Initialization Vector for ciphering + { Add any algorithm specific parameters needed here } + blockLen: integer; // Sample: Handles non-128 bit block sizes (if available) + end; {* cipherInstance *} + TcipherInstance = cipherInstance; + +{ Function prototypes } +function makeKey(key: PkeyInstance; direction: Byte; keyLen: integer; keyMaterial: pAnsichar): integer; +function cipherInit(cipher: PcipherInstance; mode: Byte; IV: pchar): integer; +{sergey has corrected it} +function blocksEnCrypt(cipher: PcipherInstance; key: PkeyInstance; input: PByte; + inputLen: integer; outBuffer: PByte): integer; +{sergey has corrected it} +function blocksDeCrypt(cipher: PcipherInstance; key: PkeyInstance; input: PByte; + inputLen: integer; outBuffer: PByte): integer; +{ cipherUpdateRounds: + + Encrypts/Decrypts exactly one full block a specified number of rounds. + Only used in the Intermediate Value Known Answer Test. + + Returns: + TRUE - on success + BAD_CIPHER_STATE - cipher in bad state (e.g., not initialized) } +function cipherUpdateRounds(cipher: PcipherInstance; key: PkeyInstance; input: PByte; + inputLen: integer; outBuffer: PByte; iRounds: integer): integer; + +implementation + +{ StrLCopy copies at most MaxLen characters from Source to Dest and returns Dest. } +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX + MOV EBX,ECX + XOR AL,AL + TEST ECX,ECX + JZ @@1 + REPNE SCASB + JNE @@1 + INC ECX +@@1: SUB EBX,ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,EDI + MOV ECX,EBX + SHR ECX,2 + REP MOVSD + MOV ECX,EBX + AND ECX,3 + REP MOVSB + STOSB + MOV EAX,EDX + POP EBX + POP ESI + POP EDI +end; + +function makeKey(key: PkeyInstance; direction: Byte; keyLen: integer; keyMaterial: pAnsichar): integer; +var + k: TArrayK; + i, j, t: integer; +begin + if not assigned(key) then + begin + result:= BAD_KEY_INSTANCE; + exit; + end; + + if ((direction = DIR_ENCRYPT) or (direction = DIR_DECRYPT)) then + key.direction:= direction + else + begin + result:= BAD_KEY_DIR; + exit; + end; + + if ((keyLen = 128) or (keyLen = 192) or (keyLen = 256)) then + key.keyLen:= keyLen + else + begin + result:= BAD_KEY_MAT; + exit; + end; + + if (keyMaterial^ <> #0) then + StrLCopy(key.keyMaterial, keyMaterial, keyLen div 4); // strncpy + + j := 0; + { initialize key schedule: } + for i:= 0 to (key.keyLen div 8)-1 do + begin + t:= integer(key.keyMaterial[2*i]); + if ((t >= ord('0')) and (t <= ord('9'))) then + j:= (t - ord('0')) shl 4 + else + if ((t >= ord('a')) and (t <= ord('f'))) then + j:= (t - ord('a') + 10) shl 4 + else + if ((t >= ord('A')) and (t <= ord('F'))) then + j:= (t - ord('A') + 10) shl 4 + else + begin + result:= BAD_KEY_MAT; + exit; + end; + + t:= integer(key.keyMaterial[2*i+1]); + if ((t >= ord('0')) and (t <= ord('9'))) then + j:= j xor (t - ord('0')) + else + if ((t >= ord('a')) and (t <= ord('f'))) then + j:= j xor (t - ord('a') + 10) + else + if ((t >= ord('A')) and (t <= ord('F'))) then + j:= j xor (t - ord('A') + 10) + else + begin + result:= BAD_KEY_MAT; + exit; + end; + + k[i mod 4][i div 4]:= word8(j); + end; + rijndaelKeySched(k, key.keyLen, key.blockLen, key.keySched); + result:= rTRUE; +end; + +function cipherInit(cipher: PcipherInstance; mode: Byte; IV: pchar): integer; +var + i, j, t: integer; +begin + if ((mode = MODE_ECB) or (mode = MODE_CBC) or (mode = MODE_CFB1)) then + cipher.mode:= mode + else + begin + result:= BAD_CIPHER_MODE; + exit; + end; + + j := 0; + + if assigned(IV) then + for i:= 0 to (cipher.blockLen div 8)-1 do + begin + t:= integer(IV[2*i]); + if ((t >= ord('0')) and (t <= ord('9'))) then + j:= (t - ord('0')) shl 4 + else + if ((t >= ord('a')) and (t <= ord('f'))) then + j:= (t - ord('a') + 10) shl 4 + else + if ((t >= ord('A')) and (t <= ord('F'))) then + j:= (t - ord('A') + 10) shl 4 + else + begin + result:= BAD_CIPHER_INSTANCE; + exit; + end; + + t:= integer(IV[2*i+1]); + if ((t >= ord('0')) and (t <= ord('9'))) then + j:= j xor (t - ord('0')) + else + if ((t >= ord('a')) and (t <= ord('f'))) then + j:= j xor (t - ord('a') + 10) + else + if ((t >= ord('A')) and (t <= ord('F'))) then + j:= j xor (t - ord('A') + 10) + else + begin + result:= BAD_CIPHER_INSTANCE; + exit; + end; + cipher.IV[i]:= Byte(j); + end; + result:= rTRUE; +end; + +function blocksEnCrypt(cipher: PcipherInstance; key: PkeyInstance; + input: PByte; inputLen: integer; outBuffer: PByte): integer; +var + i, j, t, numBlocks: integer; + block: TArrayK; +begin + { check parameter consistency: } + if (not assigned(key)) or + (key.direction <> DIR_ENCRYPT) or + ((key.keyLen <> 128) and (key.keyLen <> 192) and (key.keyLen <> 256)) then + begin + result:= BAD_KEY_MAT; + exit; + end; + + if (not assigned(cipher)) or + ((cipher.mode <> MODE_ECB) and (cipher.mode <> MODE_CBC) and (cipher.mode <> MODE_CFB1)) or + ((cipher.blockLen <> 128) and (cipher.blockLen <> 192) and (cipher.blockLen <> 256)) then + begin + result:= BAD_CIPHER_STATE; + exit; + end; + + numBlocks:= inputLen div cipher.blockLen; + case (cipher.mode) of + MODE_ECB: + for i:= 0 to numBlocks-1 do + begin + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array } + block[t][j]:= input[4*j+t] and $FF; + rijndaelEncrypt(block, key.keyLen, cipher.blockLen, key.keySched); + for j:= 0 to (cipher.blockLen div 32)-1 do + { parse rectangular array into output ciphertext bytes } + for t:= 0 to 4-1 do + outBuffer[4*j+t]:= Byte(block[t][j]); + end; + MODE_CBC: + begin + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse initial value into rectangular array } + block[t][j]:= cipher.IV[t+4*j] and $FF; + for i:= 0 to numBlocks-1 do + begin + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array and exor with + IV or the previous ciphertext } +// block[t][j]:= block[t][j] xor (input[4*j+t] and $FF); {!original!} + block[t][j]:= block[t][j] xor (input[(i*(cipher.blockLen div 8))+4*j+t] and $FF); {!sergey made it!} + rijndaelEncrypt(block, key.keyLen, cipher.blockLen, key.keySched); + for j:= 0 to (cipher.blockLen div 32)-1 do + { parse rectangular array into output ciphertext bytes } + for t:= 0 to 4-1 do +// outBuffer[4*j+t]:= Byte(block[t][j]); {!original!} + outBuffer[(i*(cipher.blockLen div 8))+4*j+t]:= Byte(block[t][j]); {!sergey made it!} + end; + end; + else + begin + result:= BAD_CIPHER_STATE; + exit + end; + end; + result:= numBlocks*cipher.blockLen; +end; + +function blocksDeCrypt(cipher: PcipherInstance; key: PkeyInstance; input: PByte; + inputLen: integer; outBuffer: PByte): integer; +var + i, j, t, numBlocks: integer; + block: TArrayK; +begin + if (not assigned(cipher)) or + (not assigned(key)) or + (key.direction = DIR_ENCRYPT) or + (cipher.blockLen <> key.blockLen) then + begin + result:= BAD_CIPHER_STATE; + exit; + end; + + { check parameter consistency: } + if (not assigned(key)) or + (key.direction <> DIR_DECRYPT) or + ((key.keyLen <> 128) and (key.keyLen <> 192) and (key.keyLen <> 256)) then + begin + result:= BAD_KEY_MAT; + exit; + end; + + if (not assigned(cipher)) or + ((cipher.mode <> MODE_ECB) and (cipher.mode <> MODE_CBC) and (cipher.mode <> MODE_CFB1)) or + ((cipher.blockLen <> 128) and (cipher.blockLen <> 192) and (cipher.blockLen <> 256)) then + begin + result:= BAD_CIPHER_STATE; + exit; + end; + + numBlocks:= inputLen div cipher.blockLen; + case (cipher.mode) of + MODE_ECB: + for i:= 0 to numBlocks-1 do + begin + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array } + block[t][j]:= input[4*j+t] and $FF; + rijndaelDecrypt (block, key.keyLen, cipher.blockLen, key.keySched); + for j:= 0 to (cipher.blockLen div 32)-1 do + { parse rectangular array into output ciphertext bytes } + for t:= 0 to 4-1 do + outBuffer[4*j+t]:= Byte(block[t][j]); + end; + MODE_CBC: + {! sergey has rearranged processing blocks and + corrected exclusive-ORing operation !} + + begin + { blocks after first } + for i:= numBlocks-1 downto 1 do + begin + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array } + block[t][j]:= input[(i*(cipher.blockLen div 8))+ 4*j+ t] and $FF; + rijndaelDecrypt(block, key.keyLen, cipher.blockLen, key.keySched); + + for j:= 0 to (cipher.blockLen div 32)-1 do + { exor previous ciphertext block and parse rectangular array + into output ciphertext bytes } + for t:= 0 to 4-1 do + outBuffer[(i*(cipher.blockLen div 8))+ 4*j+t]:= Byte(block[t][j] xor + input[(i-1)*(cipher.blockLen div 8)+ 4*j+ t]); + end; + + { first block } + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array } + block[t][j]:= input[4*j+t] and $FF; + rijndaelDecrypt(block, key.keyLen, cipher.blockLen, key.keySched); + + for j:= 0 to (cipher.blockLen div 32)-1 do + { exor the IV and parse rectangular array into output ciphertext bytes } + for t:= 0 to 4-1 do + outBuffer[4*j+t]:= Byte(block[t][j] xor cipher.IV[t+4*j]); + end; + else + begin + result:= BAD_CIPHER_STATE; + exit; + end; + end; + result:= numBlocks*cipher.blockLen; +end; + +function cipherUpdateRounds(cipher: PcipherInstance; key: PkeyInstance; input: PByte; + inputLen: integer; outBuffer: PByte; iRounds: integer): integer; +var + j, t: integer; + block: TArrayK; +begin + if (not assigned(cipher)) or + (not assigned(key)) or + (cipher.blockLen <> key.blockLen) then + begin + result:= BAD_CIPHER_STATE; + exit; + end; + + for j:= 0 to (cipher.blockLen div 32)-1 do + for t:= 0 to 4-1 do + { parse input stream into rectangular array } + block[t][j]:= input[4*j+t] and $FF; + + case (key.direction) of + DIR_ENCRYPT: + rijndaelEncryptRound(block, key.keyLen, cipher.blockLen, key.keySched, irounds); + DIR_DECRYPT: + rijndaelDecryptRound(block, key.keyLen, cipher.blockLen, key.keySched, irounds); + else + begin + result:= BAD_KEY_DIR; + exit; + end; + end; + + for j:= 0 to (cipher.blockLen div 32)-1 do + { parse rectangular array into output ciphertext bytes } + for t:= 0 to 4-1 do + outBuffer[4*j+t]:= Byte(block[t][j]); + result:= rTRUE; +end; + + +end. + + +// diff --git a/official/4.8.11/Source/rc_Crypt.pas b/official/4.8.11/Source/rc_Crypt.pas new file mode 100644 index 0000000..eac64c8 --- /dev/null +++ b/official/4.8.11/Source/rc_Crypt.pas @@ -0,0 +1,116 @@ +(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * --------------------------------- * + * DELPHI * + * Rijndael Extended API * + * version 1.0 * + * --------------------------------- * + * December 2000 * + * * + * Author: Sergey Kirichenko (ksv@cheerful.com) * + * Home Page: http://rcolonel.tripod.com * + * Adapted to FastReport: Alexander Tzyganenko * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *) + +unit rc_Crypt; + +{$I frx.inc} + +interface + +uses sysutils, + rc_ApiRef; + +const + _KEYLength = 128; + +function ExpandKey(sKey: AnsiString; iLength: integer): Ansistring; +{encode string} +function EnCryptString(const sMessage: AnsiString; sKeyMaterial: AnsiString): AnsiString; +{decode string} +function DeCryptString(const sMessage: AnsiString; sKeyMaterial: AnsiString): AnsiString; + + +implementation + +function ExpandKey(sKey: Ansistring; iLength: integer): AnsiString; +var + ikey: array [0..(_KEYLength div 8)-1] of byte; + i,t: integer; + sr: Ansistring; +begin + sr:= sKey; + FillChar(ikey,sizeof(ikey),0); + try + if (length(sr) mod 2)<> 0 then + sr:= sr+ '0'; + t:= length(sr) div 2; + if t> (iLength div 8) then + t:= (iLength div 8); + for i:= 0 to t-1 do + ikey[i]:= strtoint('$'+String(sr[i*2+1]) + String(sr[i*2+2])); + except + end; + sr:= ''; + for i:= 0 to (iLength div 8)-1 do + sr:= sr + AnsiString(IntToHex(ikey[i],2)); + result:= sr; +end; + +function EnCryptString(const sMessage: AnsiString; sKeyMaterial: AnsiString): AnsiString; +var + sres: Ansistring; + blockLength,i: integer; + keyInst: TkeyInstance; + cipherInst: TcipherInstance; +begin + keyInst.blockLen:= BITSPERBLOCK; + sres:= ExpandKey(sKeyMaterial,_KEYLength); + if makeKey(addr(keyInst), DIR_ENCRYPT, _KEYLength, pAnsichar(sres))<> rTRUE then + raise Exception.CreateFmt('Key error.',[-1]); + cipherInst.blockLen:= BITSPERBLOCK; + cipherInst.mode:= MODE_CBC; + FillChar(cipherInst.IV,sizeof(cipherInst.IV),0); + + sres:= sMessage; + blockLength:= length(sres)*8; + if (blockLength mod BITSPERBLOCK)<> 0 then + begin + for i:= 1 to ((BITSPERBLOCK-(blockLength-(BITSPERBLOCK*(blockLength div BITSPERBLOCK)))) div 8) do + sres:= sres+ ' '; + blockLength:= length(sres)*8; + end; + + if blocksEnCrypt(addr(cipherInst), addr(keyInst), addr(sres[1]), blockLength, addr(sres[1]))<> blockLength then + raise Exception.CreateFmt('EnCrypt error.',[-2]); + result:= sres; +end; + +function DeCryptString(const sMessage: AnsiString; sKeyMaterial: AnsiString): AnsiString; +var + sres: AnsiString; + blockLength: integer; + keyInst: TkeyInstance; + cipherInst: TcipherInstance; +begin + keyInst.blockLen:= BITSPERBLOCK; + sres:= ExpandKey(sKeyMaterial,_KEYLength); + if makeKey(addr(keyInst), DIR_DECRYPT, _KEYLength, pAnsichar(sres))<> rTRUE then + raise Exception.CreateFmt('Key error.',[-1]); + cipherInst.blockLen:= BITSPERBLOCK; + cipherInst.mode:= MODE_CBC; + FillChar(cipherInst.IV,sizeof(cipherInst.IV),0); + + sres:= sMessage; + blockLength:= length(sres)*8; + if (blockLength= 0) or ((blockLength mod BITSPERBLOCK)<> 0) then + raise Exception.CreateFmt('Wrong message length.',[-4]); + + if blocksDeCrypt(addr(cipherInst), addr(keyInst), addr(sres[1]), blockLength, addr(sres[1]))<> blockLength then + raise Exception.CreateFmt('DeCrypt error.',[-3]); + result:= AnsiString(trim(String(sres))); +end; + +end. + + +// diff --git a/official/4.8.11/Source/tee.inc b/official/4.8.11/Source/tee.inc new file mode 100644 index 0000000..cd30062 --- /dev/null +++ b/official/4.8.11/Source/tee.inc @@ -0,0 +1,65 @@ +//------------------- TeeChart component ---------------------------- +{$DEFINE TeeChartStd} + +//------------------- TeeChart Std 7 component ---------------------- +// If you have TeeChart Std 7, uncomment the following line: +//{$DEFINE TeeChartStd7} + +//------------------- TeeChart Pro 4 component -------------------- +// If you have TeeChart Pro 4, uncomment the following line: +//{$DEFINE TeeChart4} + +//------------------- TeeChart Pro 5 component -------------------- +// If you have TeeChart Pro 5, uncomment the following line: +//{$DEFINE TeeChart5} + +//------------------- TeeChart Pro 6 component ---------------------- +// If you have TeeChart Pro 6, uncomment the following line: +//{$DEFINE TeeChart6} + +//------------------- TeeChart Pro 7 component ---------------------- +// If you have TeeChart Pro 7, uncomment the following line: +//{$DEFINE TeeChart7} + +//------------------- TeeChart Pro 8 component ---------------------- +// If you have TeeChart Pro 8, uncomment the following line: +//{$DEFINE TeeChart8} + +//------------------- TeeChart Std 8 component ---------------------- +// If you have TeeChart Std 8, uncomment the following line: +//{$DEFINE TeeChartStd8} + + +// Don't change here ------------------------------------------------ +{$IFDEF TeeChartStd7} + {$UNDEF TeeChartStd} +{$ENDIF} + +{$IFDEF TeeChartStd8} + {$UNDEF TeeChartStd} +{$ENDIF} + +{$IFDEF TeeChart4} + {$UNDEF TeeChartStd} + {$DEFINE TeeChartPro} +{$ENDIF} + +{$IFDEF TeeChart5} + {$UNDEF TeeChartStd} + {$DEFINE TeeChartPro} +{$ENDIF} + +{$IFDEF TeeChart6} + {$UNDEF TeeChartStd} + {$DEFINE TeeChartPro} +{$ENDIF} + +{$IFDEF TeeChart7} + {$UNDEF TeeChartStd} + {$DEFINE TeeChartPro} +{$ENDIF} + +{$IFDEF TeeChart8} + {$UNDEF TeeChartStd} + {$DEFINE TeeChartPro} +{$ENDIF} diff --git a/official/4.8.11/Source/trees.zobj b/official/4.8.11/Source/trees.zobj new file mode 100644 index 0000000..8406014 Binary files /dev/null and b/official/4.8.11/Source/trees.zobj differ diff --git a/official/4.8.11/Source/wizstyle.xml b/official/4.8.11/Source/wizstyle.xml new file mode 100644 index 0000000..799535e --- /dev/null +++ b/official/4.8.11/Source/wizstyle.xml @@ -0,0 +1,35 @@ + + + + + + + diff --git a/official/4.8.11/changes.txt b/official/4.8.11/changes.txt new file mode 100644 index 0000000..ad81e59 --- /dev/null +++ b/official/4.8.11/changes.txt @@ -0,0 +1,372 @@ +current version +--------------- +- fixed bug in PDF export (file structure) +- fixed bug with pictures in Open Office Writer (odt) export +- [enterprise] fixed bug with TfrxReportServer component in Delphi 2010 ++ added support of new unicode-PDF export in D4-D6 and BCB4-BCB6 + +version 4.8 +--------------- ++ added support of Embarcadero Rad Studio 2010 (Delphi/C++Builder) ++ added TfrxDBDataset.BCDToCurrency property ++ added TfrxReportOptions.HiddenPassword property to set password silently from code ++ added TfrxADOConnection.OnAfterDisconnect event ++ added TfrxDesigner.MemoParentFont property ++ added new TfrxDesignerRestriction: drDontEditReportScript and drDontEditInternalDatasets ++ adedd checksum calculating for 2 5 interleaved barcode ++ added TfrxGroupHeader.ShowChildIfDrillDown property ++ added TfrxMailExport.OnSendMail event ++ added RTF 4.1 support for TfrxRichText object ++ [enterprise] added Windows Authentification mode ++ added confirmation reading for TfrxMailExport ++ added TimeOut field to TfrxMailExport form ++ added ability to use keeping(KeepTogether/KeepChild/KeepHeader) in multi-column report ++ added ability to split big bands(biggest than page height) by default +* [enterprise] improved CGI for IIS/Apache server +* changed PDF export (D7 and upper): added full unicode support, improved performance, decreased memory requirements + old PDF export engine saved in file frxExportPDF_old.pas +- changed inheritance mechanism, correct inherits of linked objects (fixups) +- fixed bug with Mirror Mrgins in RTF, HTML, XLS, XML, OpenOffice exports +- fixed bug when cross tab cut the text in corner, when corner height greater than column height +- [fs] improved script compilation +- improved WatchForm TListBox changet to TCheckListBox +- improved AddFrom method - copy outline +- Improved functional of vertical bands, shows memos placed on H-band which doesn't across VBand, also calculate expression inside it and call events (like in FR2) +- Improved unsorted mode in crosstab(join same columns correctly) +- Improved converter from Report Builder +- Improved TfrxDesigner.OnInsertObject, should call when drag&drop field from data tree +- improved DrillDownd mechanism, should work correct with master-detail-subtetail nesting +- fixed bug with DownThenAcross in Cross Tab +- fixed several bugs under CodeGear RAD Studio (Delphi/C++Builder) 2009 +- fixed bug with emf in ODT export +- fixed bug with outline when build several composite reports in double pass mode +- fixed bug when group doesn't fit on the whole page +- fixed "Page" and "Line" variables inside vertical bands +- fixed bug with using KeepHeader in some cases +- fixed bug with displacement of subreport when use PrintOnParent property in some cases +- fixed small memory leak in subreports +- fixed problem with PageFooter and ReportSymmary when use PrintOnPreviousPage property +- fixed bug when designer shows commented functions in object inspector +- fixed bug when designer place function in commented text block +- fixed bug when Engine try to split non-stretcheable view and gone to endless loop +- fixed bug with HTML tags in memo when use shot text and WordWrap +- [enterprise] fixed bug with variables lost on refresh/export +- fixed bug whih PDF,ODT export in Delphi4 and CBuilder4 +- fixed bug with some codepage which use two bytes for special symbols (Japanese ans Chinese codepages) +- fixed bug when engine delete first space from text in split Memo +- fixed bug in multi-column page when band overlap stretched PageHeader +- fixed bug with using ReprintOnNewPage + +version 4.7 +--------------- ++ CodeGear RAD Studio (Delphi/C++Builder) 2009 support ++ [enterprise] enchanced error description in logs ++ added properties TfrxHTMLExport.HTMLDocumentBegin: TStrings, + TfrxHTMLExport.HTMLDocumentBody: TStrings, TfrxHTMLExport.HTMLDocumentEnd: TStrings ++ improved RTF export (with line spacing, vertical gap etc) ++ added support of Enhanced Metafile (EMF) images in Rich Text (RTF), Open Office (ODS), Excel (XLS) exports ++ added OnAfterScriptCompile event ++ added onLoadRecentFile Event ++ added C++ Builder demos ++ added hot-key Ctrl + mouseWheel - Change scale in designer ++ added TfrxMemoView.AnsiText property +- fixed bug in RTF export with EMF pictures in OpenOffice Writer +- fixed some multi-thread isuues in engine, PDF, ODF exports +- [enterprise] fixed integrated template of report navigator +- [enterprise] fixed bug with export in Internet Explorer browser +- fixed bug with font size of dot-matix reports in Excel and XML exports +- fixed bug in e-mail export with many addresses +- fixed bug in XLS export (with fast export unchecked and image object is null) +- [enterprise] fixed bug in TfrxReportServer.OnGetVariables event +- fixed bug in Calcl function +- fixed memory leak in Cross editor +- fixed progress bar and find dialog bug in DualView +- fixed bug in PostNET and ean13 barcodes +- fixed bug with TruncOutboundText in Dot Matrix report +- fixed bugs with break points in syntaxis memo +- improved BeforeConnect event in ADO +- fixed bug in inhehited report with internal dataset +- fixed bug in TfrxPanelControl with background color(Delphi 2005 and above) + + +version 4.6 +--------------- ++ added & , < , > to XML reader ++ added tag, the text concluded in tag is not broken by WordWrap, it move entirely ++ added ability to move band without objects (Alt + Move) ++ added ability to output pages in the preview from right to left ("many pages" mode), for RTL languages(PreviewOptions.RTLPreview) ++ added ability to storing picture cache in "temp" file (PreviewOptions.PictureCacheInFile) ++ added EngineOptions.UseGlobalDataSetList (added for multi-thread applications) - set it to False if you don't want use Global DataSet list(use Report.EnabledDataSet.Add() to add dataset in local list) ++ added new property Hint for all printed objects, hints at the dialog objects now shows in StatusBar ++ added new property TfrxDBLookupComboBox.AutoOpenDataSet (automatically opens the attached dataset after onActivate event) ++ added new property TfrxReportPage.PageCount like TfrxDataBand.RowCount ++ added new property WordWrap for dialog buttons (Delphi 7 and above). ++ added sort by name to data tree ++ added TfrxDesigner.TemplatesExt property ++ added TfrxStyles class in script rtti ++ changes in the Chart editor: ability to change the name of the series, ability to move created series, other small changes ++ [enterprise] added configurations values refresh in run-time ++ [enterprise] added new demo \Demos\ClientServer\ISAPI ++ [enterprise] added output to server printers from user browser (see config.xml "AllowPrint", set to "no" by default), note: experimental feature ++ [enterprise] added reports list refresh in run-time ++ [enterprise] added templates feature ++ [enterprise] improved speed and stability ++ [fs] added TfsScript.IncludePath property ++ [fs] added TfsScript.UseClassLateBinding property ++ [fs] fixed type casting from variant(string) to integer/float +- changes in report inherit: FR get relative path from current loaded report(old reports based on application path works too) +- corrected module for converting reports from Report Builder +- fixed bug in CrossTab when set charset different from DEFAULT_CHARSET +- fixed bug in RTF export with some TfrxRichView objects +- fixed bug when print on landscape orientation with custom paper size +- fixed bug when use network path for parent report +- fixed bug with Band.Allowslit = True and ColumnFooter +- fixed bug with drawing subreport on stretched band +- fixed bug with embedded fonts in PDF export +- fixed bug with long ReportTitle + Header + MaterData.KeepHeader = true +- fixed bug with minimizing of Modal designer in BDS2005 and above +- fixed bug with paths in HTML export +- fixed bug with RTL in PDF export +- fixed bug with SubReport in multi column page +- fixed bug with Subreport.PrintOnParent = true in inherited report +- fixed bug with SYMBOL_CHARSET in PDF export +- fixed bug with the addition of datasets by inheritance report +- fixed bug with width calculation when use HTML tags in memo +- fixed compatibility with WideStrings module in BDS2006/2007 +- fixed flicking in preview when use OnClickObject event +- fixed free space calculation when use PrintOnPreviousPage +- fixed preview bug with winXP themes and in last update +- fixed subreports inherit +- Thumbnail and Outline shows at right side for RTL languages +- [fs] fixed bug with late binding + +version 4.5 +--------------- ++ added ConverterRB2FR.pas unit for converting reports from Report Builder to Fast Report ++ added ConverterQR2FR.pas unit for converting reports from QuickReport to FastReport ++ added support of multiple attachments in e-mail export (html with images as example) ++ added support of unicode (UTF-8) in e-mail export ++ added ability to change templates path in designer ++ added OnReportPrint script event ++ added PNG support in all version (start from Basic) ++ added TfrxDMPMemoView.TruncOutboundText property - truncate outbound text in matrix report when WordWrap=false ++ added new frames styles fsAltDot and fsSquare ++ added new event OnPreviewDblClick in all TfrxView components ++ added ability to call dialogs event after report run when set DestroyForms = false ++ added ability to change AllowExpressions and HideZeros properties in cross Cells (default=false) ++ added IgnoreDupParams property to DB components ++ added auto open dataset in TfrxDBLookupComboBox ++ added new property TfrxADOQuery.LockType ++ added define DB_CAT (frx.inc) for grouping DB components ++ added TfrxPictureView.HightQuality property(draw picture in preview with hight quality, but slow down drawing procedure) ++ [FRViewer] added comandline options "/print filename" and "/silent_print filename" ++ added unicode input support in RichEditor ++ added new define HOOK_WNDPROC_FOR_UNICODE (frx.inc) - set hook on GetMessage function for unicode input support in D4-D7/BCB4-BCB6 ++ added ability chose path to FIB packages in "Recompile Wizard" ++ added new function TfrxPreview.GetTopPosition, return a position on current preview page ++ added new hot-keys to Code Editor - Ctrl+Del delete the word before cursor, Ctrl+BackSpace delete the word after cursor(as in Delhi IDE) ++ added "MDI Designer" example +- all language resources moved to UTF8, XML +- fixed bug with html tags [sup] and [sub] +- fixed width calculation in TfrxMemoView when use HTML tags +- fixed bug with suppressRepeated in Vertical bands +- fixed bug when designer not restore scrollbars position after undo/redo +- fixed visual bug in toolbars when use Windows Vista + XPManifest + Delphi 2006 +- fixed bug in CalcHeight when use negative LineSpace +- fixed bug in frx2xto30 when import query/table components, added import for TfrDBLookupControl component +- fixed bug with Cross and TfrxHeader.ReprintOnNewPage = true +- fixed converting from unicode in TfrxMemoView when use non default charset +- [fs] fixed bug with "in" operator +- fixed bug with aggregate function SUM +- fixed bug when use unicode string with [TotalPages#] in TfrxMemoView +- fixed bug with TSQLTimeStampField field type +- fixed designer dock-panels("Object Inspector", "Report Tree", "Data Tree") when use designer as MDI or use several non-modal designer windows +- fixed bug with hide/show dock-panels("Object Inspector", "Report Tree", "Data Tree"), now it restore size after hiding +- fixed bug in XML/XLS export - wrong encode numbers in memo after CR/LF +- fiexd bug in RTF export +- fixed bug with undo/redo commands in previewPages designer +- fixed bug with SuppressRepeated when use KeepTogether in group +- fixed bug with SuppressRepeated on new page all events fired twice(use Engine.SecondScriptcall to determinate it) + + +version 4.4 +--------------- ++ added support for CodeGear RAD Studio 2007 ++ improved speed of PDF, HTML, RTF, XML, ODS, ODT exports ++ added TfrxReportPage.BackPictureVisible, BackPicturePrintable properties ++ added rtti for the TfrxCrossView.CellFunctions property ++ added properties TfrxPDFExport.Keywords, TfrxPDFExport.Producer, TfrxPDFExport.HideToolbar, + TfrxPDFExport.HideMenubar, TfrxPDFExport.HideWindowUI, TfrxPDFExport.FitWindow, + TfrxPDFExport.CenterWindow, TfrxPDFExport.PrintScaling ++ added ability recompile frxFIB packages in "recompile wizard" ++ added ability to set color property for all teechart series which support it ++ added, setting frame style for each frame line in style editor ++ added TfrxPreview.Locked property and TfrxPreview.DblClick event ++ added 'invalid password' exception when load report without crypt ++ added new parameter to InheritFromTemplate (by default = imDefault) imDefault - show Error dialog, imDelete - delete duplicates, imRename - rename duplicates ++ added property TfrxRTFExport.AutoSize (default is "False") for set vertical autosize in table cells +* redesigned dialog window of PDF export +* improved WYSIWYG in PDF export +- fixed bug, the PageFooter band overlap the ReportSummary band when use EndlessHeight +- fixed bug with lage paper height in preview +- fixed bug with outline and encryption in PDF export +- fixed bug with solid arrows in PDF export +- fixed bug when print TfrxHeader on a new page if ReprintOnNewPage = true and KeepFooter = True +- fixed bug when used AllowSplit and TfrxGroupHeader.KeepTogether +- fixed page numbers when print dotMatrix report without dialog +- fixed bug with EndlessHeight in multi-columns report +- fixed font dialog in rich editor +- [fs] fixed bug when create TWideStrings in script code +- fixed bug with dialog form when set TfrxButtonControl.Default property to True +- fixed twice duplicate name error in PreviewPages designer when copy - past object +- fixed bug with Preview.Clear and ZmWholePage mode +- fixed bug with using "outline" together "embedded fonts" options in PDF export +- fixed multi-thread bug in PDF export +- fixed bug with solid fill of transparent rectangle shape in PDF export +- fixed bug with export OEM_CODEPAGE in RTF, Excel exports +- fixed bug with vertical size of single page in RTF export +- fixed bug with vertical arrows in PDF export +- fixed memory leak with inherited reports + + +version 4.3 +--------------- ++ added support for C++Builder 2007 ++ added encryption in PDF export ++ added TeeChart Pro 8 support ++ added support of OEM code page in PDF export ++ added TfrxReport.CaseSensitiveExpressions property ++ added "OverwritePrompt" property in all export components ++ improved RTF export (WYSIWYG) ++ added support of thai and vietnamese charsets in PDF export ++ added support of arrows in PDF export +* at inheritance of the report the script from the report of an ancestor is added to the current report (as comments) +* some changes in PDF export core +- fixed bug with number formats in Open Document Spreadsheet export +- fixed bug when input text in number property(Object Inspector) and close Designer(without apply changes) +- fixed bug in TfrxDBDataset with reCurrent +- fixed bug with memory leak in export of empty outline in PDF format +- line# fix (bug with subreports) +- fixed bug with edit prepared report with rich object +- fixed bug with shadows in PDF export +- fixed bug with arrows in designer +- fixed bug with margins in HTML, RTF, XLS, XML exports +- fixed bug with arrows in exports +- fixed bug with printers enumeration in designer (list index of bound) +- fixed papersize bug in inherited reports + + +version 4.2 +--------------- ++ added support for CodeGear Delphi 2007 ++ added export of html tags in RTF format ++ improved split of the rich object ++ improved split of the memo object ++ added TfrxReportPage.ResetPageNumbers property ++ added support of underlines property in PDF export +* export of the memos formatted as fkNumeric to float in ODS export +- fixed bug keeptogether with aggregates +- fixed bug with double-line draw in RTF export +- fix multi-thread problem in PDF export +- fixed bug with the shading of the paragraph in RTF export when external rich-text was inserted +- fixed bug with unicode in xml/xls export +- fixed bug in the crop of page in BMP, TIFF, Jpeg, Gif +- "scale" printmode fixed +- group & userdataset bugfix +- fixed cross-tab pagination error +- fixed bug with round brackets in PDF export +- fixed bug with gray to black colors in RTF export +- fixed outline with page.endlessheight +- fixed SuppressRepeated & new page +- fixed bug with long time export in text format +- fixed bug with page range and outline in PDF export +- fixed undo in code window +- fixed error when call DesignReport twice +- fixed unicode in the cross object +- fixed designreportinpanel with dialog forms +- fixed paste of DMPCommand object +- fixed bug with the export of null images +- fixed code completion bug +- fixed column footer & report summary problem + + + +version 4.1 +--------------- ++ added ability to show designer inside panel (TfrxReport.DesignReportInPanel method). See new demo Demos\EmbedDesigner ++ added TeeChart7 Std support ++ [server] added "User" parameter in TfrxReportServer.OnGetReport, TfrxReportServer.OnGetVariables and TfrxReportServer.OnAfterBuildReport events ++ added Cross.KeepTogether property ++ added TfrxReport.PreviewOptions.PagesInCache property +- barcode fix (export w/o preview bug) +- fixed bug in preview (AV with zoommode = zmWholePage) +- fixed bug with outline + drilldown +- fixed datasets in inherited report +- [install] fixed bug with library path set up in BDS/Turbo C++ Builder installation +- fixed pagefooter position if page.EndlessWidth is true +- fixed shift bug +- fixed design-time inheritance (folder issues) +- fixed chm help file path +- fixed embedded fonts in PDF +- fixed preview buttons +- fixed bug with syntax highlight +- fixed bug with print scale mode +- fixed bug with control.Hint +- fixed edit preview page +- fixed memory leak in cross-tab + + + +version 4.0 initial release +--------------------- +Report Designer: +- new XP-style interface +- the "Data" tab with all report datasets +- ability to draw diagrams in the "Data" tab +- code completion (Ctrl+Space) +- breakpoints +- watches +- report templates +- local guidelines (appears when you move or resize an object) +- ability to work in non-modal mode, mdi child mode + +Report Preview: +- thumbnails + +Print: +- split a big page to several small pages +- print several small pages on one big +- print a page on a specified sheet (with scale) +- duplex handling from print dialogue +- print copy name on each printed copy (for example, "First copy", "Second copy") + +Report Core: +- "endless page" mode +- images handling, increased speed +- the "Reset page numbers" mode for groups +- reports crypting (Rijndael algorithm) +- report inheritance (both file-based and dfm-based) +- drill-down groups +- frxGlobalVariables object +- "cross-tab" object enhancements: + - improved cells appearance + - cross elements visible in the designer + - fill corner (ShowCorner property) + - side-by-side crosstabs (NextCross property) + - join cells with the same value (JoinEqualCells property) + - join the same string values in a cell (AllowDuplicates property) + - ability to put an external object inside cross-tab + - AddWidth, AddHeight properties to increase width&height of the cell + - AutoSize property, ability to resize cells manually +- line object can have arrows +- added TfrxPictureView.FileLink property (can contain variable or a file name) +- separate settings for each frame line (properties Frame.LeftLine, +TopLine, RightLine, BottomLine can be set in the object inspector) +- PNG images support (uncomment {$DEFINE PNG} in the frx.inc file) +- Open Document Format for Office Applications (OASIS) exports, spreadsheet (ods) and text (odt) + +Enterprise components: +- Users/Groups security support (see a demo application Demos\ClientServer\UserManager) +- Templates support +- Dynamically refresh of configuration, users/groups + diff --git a/official/4.8.11/changes_rus.txt b/official/4.8.11/changes_rus.txt new file mode 100644 index 0000000..f7c0812 --- /dev/null +++ b/official/4.8.11/changes_rus.txt @@ -0,0 +1,373 @@ +Текущая версия +--------------- +- исправлена ошибка в PDF экспорте (структура файла) +- исправлена ошибка с экспортом картинок в Open Office Writer (odt) +- [enterprise] исправлена ошибка с компонентой TfrxReportServer в Delphi 2010 ++ добавлена поддержка нового PDF экспорта в D4-D6 и BCB4-BCB6 + +Версия 4.8 +--------------- ++ добавлена поддержка Embarcadero Rad Studio 2010 (Delphi/C++Builder) ++ добавлено св-во TfrxDBDataset.BCDToCurrency ++ добавлено св-во TfrxReportOptions.HiddenPassword для возможности устанавливать пароль из кода ++ добавлено событие TfrxADOConnection.OnAfterDisconnect ++ добавлено св-во TfrxDesigner.MemoParentFont ++ добавлены новые значения для св-ва TfrxDesignerRestriction: drDontEditReportScript и drDontEditInternalDatasets ++ добавлено вычисление контрольной суммы для штрихкода 2-5 interleaved ++ добавлено св-во TfrxGroupHeader.ShowChildIfDrillDown ++ добавлено событие TfrxMailExport.OnSendMail ++ добавлена поддержка RTF 4.1 в объекте TfrxRichText ++ [enterprise] добавлен режим аутентификации Windows ++ добавлен флаг подтверждения прочтения в TfrxMailExport ++ в диалог TfrxMailExport добавленно поле TimeOut ++ добавлена возможность использования механизма "держать вместе"(KeepTogether/KeepChild/KeepHeader) в многоколоночном отчете ++ добавлена возможность разбиения больших бэндов(больше чем высота страницы) по умолчанию +* [enterprise] улучшена работа CGI совместно с серверами IIS/Apache +* изменен PDF экспорт (D7 и выше): добавлена полная поддержка Unicode, увеличена скорость работы, уменьшены требования к памяти + старый PDF экспорт сохранен в файле frxExportPDF_old.pas +- изменен механизм наследования, правильное наследование связанных объектов (fixups) +- исправлена ошибка с зеркальными полями в RTF, HTML, XLS, XML, OpenOffice экспортах +- исправлена ошибка, при которой кросс таблица обрезала текст в "углу" таблицы, когда высота "угла" больше высоты колонки +- [fs] увеличена скорость компиляции скрипта +- улучшено WatchForm: TListBox заменен на TCheckListBox +- улучшен метод AddFrom - копирование outline +- улучшен функционал вертикальных бэндов, показывает мемо поля помещенные на гориз. бэнд и которые не пересекают вертикальный бэнд, а так же вычисляет в них значения и обрабатывает события(как в FR2) +- улучшен режим без сортировки в кросс таблице(объединяет колонки корректно) +- улучшен конвертер из Report Builder +- улучшено событие TfrxDesigner.OnInsertObject, должно вызываться при перетаскивании полей из дерева данных +- улучшен механизм дрилл-даунов, должен корректно работать с master-detail-subdetail отчетами +- исправлена ошибка использования DownThenAcross в кросс таблице +- исправлено несколько ошибок под CodeGear RAD Studio (Delphi/C++Builder) 2009 +- исправлена ошибка с emf в ODT экспорте +- исправлена ошибка с некорректным отображением outline при построении нескольких составных отчетов с использованием двухпроходного режима +- исправлена ошибка, когда группа не вмещается на пустую страницу и переносится +- исправлена ошибка с переменными "Page" и"Line" в вертикальных бэндах +- исправлена ошибка, возникающая при использовании св-ва KeepHeader +- исправлена ошибка со смещением вложенных отчетов при использовании св-ва PrintOnParent +- исправлена небольшая утечка памяти во вложенных отчетах +- исправлена проблема при использовании PageFooter и ReportSymmary вместе со св-вом PrintOnPreviousPage +- исправлена ошибка, когда дизайнер показывал закомментированные функции в инспекторе объектов +- исправлена ошибка, когда дизайнер вставлял код события в закомментированный блок +- исправлена ошибка, когда движок пытался перенести большие неразрываемые объекты и "уходил" в бесконечный цикл +- исправлена ошибка с использованием HTML тэгов в мемо вместе с WordWrap на коротком тексте +- [enterprise] исправлена ошибка с потерей параметров при обновлении/экспорте отчета +- исправлена ошибка экспорта в PDF для Delphi4 +- исправлена ошибка с неправильным отображением некоторых кодовых страниц, которые используют 2 байта для спец. символов (Японские и Китайские кодовые страницы) +- исправлена ошибка удаления первого пробела из текста в "разрываемом" memo +- исправлена ошибка с многоколоночной страницей, когда бэнд перекрывал PageHeader +- исправлена ошибка использования опции ReprintOnNewPage +- внесены незначительные изменения в лицензионное соглашение + + +Версия 4.7 +-------------- ++ поддержка CodeGear RAD Studio (Delphi/C++Builder) Delphi 2009 ++ [enterprise] расширенное описание ошибок в логах ++ добавлены свойства TfrxHTMLExport.HTMLDocumentBegin: TStrings, + TfrxHTMLExport.HTMLDocumentBody: TStrings, TfrxHTMLExport.HTMLDocumentEnd: TStrings ++ улучшен RTF экспорт (межстрочный интервал и т.д.) ++ добавлена поддержка изображений Enhanced Metafile (EMF) в RTF, Open Office (ODS), Excel (XLS) экспортах ++ добавлено событие OnAfterScriptCompile ++ добавлено событие onLoadRecentFile ++ добавлен hot-key Ctrl + mouseWheel - изменяет масштаб в дизайнере ++ добавлено св-во TfrxMemoView.AnsiText ++ добавлены примеры для C++ Builder +- исправлена ошибка в RTF экспорте с EMF изображениями в OpenOffice Writer +- исправлены некоторые многопоточные моменты в ядре, PDF, ODF экспортах +- [enterprise] исправлена ошибка с интегрированным шаблоном навигатора отчета +- [enterprise] исправлена ошибка с экспортом в браузере Internet Explorer +- исправлена ошибка с размером шрифта матричных отчетов в Excel и XML экспортах +- исправлена ошибка в e-mail экспорте с несколькими адресами +- исправлена ошибка в XLS экспорте (с выключенным быстрым экспортом и объектом image равным null) +- [enterprise] исправлена ошибка в обработке события TfrxReportServer.OnGetVariables +- исправлена ошибка в функции Calcl +- исправлена утечка памяти в редакторе CrossTab +- исправлена ошибка отображения некоторых диалогов в режиме DualView +- исправлена ошибка в PostNET и ean13 штрихкодах +- исправлена ошибка при использовании TruncOutboundText в матричных отчетов +- исправлена ошибка с точками останова в синтаксис мемо +- улучшенно событие OnBeforeConnect в ADO компонентах +- исправлена ошибка при наследовании отчетов в встроенных DB компонентах +- исправлена ошибка с фоновым цветом в TfrxPanelControl(Delphi 2005 и выше) + +Версия 4.6 +-------------- ++ добавлен новый тег , текст заключенный в тег не разбивается WordWrap, а переносится целиком ++ добавлена возможность "сортировать по имени" в дереве данных ++ добавлена возможность вывода страниц в предпросмотре справа налево (в режиме много страниц), для RTL языков ++ добавлена возможность перемещать бенд без объектов (Alt + Move) ++ добавлена возможность сохранения кэша изображений в "temp" файл (PreviewOptions.PictureCacheInFile) ++ добавлено новое свойство TfrxReportPage.PageCount аналогично TfrxDataBand.RowCount ++ добавлено св-во EngineOptions.UseGlobalDataSetList (для многопоточных приложений ) - установите св-во в True, если не нужно использовать Глобальный список DataSet (используйте Report.EnabledDataSet.Add () для добавления данных в локальный список) ++ добавлено св-во Hint для всех печатаемых объектов, подсказки у диалоговых объектов теперь отображаются и в StatusBar ++ добавлено св-во TfrxDBLookupComboBox.AutoOpenDataSet (автоматически открывает присоединенный датасет после события onActivate диалога ) ++ добавлено св-во WordWrap для диалоговых кнопок (Delphi 7 и выше) ++ добавлено св-воTfrxDesigner.TemplatesExt ++ добавлены & , < , > в XML reader ++ изменения в редакторе диаграмм: возможность изменять имя серий, возможность перемещать созданные серии, небольшие исправления ++ Класс TfrxStyles зарегистрирован в скрипте ++ [enterprise] добавлена экспериментальная возможность печати на принтеры, подключенные к серверу + (config.xml "AllowPrint", установлено в "no" по умолчанию) ++ [enterprise] добавлена поддержка шаблонов (папка "templates"), внимание: все файлы шаблонов записаны в кодировке UTF8 ++ [enterprise] добавлено автообновление параметров конфигурации ++ [enterprise] добавлено автообновление списка отчетов ++ [enterprise] добавлено новое демо \Demos\ClientServer\ISAPI ++ [enterprise] улучшены быстродействие и стабильность ++ [fs] добавлено св-во TfsScript.IncludePath ++ [fs] добавлено св-во TfsScript.UseClassLateBinding ++ [fs] Исправлена ошибка в приведении типов из Variant(string) к Integer / Float +- исправлена ошибка при выводе subreport на растягиваемом бенде +- исправлена ошибка при использовании Band.Allowslit = True и TfrxColumnFooter +- исправлена ошибка при использовании charset в Кросс таблице отличной от DEFAULT_CHARSET +- исправлена ошибка при печати на альбомной ориентации с пользовательским размером бумаги +- исправлена ошибка с использованием сетевых путей в наследовании отчета +- исправлена совместимость с модулем WideStrings в BDS2006/2007 +- исправлено вычисление свободного пространства на странице при использовании PrintOnPreviousPage +- Thumbnail и Outline показываются справа для RTL языков +- [fs] исправлена ошибка с поздним связыванием +- изменения в наследовании отчетов: пути к шаблону потомку теперь записываются относительно текущего отчета (старые отчеты, в которых использовались пути относительно приложении тоже будут работать) +- исправлен модуль для конвертации отчетов из Report Builder +- исправлена ошибка в RTF экспорте с некоторыми TfrxRichView объектами +- исправлена ошибка в наследование subreports +- исправлена ошибка в предпросмотре с темами winXP в последнем обновлении +- исправлена ошибка вычислений ширины при использовании HTML тегов в мемо +- исправлена ошибка мерцания предпросмотра при использовании события OnClickObject +- исправлена ошибка при минимизации модального дизайнера в BDS2005 и выше +- исправлена ошибка с RTL в PDF экспорте +- исправлена ошибка с SubReport при использовании многоколоночной страницы +- исправлена ошибка с Subreport.PrintOnParent = True в наследованных отчетах +- исправлена ошибка с SYMBOL_CHARSET в PDF экспорте +- исправлена ошибка с внедренными шрифтами в PDF экспорте +- исправлена ошибка с длинными ReportTitle + Header + MaterData.KeepHeader = True +- исправлена ошибка с добавлением датасетов при наследовании отчета +- исправлена ошибка с путями в HTML экспорте + +Версия 4.5 +-------------- ++ добавлен модуль ConverterRB2FR.pas для конвертации отчетов из Report Builder ++ добавлен модуль ConverterQR2FR.pas для конвертации отчетов из QuickReport ++ добавлена поддержка нескольких приложений в e-mail экспорте (например html с картинками) ++ добавлена поддержка юникода (UTF-8) в e-mail экспорте ++ добавлена возможность изменять путь к шаблонам в дизайнере (вкладка наследования отчета) ++ добавлено скриптовое событие OnReportPrint ++ добавлена поддержка PNG во все версии (начиная с Basic) ++ добавлено св-во TfrxDMPMemoView.TruncOutboundText - обрезает текст выходящий за границы объекта в матричном отчете когда WordWrap=false ++ добавлены новые стили рамки fsAltDot и fsSquare ++ добавлено новое событие OnPreviewDblClick для всех компонентов TfrxView ++ добавлена возможность вызывать события диалоговых форм после построения отчета, DestroyForms должен быть установлен в false ++ добавлена возможность изменять св-ва AllowExpressions и HideZeros в ячейках CrossTab (по умолчанию = false) ++ добавлено св-во IgnoreDupParams для DB компонентов ++ добавлена авто-открытие датасета у TfrxDBLookupComboBox ++ добавлено св-во TfrxADOQuery.LockType ++ добавлен новый define DB_CAT (frx.inc) для группировки DB компонентов ++ добавлено св-во TfrxPictureView.HightQuality (отображает рисунок в предпросмотре более качественно, но снижает скорость отрисовки) ++ [FRViewer] добавлены параметры командной строки "/print filename" и "/silent_print filename" ++ добавлена поддержка ввода юникода в "Rich Editor" ++ добавлен новый define HOOK_WNDPROC_FOR_UNICODE (frx.inc) - устанавливает хук на функцию GetMessage для поддержки ввода юникода в D4-D7/BCB4-BCB6 ++ добавлена возможность выбора пути к пакетам FIB в "Recompile Wizard" ++ добавлена новая функция TfrxPreview.GetTopPosition, возвращает позицию на текущей странице ++ добавлены новые "горячие - клавиши" в "Редактор кода" : Ctrl+Del - удаляет слово перед курсором, Ctrl+BackSpace - удаляет слово после курсора(как в Delhi IDE) ++ добавлен пример "MDI Designer" +- все языковые ресурсы перенесены в UTF8, XML +- исправлена ошибка с HTML- тегами [sup] и [sub] +- исправлена ошибка при вычислении ширены в TfrxMemoView, при использовании HTML тегов +- исправлена ошибка с suppressRepeated в вертикальных бэндах +- исправлена ошибка когда дизайнер не восстанавливал позиции полос прокрутки после команд undo/redo +- исправлена визуальная ошибка в панели при использовании Windows Vista + XPManifest + Delphi 2006 +- исправлена ошибка в CalcHeight при использовании отрицательного LineSpace +- исправлена ошибка в frx2xto30 при импорте компонента запроса/таблицы, добавлен импорт компонента TfrDBLookupControl +- исправлена ошибка при использовании CrossTab и TfrxHeader.ReprintOnNewPage = True +- исправлена ошибка с исчезновением символа переноса (WordBreak) при разрыве TfrxMemoView или использовании FlowTo +- исправлено конвертирование из юникода в TfrxMemoView когда используется charset не по умолчанию +- [fs] исправлена ошибка с оператором "in" +- исправлена ошибка с агрегатной функцией SUM +- исправлена ошибка при использовании юникода вместе с [TotalPages#] в TfrxMemoView +- исправлена ошибка с типом поля TSQLTimeStampField +- исправлена ошибка док-панелей ("Object Inspector", "Report Tree", "Data Tree") при использовании дизайнера как MDI или при использовании нескольких не модальнх дизайнеров +- исправлена ошибка при скрытии/показе док-панелей ("Object Inspector", "Report Tree", "Data Tree"), теперь после скрытия восстанавливается их размер +- исправлена ошибка в XML/XLS экспорте - неверная кодировка цифр после переноса строки +- исправлена ошибка в RTF экспорте +- исправлена ошибка с командами undo/redo в дизайнере при редактировании PreviewPages +- исправлена ошибка с SuppressRepeated при использовании KeepTogether в группе +- исправлена ошибка с SuppressRepeated, на новой странице все события вызывались дважды(используйте Engine.SecondScriptCall чтобы определить повторный вызов) + + +Версия 4.4 +-------------- ++ добавлена поддержка CodeGear RAD Studio 2007 ++ увеличена скорость PDF, HTML, RTF, XML, ODS, ODT экспортов ++ добавлены свойства TfrxReportPage.BackPictureVisible, BackPicturePrintable ++ добавлен доступ к свойству TfrxCrossView.CellFunctions из скрипта ++ добавлены свойства TfrxPDFExport.Keywords, TfrxPDFExport.Producer, TfrxPDFExport.HideToolbar, + TfrxPDFExport.HideMenubar, TfrxPDFExport.HideWindowUI, TfrxPDFExport.FitWindow, + TfrxPDFExport.CenterWindow, TfrxPDFExport.PrintScaling ++ добавлена возможность перекомпиляции пакетов frxFIB из "recompile wizard" ++ добавлена возможность устанавливать цвет для всех серий TeeChart, которые это поддерживают ++ добавлена возможность устанавливать стили рамки для каждой линии в редакторе стилей ++ добавлено св-во TfrxPreview.Locked и событие TfrxPreview.DblClick ++ добавлено исключение "invalid password", при загрузке не зашифрованного отчета ++ добавлен новый параметр у функции InheritFromTemplate (по умолчанию = imDefault) imDefault - показать диалог с ошибкой, imDelete - удалить дубликаты, imRename - переименовать дубликаты ++ добавлено свойство TfrxRTFExport.AutoSize (по умолчанию "False") для включения авторазмера по вертикали у ячеек таблиц +* переработано диалоговое окно PDF экспорта +* улучшен WYSIWYG в PDF экспорте +- исправлена ошибка с смещением бэндов PageFooter и ReportSummary при использовании EndlessHeight +- исправлена ошибка с большой высотой страницы в предпросмотре +- исправлена ошибка с одновременным использованием оглавления и шифрования в PDF экспорте +- исправлена ошибка с залитыми стрелками (solid arrows) в PDF экспорте +- исправлена ошибка печати TfrxHeader на новой странице если ReprintOnNewPage=true и KeepFooter=True +- исправлена ошибка при использовании AllowSplit и TfrxGroupHeader.KeepTogether +- исправлена ошибка c номерами страниц при печати dotMatrix отчета без диалогов +- исправлена ошибка с EndlessHeight в мульти-колоночном отчете +- исправлена ошибка при изменении шрифта у TfrxRichView +- [fs] исправлена ошибка при создании TWideStrings из скрипта +- исправлена ошибка с диалоговой формой когда св-во TfrxButtonControl.Default установлено в True +- исправлено двукратный вызов ошибки "duplicate name" в дизайнере страниц сформированного отчета, при копировании-вставке объекта +- исправлена ошибка с TfrxPreview.Clear и режимом ZmWholePage +- исправлена ошибка в PDF экспорте при использовании одновременно опций "outline" и "embedded fonts" +- исправлена ошибка с многопоточностью в PDF экспорте +- исправлена ошибка с заливкой прозрачного прямогольника в PDF экспорте +- исправлена ошибка с экспортом OEM_CODEPAGE в RTF, Excel +- исправлена ошибка с вертикальным размером одной страницы в RTF экспорте +- исправлена ошибка с вертикальными стрелками в PDF экспорте +- исправлена утечка памяти с наследуемыми отчетами + +Версия 4.3 +-------------- ++ добавлена поддержка шифрования в PDF экспорте ++ добавлена поддержка TeeChart Pro 8 ++ добавлена поддержка кодовой страницы OEM в PDF экспорте ++ добавлено св-во TfrxReport.CaseSensitiveExpressions ++ добавлена поддержка C++Builder 2007 ++ добавлено свойство "OverwritePrompt" во все компоненты экспорта ++ улучшен RTF экспорт (WYSIWYG) ++ добавлена поддержка тайской и вьетнамской кодировок в PDF экспорте ++ добавлена поддержка стрелок в PDF экспорте +* при наследовании отчета скрипт из отчета предка добавляется к текущему отчету (закомментированный) +* небольшие изменения в ядре PDF экспорта +- исправлена ошибка при форматировании чисел в Open Document Spreadsheet экспорте +- исправлена ошибка при вводе текстовых данных в числовое поле(Object Inspector) и закрытие дизайнера (без применения изменений) +- исправлена ошибка в TfrxDBDataset с установленным reCurrent +- исправлена ошибка с утечкой памяти при экспорте пустого outline в PDF формат +- исправлена ошибка с line# (с subreports) +- ошибка с редактированием готового отчета, содержащего rich объект +- исправлена ошибка с экспортом теней в PDF экспорте +- исправлена ошибка с рисованием стрелок в дизайнере +- исправлена ошибка с полями в HTML, RTF, XLS, XML экспортах +- исправлена ошибка с экспортом стрелок в различные форматы +- исправлена ошибка с определением принтеров при открытии дизайнера (list index of bound) +- исправлена ошибка с размером страницы в наследованных отчетах + +Версия 4.2 +-------------- ++ добавлена поддержка CodeGear Delphi 2007 ++ добавлен экспорт html тегов в формат RTF ++ улучшено разбиение объекта "Rich" на страницы ++ улучшено разбиение объекта "Текст" на страницы ++ добавлено свойство TfrxReportPage.ResetPageNumbers ++ добавлена поддержка экспорта underlines в формат PDF +* экспорт текстовых полей с форматом fkNumeric как чисел в ODS экспорт +- исправлена ошибка keeptogether с агрегатными ф-ями +- исправлена ошибка с экспортом двойных линий в RTF +- исправлена ошибка с мультипоточностью в PDF экспорте +- исправлена ошибка с цветом фона абзаца в RTF экспорте +- исправлена ошибка с юникодом в xml/xls экспорте +- исправлена ошибка с обрезанием страниц в экспортах BMP, TIFF, Jpeg, Gif +- исправлена ошибка режима печати "масштабирование" +- исправлена ошибка группы с userdataset +- исправлена ошибка разбиения cross-tab на страницы +- исправлена ошибка с круглыми скобками в PDF экспорте +- исправлена ошибка с изменением серого цвета в черный в RTF экспорте +- исправлена ошибка outline с page.endlessheight +- исправлена ошибка с зависанием при экспорте в текстовый формат некоторых отчетов +- исправлена ошибка с диапазоном страниц и outline в PDF экспорте +- исправлена ошибка с вызовом DesignReport дважды +- исправлена ошибка undo в окне кода +- исправлена поддержка unicode в cross объекте +- исправлен метод designreportinpanel с диалоговыми формами +- исправлена ошибка копирования DMPCommand в буфер обмена +- исправлена ошибка с экспортом null изображений +- исправлена ошибка code completion +- исправлена ошибка column footer & report summary + + +Версия 4.1 +-------------- ++ добавлена возможность показа дизайнера в панели (метод TfrxReport.DesignReportInPanel). См. демо Demos\EmbedDesigner ++ добавлена поддержка TeeChart7 Std ++ [server] добавлен параметр "User" в события TfrxReportServer.OnGetReport, TfrxReportServer.OnGetVariables и TfrxReportServer.OnAfterBuildReport ++ добавлено свойство Cross.KeepTogether ++ добавлено свойство TfrxReport.PreviewOptions.PagesInCache +- исправлена ошибка в штрихкоде (при экспорте без превью) +- исправлена ошибка в preview (AV при zoommode = zmWholePage) +- исправлена ошибка с outline + drilldown +- исправлена ошибка с датасетами в наследованном отчете +- [install] исправлена ошибка с настройкой library path при установке в BDS/Turbo C++ Builder +- исправлена позиция pagefooter если page.EndlessWidth = true +- исправлена ошибка сдвига объектов +- исправлено наследование в design-time (ошибка с путями) +- исправлена ошибка с chm help в дизайнере +- исправлена ошибка в PDF (встраивание шрифтов) +- исправлены кнопки превью +- исправлена ошибка с подсветкой синтаксиса +- исправлена ошибка в режиме print scale +- исправлена ошибка с control.Hint +- исправлена ошибка редактирования в режиме превью +- исправлена утечка в cross-tab + + +Версия 4.0 релиз +----------- + +Дизайнер: +- оформление интерфейса в стиле XP +- закладка "Data" со всеми источниками данных отчета +- рисование диаграмм в закладке "Data" +- code completion (Ctrl+Space) +- точки останова +- watches +- шаблоны отчетов +- локальные выносные линии (появляются при перемещении или изменении +размеров объекта) +- возможность немодальной работы, mdi child + +Предварительный просмотр: +- эскизы страниц + +Печать: +- разрезание страниц при печати на меньший размер бумаги +- печать нескольких страниц на одной большой +- печать с масштабированием +- управление дуплексом из диалога печати +- печать имени копии на каждой копии документа (например, "Первая копия", "Вторая копия") + +Ядро: +- режим "бесконечная страница" +- увеличена скорость работы с изображениями +- режим "reset page numbers" для групп +- шифрация файлов отчета (Rijndael алгоритм) +- наследование отчетов (в файлах и формах dfm) +- drill-down отчеты +- объект frxGlobalVariables +- улучшения в объекте "cross-tab" + - улучшенное управление ячейками + - элементы показываются в дизайнере + - заполнение угла таблицы (св-во ShowCorner) + - несколько кроссов в ширину (св-во NextCross) + - объединение одинаковых ячеек (св-во JoinEqualCells) + - объединение одинаковых строковых значений внутри ячейки (св-во AllowDuplicates) + - возможность вывода посторонних объектов внутри кросс-таблицы + - свойства AddWidth, AddHeight для увеличения ширины и высоты ячейки + - свойство AutoSize, возможность менять размеры ячеек вручную +- объект "Линия" может иметь стрелки +- добавлено св-во TfrxPictureView.FileLink (может содержать переменную или +имя файла) +- индивидуальное оформление каждой линии рамки (свойства Frame.LeftLine, +TopLine, RightLine, BottomLine - настраиваются в инспекторе) +- поддержка PNG изображений (раскомментируйте {$DEFINE PNG} в файле frx.inc) +- поддержка экспорта в формат Open Document Format for Office Applications (OASIS), таблиц (ods) и текстовых документов (odt) + +Enterprise компоненты: +- Поддержка разграничения доступа на основе политики Пользователей/Групп (добавлено новое demo) +- Поддержка шаблонов +- Динамическое обновление конфигурации, списка пользователей/групп + diff --git a/official/4.8.11/frx_icon.ico b/official/4.8.11/frx_icon.ico new file mode 100644 index 0000000..3838d05 Binary files /dev/null and b/official/4.8.11/frx_icon.ico differ diff --git a/official/4.8.11/recompile.exe b/official/4.8.11/recompile.exe new file mode 100644 index 0000000..ef12c81 Binary files /dev/null and b/official/4.8.11/recompile.exe differ