From be8eb716378570701297a9a00cedf2b9f137c6af Mon Sep 17 00:00:00 2001 From: FChrisF Date: Tue, 1 Mar 2016 14:27:02 +0100 Subject: [PATCH] Version 1.01 --- README.md | 27 +- README.txt | 294 +++++-- demo/Delphi/LLCLTest.dof | 8 +- demo/Delphi/Unit1.pas | 11 +- demo/FPC/unit1.lfm | 2 +- demo/FPC/unit1.pas | 11 +- sources/Classes.pas | 123 +-- sources/ClipBrd.pas | 193 +++++ sources/ComCtrls.pas | 27 +- sources/Controls.pas | 405 ++++++---- sources/Dialogs.pas | 54 +- sources/ExtCtrls.pas | 28 +- sources/FileCtrl.pas | 117 +++ sources/FileUtil.pas | 5 +- sources/Forms.pas | 23 +- sources/Graphics.pas | 465 ++++++++--- sources/Grids.pas | 1527 ++++++++++++++++++++++++++++++++++++ sources/IniFiles.pas | 155 ++++ sources/Interfaces.pp | 5 +- sources/LCLIntF.pas | 110 +++ sources/LCLType.pp | 40 +- sources/LLCLFPCInc.inc | 29 +- sources/LLCLOSInt.pas | 1048 ++++++++++++++++++++++--- sources/LLCLOptions.inc | 150 +++- sources/LLCLPng.pas | 892 +++++++++++++++++++++ sources/LLCLZlib.pas | 464 +++++++++++ sources/LMessages.pp | 40 +- sources/LazFileUtils.pas | 5 +- sources/LazUTF8.pas | 67 +- sources/LazUTF8Classes.pas | 5 +- sources/Menus.pas | 5 +- sources/StdCtrls.pas | 165 ++-- sources/SysUtils.pas | 137 ++-- sources/Variants.pas | 5 +- sources/XPMan.pas | 5 +- 35 files changed, 5904 insertions(+), 743 deletions(-) create mode 100644 sources/ClipBrd.pas create mode 100644 sources/FileCtrl.pas create mode 100644 sources/Grids.pas create mode 100644 sources/IniFiles.pas create mode 100644 sources/LCLIntF.pas create mode 100644 sources/LLCLPng.pas create mode 100644 sources/LLCLZlib.pas diff --git a/README.md b/README.md index 4195cea..ca37381 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ while being compatible with - a part of - the LCL/VCL. It may concern for instance: small installation or configuration programs, simple tools, test programs, ... Typically, the size is about 1/10th with Free Pascal/Lazarus and 1/5th with Delphi -for simple small programs. +for small and simple programs. It's not a specific graphical library, or another widgetset. It's an emulation of a small subset of the standard LCL/VCL, @@ -30,7 +30,7 @@ configuration to modify: just indicate a valid path for the Light LCL files into your project options, and that's it ! It's available only for Windows (32 and 64 bits). It has -been tested with FPC 2.6.x/3.x + Lazarus 1.2.x/1.4.x/1.5 and +been tested with FPC 2.6.x/3.x + Lazarus 1.4.x/1.6 and Delphi 7. See "README.txt" for more pieces of information. @@ -44,6 +44,29 @@ version 2.0. See "LICENSE.txt". ## LLCL ChangeLog +* [Version 1.01] (https://github.com/FChrisF/LLCL/releases/tag/v1.0.1): + Main changes and additions: + - TStringGrid control added (Grids.pas), + - TIniFile class added (IniFiles.pas), + - TClipboard class added for text data (ClipBrd.pas), + - PNG images support (not enabled by default), + - transparent bitmaps support (not enabled by default), + - forms double buffering support (not enabled by default), + - TSelectDirectoryDialog control added (Dialog.pas) for + FPC/Lazarus (not enabled by default) and SelectDirectory + function (Dialog.pas or FileCtrl.pas), + - ANSI LLCL option (i.e. no UTF8 at all) added for + FPC/Lazarus (see in LLCLFPCInc.inc), + - design time only properties for controls are now + accessible for dynamic creation purposes. Run time + modifications are still not supported for them, but they + can now be set at run time before the corresponding + control is dynamically created, + - a few bug fixes and some minor additions/modifications. + Note: controls and functionalities not enabled by default + can be activated by defining the corresponding option(s) in + the option files LLCLOptions.inc. + * [Version 1.00] (https://github.com/FChrisF/LLCL/releases/tag/v1.0.0): - Initial public release. diff --git a/README.txt b/README.txt index f71f08b..f3383a7 100644 --- a/README.txt +++ b/README.txt @@ -11,7 +11,7 @@ while being compatible with - a part of - the LCL/VCL. It may concern for instance: small installation or configuration programs, simple tools, test programs, ... Typically, the size is about 1/10th with Free Pascal/Lazarus and 1/5th with Delphi -for simple small programs. +for small and simple programs. It's not a specific graphical library, or another widgetset. It's an emulation of a small subset of the standard LCL/VCL, @@ -22,10 +22,10 @@ can be used. There is nothing to install in order to use it, nor any configuration to modify: just indicate a valid path for the -LLCL files into your project options, and that's it ! +Light LCL files into your project options, and that's it ! It's available only for Windows (32 and 64 bits). It has -been tested with FPC 2.6.x/3.x + Lazarus 1.2.x/1.4.x/1.5 and +been tested with FPC 2.6.x/3.x + Lazarus 1.4.x/1.6 and Delphi 7. @@ -42,6 +42,29 @@ the Light VCL (LVCL), with some additions and modifications. LLCL ChangeLog: +* Version 1.01: + Main changes and additions: + - TStringGrid control added (Grids.pas), + - TIniFile class added (IniFiles.pas), + - TClipboard class added for text data (ClipBrd.pas), + - PNG images support (not enabled by default), + - transparent bitmaps support (not enabled by default), + - forms double buffering support (not enabled by default), + - TSelectDirectoryDialog control added (Dialog.pas) for + FPC/Lazarus (not enabled by default) and SelectDirectory + function (Dialog.pas or FileCtrl.pas), + - ANSI LLCL option (i.e. no UTF8 at all) added for + FPC/Lazarus (see in LLCLFPCInc.inc), + - design time only properties for controls are now + accessible for dynamic creation purposes. Run time + modifications are still not supported for them, but they + can now be set at run time before the corresponding + control is dynamically created, + - a few bug fixes and some minor additions/modifications. + Note: controls and functionalities not enabled by default + can be activated by defining the corresponding option(s) in + the option files LLCLOptions.inc. + * Version 1.00: - Initial public release. @@ -58,15 +81,15 @@ file, You can obtain one at http://mozilla.org/MPL/2.0/. See the "LICENSE.txt" file for a copy of the MPL. -Copyright (c) 2015 ChrisF +Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr Note: as the LVCL has been released under the MPL version -1.1, this Source Code Form is “Incompatible With Secondary -Licenses”, as defined by the Mozilla Public License, v. 2.0. +1.1, this Source Code Form is "Incompatible With Secondary +Licenses", as defined by the Mozilla Public License, v. 2.0. More simply (i.e. my own interpretation): In simple terms, it means that you can use it in a common @@ -86,13 +109,15 @@ modified LGPL license used for the standard LCL of Lazarus. The files/units present in the Ligth LCL replace the main standard files/units used inside the LCL/VCL: Classes, -ComCtrls, Controls, Dialogs, ExtCtrls, Forms, Graphics, Menus, -StdCtrls, SysUtils and Variants. +ClipBrd, ComCtrls, Controls, Dialogs, ExtCtrls, FileCtrl, +Forms, Graphics, Grids, IniFiles, Menus, StdCtrls, SysUtils +and Variants. Plus an additional unit for the VCL: XPMan. And a few other ones for the LCL: FileUtil, Interfaces, -LazFileUtils, LazUTF8, LazUTF8Classes, LCLType and LMessages. +LazFileUtils, LazUTF8, LazUTF8Classes, LCLIntF, LCLType and +LMessages. Some of these units are just 'dummy' (i.e. empty) units, provided for compatibility reasons. @@ -105,18 +130,20 @@ provided for compatibility reasons. - LLCLFPCInc.inc: include file containing compilation directives (used only for FPC/Lazarus), - LLCLOptions.inc: include file with various possible - compilation options. + compilation options for the LLCL, +- LLCLPng.pas and LLCLZlib.pas: internal unit files for the + PNG support and the ZLib interface. 4. HOW TO USE THE LIGHT LCL --------------------------- Put all the LLCL files into a new directory (DO NOT -overwrite the standard LCL/VCL files - for instance, create a -subdirectory in your project called LLCLUnits), and just add -the corresponding path for the LLCL files into your project -options, in order they are used instead of the standard -LCL/VCL ones: +OVERWRITE the standard LCL/VCL files - for instance, create a +subdirectory in your project directory and call it LLCLUnits), +and just add the corresponding path for the LLCL files into +your project options, in order they are used instead of the +standard LCL/VCL ones: - for FPC/Lazarus (-Fu compiler option): Project->Project Options->Compiler options->Paths-> @@ -137,19 +164,19 @@ to apply to your projects: and Linking->Optimization levels - use a smaller icon than the default one for your program. The by-default icon for a project created with FPC/Lazarus - (i.e. yourproject.ico) includes several versions of icons, + (i.e. [yourproject].ico) includes several versions of icons, with various sizes and various numbers of colors: but, the final icon file size is about 134 Kb. Use instead only one small icon: for instance one with 32x32x256 size*colors - (3 Kb), or 32x32x16 size*colors (only 1 Kb). + (3 Kb), or with 32x32x16 size*colors (only 1 Kb). And both for FPC/Lazarus and Delphi: - remove the LLCL units not needed into your code (in the 'uses' clauses). Especially, remove the Dialogs unit (added - automatically by default in a new project), if this unit is - not needed. Units concerned by this remark: ComCtrls, - Dialogs and ExtCtrls. + automatically by default in a new project) if this unit is + not needed. Units especially concerned by this remark: + ComCtrls, Dialogs and ExtCtrls. 5. LINKS @@ -179,22 +206,22 @@ Delphi: http://www.embarcadero.com includes packages using the LCL/VCL. . Some other standard (i.e. FPC/Lazarus or Delphi) units may - or may not be used with the LLCL. Particularly: + or may not be used with the LLCL. More particularly: - can be used: SysUtils (with an extra size penalization), Variants (only with the standard SysUtils unit), Types (not included into the LLCL files), - cannot be used: Classes (at least not without some - modifications). + modifications - see the "GetWebPage" sample). To use one standard unit instead of its corresponding LLCL unit in your projects, rename or delete it into the LLCL directory. See also the next paragraph in this case. . It's possible to switch back and forth between the LLCL and - the LCL/VCL for a given project. En each case, a full build + the LCL/VCL for a given project. In each case, a full build ("Build" Shift+F9) is preferable. However, when switching from the LLCL to the VCL/LCL, it's not sufficient for - FPC/Lazarus if the source files of the LLCL have been used - (because the binary files of the LLCL are still present). + FPC/Lazarus if the source files of the LLCL have been used: + because the binary files of the LLCL are then still present. Here are the steps to use in both cases: * From the LCL/VCL to the LLCL: 1/ add the path for the LLCL files into the project @@ -203,7 +230,7 @@ Delphi: http://www.embarcadero.com * From the LLCL to the LCL/VCL: 1/ remove the path for the LLCL files into the project options, or rename/delete the corresponding LLCL file - (for using a standard LCL/VCL file like SysUtils for + (for using a standard LCL/VCL file like SysUtils, for instance), 2/ if the source files of the LLCL have been used, delete the corresponding binary file(s) in the binary @@ -230,8 +257,12 @@ Delphi: http://www.embarcadero.com . Some compilation directives for the LLCL are available in the LLCLOptions.inc file. Their main aims are to permit to reduce a little bit more the size of the final executable - file. See in the include file itself for the option list, - and for pieces of information for each option. + file, or to adjust more precisely some functionalities + supported by the LLCL. See in the include file itself for + the option list, and for pieces of information for each of + these options. It's also possible to use global defines for + these options in the project options (see the "Visual" + sample for this later case). . Unknown properties (i.e. properties not supported by the LLCL) present in the lfm/dfm files are just ignored; as for @@ -241,12 +272,12 @@ Delphi: http://www.embarcadero.com . Though not recommended, it's possible to make conditional compilation for programs using the LLCL by testing the - "Declared(LLCLVersion)" assertion (i.e. {$if ...}). Forms - unit must be used in this case. + "Declared(LLCLVersion)" assertion (i.e. {$if ...}). The + Forms unit must be used in this case. -. Controls can be created at runtime, but with some - limitations: especially concerning properties that can only - be set at design time (see 7.3). +. Controls can be created at run time, but with some + limitations. The main exception is menus (TMainMenu and + TPopupMenu), which can't be created at run time. . Though they are not supposed to be seen by the final user, it's possible to use an external include file for the LLCL @@ -261,7 +292,7 @@ Delphi: http://www.embarcadero.com possible to use an experimental UTF16 version of the LLCL (i.e. "Unicode" version of Free Pascal). Select one of the UTF16 modes in the LLCLFPCInc include file ("unicodestrings" - or "delphiunicode"), and select it also for your own units. + or "delphiunicode"), and PUT IT ALSO in your own units. Notes: - some of the SysUtils functions are currently absent in the UTF16 version of the LLCL, @@ -269,7 +300,29 @@ Delphi: http://www.embarcadero.com the "Unicode" version of Free Pascal. As a consequence, using the standard SysUtils unit in the LLCL will display several implicit conversions and relative warnings during - the compilation. + the compilation, + - only the Unicode Windows APIs are then used (though it's + still possible to use the LLCL_OPT_UNICODE_API_XXXX + options to modify this), + - the "-FcUTF8" option must be then used for the whole + project, or the "{$codepage UTF8}" directive must be added + to all your program units. If the "delphiunicode" mode is + choosen, the "{$codepage UTF8}" directive in all your + units is then mandatory (i.e. the "-FcUTF8" option is not + sufficient). + +. For FPC/Lazarus, it's possible to use a "pure" ANSI version + of the LLCL (note: it is not really the same thing as the + "DisableUTF8RTL" option of the standard LCL version 1.6): + see the LLCL_FPC_ANSI_ONLY option in LLCLFPCInc.inc. In this + later case, you must also save your own program units in the + corresponding ANSI encoding type, and not use the by-default + UTF8 encoding type. With this mode, only the ANSI Windows + APIs are then used (though it's still possible to use the + LLCL_OPT_UNICODE_API_XXXX options to modify this). For + compatibility reasons, UTF8 functions (especially UTF8ToSys + and SysToUTF8) are not making any conversions when used in + this mode (mainly concerns FPC 2.6.x). 7. EMULATION MINI DOCUMENTATION @@ -281,14 +334,16 @@ Delphi: http://www.embarcadero.com Standard: TLabel, TButton, TEdit, TMemo, TCheckBox, TRadioButton, TGroupBox, TComboBox, TListBox, TStaticText, TMainMenu, TPopupMenu -Additional: TImage, TTrayIcon +Additional: TImage, TTrayIcon, TStringGrid Common: TProgressBar, TTrackBar, TXPManifest (Delphi) -Dialogs: TOpenDialog, TSaveDialog +Dialogs: TOpenDialog, TSaveDialog, TSelectDirectoryDialog + (FPC only, and not enabled by default) System: TTimer -Other classes: TCustomForm, TForm +Other classes: TCustomForm, TForm, TClipboard, TIniFile -General variables: Application (TApplication), Mouse(TMouse) +General variables: Application (TApplication), Mouse(TMouse), + Clipboard(TClipboard) 7.2 BASE CLASSES TREE @@ -314,11 +369,15 @@ TNonVisualControl* TVisualControl* 7.3 CLASSES DETAILS -------------------- -Standard public methods, properties and events available -[rwd] options: - r=read, w=write, d=design time ([d] means design time only) + Standard public methods, properties and events available +[rwd] options: r=read, w=write, d=design time. + + "Design time" meaning: can bet set only inside the IDE +(i.e. in the dfm/lfm files), or in code for controls created +dynamically before their "real" creation (i.e. before affected +to their TWinControl parent). -Preliminary note: generally speaking, they are usually + Preliminary note: generally speaking, they are usually simplified and so, are supposed to work properly for the common case(s) only. @@ -433,6 +492,7 @@ Note: TCustomBox is specific to the LLCL TGraphicData (Graphics - TPersistent) destructor Destroy; override; property Data: array of byte; [d] + property OnChange: TNotifyEvent; [rw] Note: TGraphicData is specific to the LLCL TBitmap (Graphics - TGraphicData) @@ -447,6 +507,7 @@ TPicture (Graphics - TPersistent) procedure LoadFromResourceName(Instance: THandle; const ResName: string); * procedure LoadFromFile(const FileName: string); property Bitmap: TBitmap; [rw] + property OnChange: TNotifyEvent; [rw] *: only with Free Pascal/Lazarus TIcon (Graphics - TGraphicData) @@ -506,6 +567,7 @@ TVisualControl (Controls - TControl) procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); virtual; procedure Show; virtual; procedure Update; virtual; + property Alignment: [rd] * property AutoSize; [rwd] property Canvas: TCanvas; [r] property Caption: string; [rwd] @@ -519,6 +581,7 @@ TVisualControl (Controls - TControl) property Visible: boolean; [rwd] property Width: integer; [rwd] property OnShow: TNotifyEvent; [rwd] +*: Present in corresponding controls for standard LCL/VCL Note: TVisualControl is specific to the LLCL TGraphicControl (Controls - TVisualControl) @@ -572,9 +635,7 @@ TCheckBox (SdtCtrls - TWinControl) constructor Create(AOwner: TComponent); override; property AllowGrayed: boolean; [rwd] property Checked: boolean; [rwd] - property InitialAlignment: TAlignment; [rw] * property State: TCheckBoxState; [rwd] -*: LLCL specific TComboBox (SdtCtrls - TCustomBox) constructor Create(AOwner: TComponent); override; @@ -587,14 +648,11 @@ TComboBox (SdtCtrls - TCustomBox) TEdit (StdCtrls - TWinControl) constructor Create(AOwner: TComponent); override; - property Alignment: TAlignment; [d] - property InitialAlignment: TAlignment; [rw] * property PasswordChar: Char; [d] procedure SelectAll; property ReadOnly: boolean; [rwd] property Text: string; [rwd] property OnChange: TNotifyEvent; [rwd] -*: LLCL specific TGroupBox (SdtCtrls - TWinControl) constructor Create(AOwner: TComponent); override; @@ -607,10 +665,9 @@ TImage (ExtCtrl - TGraphicControl) TLabel (StdCtrls - TGraphicControl) constructor Create(AOwner: TComponent); override; - property Alignment: TAlignment; [d] property WordWrap: boolean; [d] Note: TLabel is a TStaticText subclass, if LLCL_OPT_STDLABEL -is not defined + is not defined TListBox (SdtCtrls - TCustomBox) constructor Create(AOwner: TComponent); override; @@ -637,7 +694,6 @@ TRadioButton (SdtCtrls - TCheckBox) TStaticText (SdtCtrls - TWinControl) constructor Create(AOwner: TComponent); override; - property Alignment: TAlignment; [d] property BorderStyle: boolean; [d] TOpenDialog (Dialogs - TNonVisualControl) @@ -667,6 +723,50 @@ TSaveDialog (Dialogs - TOpenDialog) constructor Create(AOwner: TComponent); override; Note: available only if LLCL_OPT_USEDIALOG is not undefined +TSelectDirectoryDialog (Dialogs - TOpenDialog) + constructor Create(AOwner: TComponent); override; + function Execute: boolean; override; +Notes: - only with Free Pascal/Lazarus + - available only if LLCL_OPT_USESELECTDIRECTORYDIALOG + is defined + +TStringGrid (Grids - TWinControl) + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SortColRow(IsColumn: boolean; Index: integer); *1 + property Cells[ACol, ARow: integer]: string; [rwd] *2 + property Col: integer; [rw] + property ColCount: integer; [rwd] + property Cols[Index: integer]: TStringList; [rw] + property ColumnClickSorts: boolean; [rwd] *3 + property ColWidths[Index: integer]: integer; [rwd] + property DefaultColWidth: integer; [rwd] + property DefaultRowHeight: integer; [rwd] *4 + property FixedCols: integer; [rwd] *5 + property FixedRows: integer; [rwd] *6 + property OnCompareCells: TOnCompareCells; [rwd] *3 + property OnGetEditText: TGetEditEvent; [rwd] + property OnHeaderClick: THdrEvent; [rwd] *3 + property OnSelectCell: TOnSelectCellEvent; [rwd] + property OnSetEditText: TSetEditEvent; [rwd] + property Options: TGridOptions; [rd] + property Row: integer; [rw] + property RowCount: integer; [rwd] + property RowHeights[Index: integer]: integer; [rwd] *7 + property Rows[Index: integer]: TStringList; [rw] + property Selection: TGridRect; [r] + property SortColumn: integer; [r] *3 + property SortOrder: TSortOrder; [rw] *3 +*1: only for columns (i.e. IsColumn = True) +*2: not possible at design time for Delphi +*3: not present in the standard Delphi VCL +*4: fixed row not concerned +*5: ignored +*6: only 1 fixed row is possible +*7: ignored +Note: some properties are available only if certain options + are defined (see LLCL_OPT_GRIDSOPT_XXXX) + TTimer (ExtCtrl - TNonVisualControl) constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -702,8 +802,7 @@ TTrayIcon (ExtCtrl - TNonVisualControl) property BalloonTitle: string; [rwd] property OnDblClick: TNotifyEvent; [rwd] *: Available if LLCL_OPT_USEMENUS is not undefined -**: Balloon notifications are possible only for Windows 2000 -or newer +**: Balloon notifications are possible only for Windows 2000+ ***: Only for Windows 2000 or XP TXPManifest (XPMan - TComponent) @@ -771,8 +870,8 @@ TMouse (Controls - TObject) property CursorPos: TPoint; [rw] -7.3.5 SYSTEM CLASSES DETAILS ----------------------------- +7.3.5 VARIOUS OTHER CLASSES DETAILS +----------------------------------- TStream (Classes - TObject) procedure Clear; @@ -822,7 +921,7 @@ TMemoryStream (Classes - TCustomMemoryStream) TReader (Classes - TObject) Note: the whole class is not standard, and therefore should -not be used + not be used TThread (Classes - TObject) constructor Create(CreateSuspended: boolean); @@ -841,8 +940,9 @@ TThread (Classes - TObject) Note: it's also possible to use (from the protected part) procedure Execute; virtual; abstract; property Terminated: boolean; [r] -*: Resume and Suspend are deprecated for Delphi 2010+ and FPC/Lazarus 2.4.4+ -**: only with FPC and Delphi 2010+ (use Start instead of Resume) +*: Resume and Suspend are deprecated for Delphi 2010+ and + FPC/Lazarus 2.4.4+ +**: only with FPC and Delphi 2010+ (Start instead of Resume) TEvent (Classes - TObject) constructor Create(EventAttributes: PSecurityAttributes; ManualReset, InitialState: Boolean; const Name: string); @@ -850,9 +950,35 @@ TEvent (Classes - TObject) procedure ResetEvent; procedure SetEvent; function WaitFor(Timeout: LongWord): TWaitResult; - property Handle: THandle ; [r] * + property Handle: THandle; [r] * *: only with Delphi +TClipboard (ClipBrd - TPersistent) + procedure Open; + procedure Close; + procedure Clear; + function HasFormat(Format: cardinal): boolean; + function GetAsHandle(Format: cardinal): THandle; + procedure SetAsHandle(Format: cardinal; Value: THandle); + property AsText: string; [rw] + +TIniFile (IniFiles - TObject) + constructor Create(const AFileName: string); + procedure DeleteKey(const Section, Ident: string); virtual; + procedure EraseSection(const Section: string); virtual; + function ReadBool(const Section, Ident: string; Default: boolean): boolean; virtual; + function ReadDate(const Section, Ident: string; Default: TDateTime): TDateTime; virtual; + function ReadInt64(const Section, Ident: string; Default: int64): int64; virtual; + function ReadInteger(const Section, Ident: string; Default: integer): integer; virtual; + function ReadString(const Section, Ident, Default: string): string; virtual; + procedure WriteBool(const Section, Ident: string; Value: boolean); virtual; + procedure WriteDate(const Section, Ident: string; Value: TDateTime); virtual; + procedure WriteInt64(const Section, Ident: string; Value: int64); virtual; + procedure WriteInteger(const Section, Ident: string; Value: integer); virtual; + procedure WriteString(const Section, Ident, Value: string); virtual; + property FileName: string; [r] +Note: string date/time formats are specific in LLCL SysUtils + 7.4 SPECIFIC NOTES ------------------ @@ -887,13 +1013,43 @@ Controls and main classes: not used). . TPicture: - Only BMP images are supported. + Only BMP and PNG (not enabled by default for PNG) images are + supported. To use PNG images, the LLCL_OPT_PNGSUPPORT option + must be defined, or eventually the more complete + LLCL_OPT_EXTENDGRAPHICAL option which enables also the + support of transparent bitmaps and of the double buffering + painting mode for forms. Some additional Zlib options (PNG + images support requires the Zlib decompression) are also + available. Neither TPicture nor TBitmap support any kind of + data saving. . TOpenDialog: The number of files which can be selected is limited in case of a multi selection: 100 files or more, depending of the whole file path sizes. +. TStringGrid: + As the StringGrid control is based upon a Windows Listview + control in the LLCL, there are several differences with the + standard LCL/VCL one. Hereafter, the main differences: + - only one or zero fixed rows is possible. More than one + fixed rows gives only one fixed row, + - fixed columns are not possible: they are just ignored, + - a single cell or a group of cells can't be selected except + in the first column. Selecting a single row or a + group of rows is however possible (if the goRowSelect + option is set), + - only cells in the first column can be edited (not enabled + by default), + - rows can't be sorted, only columns, + A few options are available concerning this control: see + LLCL_OPT_GRIDSOPT_XXXX in LLCLOptions.inc. + +. TSelectDirectoryDialog: + This control (FPC/Lazarus only) is available only if the + general LLCL_OPT_USEDIALOG option is defined, and if the + specific LLCL_OPT_USESELECTDIRECTORYDIALOG option too. + . TTrayIcon: WM_USER+125 message is used in the main Windows procedure for TTrayIcon; i.e. it's not available for other purposes. @@ -903,13 +1059,15 @@ System classes: . TThread: There is no Synchronize function. As a consequence, the OnTerminate event is executed inside the calling thread, - and not inside the main thread. + and not inside the main thread (contrarily to the standard + LCL/VCL). Others: . SysUtils: - DateTimeToStr, DateToStr and TimeToStr function are using - only a fixed output format: 'YYYY/MM/DD hh:mm:ss'. + The DateTimeToStr, DateToStr, TimeToStr, TryStrToDate and + TryStrToTime functions are using only a fixed format: + 'YYYY/MM/DD hh:mm:ss'. 7.5 KNOWN ISSUES @@ -926,3 +1084,13 @@ Others: units: "range" (-Cr) and "Verify method calls (-CR). Your projects may however still used these options, but the used LLCL units must be compiled first without them. + +. Since Lazarus 1.6, the IDE is displaying some warnings (i.e. + "note") during the compilation step, when some unit names + are identical between the project files and the files used + by the package(s) for the project. This is especially the + case when the "LCL" package is used for a project (default + for a standard application), and the LLCL too. Currently, + there are no ways to avoid them. So, just ignore them; or + eventually (which is absolutely not recommended) remove the + "LCL" package dependency for the project. diff --git a/demo/Delphi/LLCLTest.dof b/demo/Delphi/LLCLTest.dof index bfd437b..64ea0f5 100644 --- a/demo/Delphi/LLCLTest.dof +++ b/demo/Delphi/LLCLTest.dof @@ -95,7 +95,7 @@ UnitOutputDir= PackageDLLOutputDir= PackageDCPOutputDir= SearchPath=..\..\sources -Packages=vcl;rtl;vclx;VclSmp;vclshlctrls;IndyCore70;IndySystem70;IndyProtocols70 +Packages=vcl;rtl;vclx;VclSmp;vclshlctrls Conditionals= DebugSourceDirs= UsePackages=0 @@ -130,13 +130,9 @@ OriginalFilename= ProductName= ProductVersion=1.0.0.0 Comments= -[Excluded Packages] -C:\WINDOWS\system32\IndyCore70.bpl=Indy 10 Core -C:\WINDOWS\system32\IndySystem70.bpl=Indy 10 System [HistoryLists\hlUnitAliases] Count=1 Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; [HistoryLists\hlSearchPath] -Count=2 +Count=1 Item0=..\..\sources -Item1=.\LLCLUnits diff --git a/demo/Delphi/Unit1.pas b/demo/Delphi/Unit1.pas index 736eb1b..11f6834 100644 --- a/demo/Delphi/Unit1.pas +++ b/demo/Delphi/Unit1.pas @@ -9,14 +9,14 @@ {$mode objfpc}{$H+} // {$mode delphi} // {$mode objfpc}{$modeswitch unicodestrings}{$H+} // Requires FPC 2.7.1+ -// {$mode delphiunicode} // (See LLCL README.txt) +// {$mode delphiunicode}{$codepage UTF8} // (See LLCL README.txt) {$ENDIF} {$IFDEF FPC_OBJFPC} {$DEFINE IS_FPC_OBJFPC_MODE} {$ENDIF} interface uses - SysUtils, {$IFDEF FPC}FileUtil, LCLType,{$ELSE} Variants, XPMan,{$ENDIF} + SysUtils, {$IFDEF FPC}LazUTF8, LCLType,{$ELSE} Variants, XPMan,{$ENDIF} Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, Menus; @@ -146,9 +146,9 @@ procedure MemoAddLineFmt(MemoCtrl: TMemo; const s: string; const Args: array of procedure TForm1.CreateParams(var Params : TCreateParams); begin inherited; - Form1.CheckBox1.InitialAlignment := taLeftJustify; // Note: TCheckBox has an alignment - Form1.CheckBox3.InitialAlignment := taLeftJustify; // property since Lazarus 1.4 - Form1.RadioButton2.InitialAlignment := taLeftJustify; + Form1.CheckBox1.Alignment := taLeftJustify; // Note: TCheckBox has an alignment + Form1.CheckBox3.Alignment := taLeftJustify; // property since Lazarus 1.4 + Form1.RadioButton2.Alignment := taLeftJustify; end; {$IFEND} {$ENDIF} @@ -324,7 +324,6 @@ procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); // (Because Form1 has KeyPreview=True property) // Only the character code is present here (see FormKeyDown, FormKeyUp) MemoAddLineFmt(Memo1,'FormKeyPress #%d ''%s''', [Ord(Key), - // (Note: warning for SysToUTF8 with Lazarus 1.5+ and standard LCL) {$if Defined(FPC) and not Defined(UNICODE)}SysToUTF8(Key){$else}Key{$ifend}]); // Char type is not UTF8 end; diff --git a/demo/FPC/unit1.lfm b/demo/FPC/unit1.lfm index e82727c..ddcc494 100644 --- a/demo/FPC/unit1.lfm +++ b/demo/FPC/unit1.lfm @@ -14,7 +14,7 @@ object Form1: TForm1 OnKeyUp = FormKeyUp OnMouseDown = FormMouseDown OnMouseUp = FormMouseUp - LCLVersion = '1.4.2.0' + LCLVersion = '1.4.4.0' object GroupBox1: TGroupBox Left = 8 Height = 65 diff --git a/demo/FPC/unit1.pas b/demo/FPC/unit1.pas index 736eb1b..11f6834 100644 --- a/demo/FPC/unit1.pas +++ b/demo/FPC/unit1.pas @@ -9,14 +9,14 @@ {$mode objfpc}{$H+} // {$mode delphi} // {$mode objfpc}{$modeswitch unicodestrings}{$H+} // Requires FPC 2.7.1+ -// {$mode delphiunicode} // (See LLCL README.txt) +// {$mode delphiunicode}{$codepage UTF8} // (See LLCL README.txt) {$ENDIF} {$IFDEF FPC_OBJFPC} {$DEFINE IS_FPC_OBJFPC_MODE} {$ENDIF} interface uses - SysUtils, {$IFDEF FPC}FileUtil, LCLType,{$ELSE} Variants, XPMan,{$ENDIF} + SysUtils, {$IFDEF FPC}LazUTF8, LCLType,{$ELSE} Variants, XPMan,{$ENDIF} Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, Menus; @@ -146,9 +146,9 @@ procedure MemoAddLineFmt(MemoCtrl: TMemo; const s: string; const Args: array of procedure TForm1.CreateParams(var Params : TCreateParams); begin inherited; - Form1.CheckBox1.InitialAlignment := taLeftJustify; // Note: TCheckBox has an alignment - Form1.CheckBox3.InitialAlignment := taLeftJustify; // property since Lazarus 1.4 - Form1.RadioButton2.InitialAlignment := taLeftJustify; + Form1.CheckBox1.Alignment := taLeftJustify; // Note: TCheckBox has an alignment + Form1.CheckBox3.Alignment := taLeftJustify; // property since Lazarus 1.4 + Form1.RadioButton2.Alignment := taLeftJustify; end; {$IFEND} {$ENDIF} @@ -324,7 +324,6 @@ procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); // (Because Form1 has KeyPreview=True property) // Only the character code is present here (see FormKeyDown, FormKeyUp) MemoAddLineFmt(Memo1,'FormKeyPress #%d ''%s''', [Ord(Key), - // (Note: warning for SysToUTF8 with Lazarus 1.5+ and standard LCL) {$if Defined(FPC) and not Defined(UNICODE)}SysToUTF8(Key){$else}Key{$ifend}]); // Char type is not UTF8 end; diff --git a/sources/Classes.pas b/sources/Classes.pas index 5841d26..0337fe0 100644 --- a/sources/Classes.pas +++ b/sources/Classes.pas @@ -12,15 +12,17 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * TReader: ReadStringInts (and StringIntProperty), ReadIntArray added Version 1.00: * Rect, EStreamError moved from SysUtils to Classes * TList reviewed (List, Capacity, ...) @@ -317,6 +319,7 @@ TReader = class function BooleanProperty(): boolean; function IntegerProperty(): integer; function StringProperty(): string; + function StringIntProperty(): string; function ColorProperty(): integer; function BinaryProperty(var Size: integer): pointer; procedure IdentProperty(var aValue; aTypeInfo: pointer); @@ -329,10 +332,12 @@ TReader = class function ReadUTF8String(): string; function ReadWString(): string; procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: integer); + procedure AnyProperty; procedure ReadList; procedure ReadSet; procedure ReadStrings(Strings: TStrings); - procedure AnyProperty; + procedure ReadStringInts(Strings: TStrings); + procedure ReadIntArray(var IntArray: array of integer); // Read an array of integers property Size: integer read fSize; property Position: integer read fPosition write SetPosition; end; @@ -514,6 +519,7 @@ TTypeInfo = record function GetTypeData(ptrTypeInfo: PTypeInfo) : PTypeData; forward; function GetEnumNameValue(ptrTypeInfo: PTypeInfo; const Name: string): integer; forward; function GetColorFromIdent(Ident: PChar): integer; forward; +function ClassSameText(const S1, S2: string): boolean; forward; {$ifdef MSWindows} var @@ -526,8 +532,7 @@ function CreateComponent(const AClassName: shortstring; AOwner: TComponent): TCo {$define Def_FPC_StdSys} {$ifend} {$ifdef Def_FPC_StdSys} -function Class_CompareText(const S1, S2: string): integer; forward; -function Class_SameText(const S1, S2: string): boolean; forward; +function Class_IntToStr(Value: integer): string; forward; {$endif} @@ -550,9 +555,9 @@ function GetEnumNameValue(ptrTypeInfo: PTypeInfo; const Name: string): integer; case ptrTypeInfo^.Kind of tkBool: begin - if {$ifdef Def_FPC_StdSys}Class_CompareText{$else}CompareText{$endif}(BooleanIdents[false],Name)=0 then + if ClassSameText(BooleanIdents[false], Name) then result := 0 - else if {$ifdef Def_FPC_StdSys}Class_CompareText{$else}CompareText{$endif}(BooleanIdents[true],Name)=0 then + else if ClassSameText(BooleanIdents[true], Name) then result := 1; end; tkEnumeration: @@ -562,7 +567,7 @@ function GetEnumNameValue(ptrTypeInfo: PTypeInfo; const Name: string): integer; PS := @PT^.NameList; while PByte(PS)^<>0 do begin - if {$ifdef Def_FPC_StdSys}Class_CompareText{$else}CompareText{$endif}(string(PS^), Name) = 0 then + if ClassSameText(string(PS^), Name) then begin result := Count+PT^.MinValue; break; @@ -690,40 +695,17 @@ function GetColorFromIdent(Ident: PChar): integer; result := clNone; end; -{$ifdef Def_FPC_StdSys} -function Class_CompareText(const S1, S2: string): integer; -var i, count, count1, count2: integer; -var ch1, ch2: integer; -begin - count1 := length(S1); - count2 := length(S2); - if count1 > count2 then - count := count2 - else - count := count1; - for i:=1 to count do - begin - ch1 := ord(S1[i]); - ch2 := ord(S2[i]); - if ch1 <> ch2 then - begin - if ch1 in [ord('a')..ord('z')] then Dec(ch1, 32); - if ch2 in [ord('a')..ord('z')] then Dec(ch2, 32); - if ch1 <> ch2 then - begin - result := ch1 - ch2; - exit; - end; - end; - end; - result := count1 - count2; +function ClassSameText(const S1, S2: string): boolean; +begin + result := (LLCLS_CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, S2)=CSTR_EQUAL); end; -function Class_SameText(const S1, S2: string): boolean; +{$ifdef Def_FPC_StdSys} +function Class_IntToStr(Value: integer): string; begin - result := (Class_CompareText(S1, S2)=0); + Str(Value, result); end; -{$endif} +{$endif Def_FPC_StdSys} { TList } @@ -964,7 +946,7 @@ function TStringList.IndexOf(const s: string): integer; if fCaseSensitive then begin if fListStr[i]=s then begin result := i; exit; end; end else - begin if {$ifdef Def_FPC_StdSys}Class_SameText{$else}SameText{$endif}(fListStr[i], s) then begin result := i; exit; end; end; + begin if ClassSameText(fListStr[i], s) then begin result := i; exit; end; end; end; function TStringList.IndexOfObject(item: pointer): integer; @@ -989,7 +971,7 @@ function TStringList.IndexOfName(const ObjName: string; const Separator: string= begin Tmp := ObjName + Separator; for i := 0 to fCount-1 do - if {$ifdef Def_FPC_StdSys}Class_CompareText{$else}CompareText{$endif}(Copy(fListStr[i], 1, length(Tmp)), Tmp) = 0 then + if ClassSameText(Copy(fListStr[i], 1, length(Tmp)), Tmp) then begin result := i; exit; @@ -1182,7 +1164,7 @@ function TStream.CopyFrom(Source: TStream; Count: integer): integer; Dec(Count, N); end; finally - FreeMem(Buffer, BufSize); + FreeMem(Buffer); end; end; @@ -1441,6 +1423,23 @@ function TReader.StringProperty(): string; end; end; +function TReader.StringIntProperty(): string; +var ValueType: TValueType; +begin + result := ''; + ValueType := ReadValueType(); + case ValueType of + vaIdent, + vaString: result := ReadString(); + vaUTF8String: result := ReadUTF8String(); + vaWString: result := ReadWString(); + vaInt8 : result := {$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ShortInt(ReadByte())); + vaInt16 : result := {$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ReadWord()); + vaInt32 : result := {$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ReadInteger()); + else raise EClassesError.CreateFmt(LLCL_STR_CLAS_STRING, [integer(ValueType)]); + end; +end; + function TReader.ColorProperty(): integer; var ValueType: TValueType; begin @@ -1631,6 +1630,35 @@ procedure TReader.ReadStrings(Strings: TStrings); else Error(LLCL_STR_CLAS_LIST); end; +// Read strings and integers (hack: integers are stored as strings) +procedure TReader.ReadStringInts(Strings: TStrings); +var ValueType: TValueType; + s: string; +begin + ValueType := ReadValueType(); + if ValueType=vaList then + repeat + s := StringIntProperty(); + Strings.Add(s); + until EndOfList() + else Error(LLCL_STR_CLAS_LIST); +end; + +// Read array of integers (array must wide enough) +procedure TReader.ReadIntArray(var IntArray: array of integer); +var ValueType: TValueType; + i: integer; +begin + i := 0; + ValueType := ReadValueType(); + if ValueType=vaList then + repeat + IntArray[i ] := IntegerProperty(); + Inc(i); + until EndOfList() + else Error(LLCL_STR_CLAS_LIST); +end; + { TPersistent } function TPersistent.SubProperty(const SubPropName: string): TPersistent; @@ -1659,8 +1687,8 @@ procedure TPersistent.ReadProperty(const PropName: string; Reader: TReader); {$ifdef debug} ValueType := ReadValueType(); case ValueType of - vaInt8 : Value := IntToStr(ReadByte()); - vaInt16 : Value := IntToStr(ReadWord()); + vaInt8 : Value := {$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ReadByte()); + vaInt16 : Value := {$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ReadWord()); vaIdent : Value := '"'+ReadString()+'"'; vaString : Value := ReadString(); vaUTF8String: Value := ReadUTF8String(); @@ -1668,12 +1696,12 @@ procedure TPersistent.ReadProperty(const PropName: string; Reader: TReader); vaFalse : Value := '"FALSE"'; vaTrue : Value := '"TRUE"'; vaBinary : begin - i := ReadInteger(); Value := '('+IntToStr(i)+LLCL_STR_CLAS_BYTES; + i := ReadInteger(); Value := '('+{$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(i)+LLCL_STR_CLAS_BYTES; Inc(fPointer,i); Inc(fPosition,i); end; vaList: ReadList; vaSet: ReadSet; - else OutputDebugString(pointer(LLCL_STR_CLAS_BADVALUETYPE+IntToStr(ord(ValueType)))); + else OutputDebugString(pointer(LLCL_STR_CLAS_BADVALUETYPE+{$ifdef Def_FPC_StdSys}Class_IntToStr{$else}IntToStr{$endif}(ord(ValueType)))); end; Oem := LLCLS_StringToOem(Value); writeln(self.ClassName+' '+TComponent(self).Name+'.'+PropName+'='+Oem); @@ -1874,7 +1902,7 @@ function TComponent.FindComponent(const CompName: string): TComponent; result := nil; if fComponents<>nil then for i := 0 to fComponents.Count-1 do - if {$ifdef Def_FPC_StdSys}Class_SameText{$else}SameText{$endif}(TComponent(fComponents[i]).Name, CompName) then + if ClassSameText(TComponent(fComponents[i]).Name, CompName) then begin result := TComponent(fComponents[i]); break; @@ -1906,8 +1934,7 @@ procedure TMemoryStream.SetSize(Value: integer); destructor TMemoryStream.Destroy; begin - if Memory<>nil then - Freemem(Memory); + LLCLS_FreeMemAndNil(fMemory); inherited; end; diff --git a/sources/ClipBrd.pas b/sources/ClipBrd.pas new file mode 100644 index 0000000..8ca0467 --- /dev/null +++ b/sources/ClipBrd.pas @@ -0,0 +1,193 @@ +unit ClipBrd; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * TClipboard/Clipboard implemented (only for text) +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +uses + Classes; + +type + TClipboard = class(TPersistent) + private + fOwnerHandle: THandle; + function OpenClipBrd(): boolean; + procedure CloseClipBrd; + function GetAsText(): string; + procedure SetAsText(const Value: string); + procedure SetBuffer(Format: cardinal; Buffer: pointer; Size: integer); + public + procedure Open; + procedure Close; + procedure Clear; + function HasFormat(Format: cardinal): boolean; + function GetAsHandle(Format: cardinal): THandle; + procedure SetAsHandle(Format: cardinal; Value: THandle); + property AsText: string read GetAsText write SetAsText; + end; + +{$IFDEF FPC} +const + CF_TEXT = 1; + CF_BITMAP = 2; + CF_UNICODETEXT = 13; +{$ENDIF} + +var + Clipboard: TClipboard; + +//------------------------------------------------------------------------------ + +implementation + +uses + LLCLOSInt, Windows, + Forms; + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +type + TPApplication = class(TApplication); // To access to protected part + +//------------------------------------------------------------------------------ + +{ TClipboard } + +function TClipboard.OpenClipBrd(): boolean; +begin + if fOwnerHandle=0 then + fOwnerHandle := TPApplication(Application).AppHandle; + result := LLCL_OpenClipboard(fOwnerHandle); +end; + +procedure TClipboard.CloseClipBrd; +begin + LLCL_CloseClipboard(); +end; + +function TClipboard.GetAsText(): string; +var hData: THandle; +begin + result := ''; + if not OpenClipBrd() then exit; + hData := LLCL_GetClipboardData(LLCLS_CLPB_GetTextFormat()); + if hData<>0 then + begin + result := LLCLS_CLPB_GetText(LLCL_GlobalLock(hData)); + LLCL_GlobalUnlock(hData); + end; + CloseClipBrd; +end; + +procedure TClipboard.SetAsText(const Value: string); +var lpText: pointer; +var len: cardinal; +begin + lpText := LLCLS_CLPB_SetTextPtr(Value, len); + SetBuffer(LLCLS_CLPB_GetTextFormat(), lpText, len); +end; + +procedure TClipboard.SetBuffer(Format: cardinal; Buffer: pointer; Size: integer); +var hMem: THandle; +var pMem: pointer; +begin + if not OpenClipBrd() then exit; + Clear; + hMem := LLCL_GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, Size); + if hMem<>0 then + begin + pMem := LLCL_GlobalLock(hMem); + if Assigned(pMem) then + Move(Buffer^, pMem^, Size); + LLCL_GlobalUnlock(hMem); + LLCL_SetClipboardData(Format, hMem); + // Don't free the allocated memory + end; + CloseClipBrd; +end; + +procedure TClipboard.Open; +begin + OpenClipBrd(); +end; + +procedure TClipboard.Close; +begin + CloseClipBrd; +end; + +procedure TClipboard.Clear; +begin + LLCL_EmptyClipboard(); +end; + +function TClipboard.HasFormat(Format: cardinal): boolean; +begin + result := LLCL_IsClipboardFormatAvailable(Format); +end; + +function TClipboard.GetAsHandle(Format: cardinal): THandle; +begin + result := 0; + if not OpenClipBrd() then exit; + result := LLCL_GetClipboardData(Format); + Close; +end; + +procedure TClipboard.SetAsHandle(Format: cardinal; Value: THandle); +begin + if not OpenClipBrd() then exit; + Clear; + LLCL_SetClipboardData(Format, Value); + Close; +end; + +//------------------------------------------------------------------------------ + +initialization + Clipboard := TClipboard.Create(); + +finalization + Clipboard.Free; + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/ComCtrls.pas b/sources/ComCtrls.pas index 58a5eb7..c853118 100644 --- a/sources/ComCtrls.pas +++ b/sources/ComCtrls.pas @@ -12,15 +12,18 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * TWinControl: notifications for child controls modified + * TTrackBar: 'Orientation' and 'TickStyle' properties now accessible (design time only) Version 1.00: * File creation. * TProgressBar implemented @@ -59,7 +62,7 @@ TProgressBar = class(TWinControl) procedure SetStep(Value: integer); protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; public constructor Create(AOwner: TComponent); override; @@ -97,9 +100,9 @@ TTrackBar = class(TWinControl) procedure SetPageSize(Value: integer); protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; - procedure ComponentNotif(var Msg: TMessage); override; + function ComponentNotif(var Msg: TMessage): boolean; override; public constructor Create(AOwner: TComponent); override; property Min: integer read fMin write SetMin; @@ -108,6 +111,8 @@ TTrackBar = class(TWinControl) property Frequency: integer read fFrequency write SetFrequency; property LineSize: integer read fLineSize write SetLineSize; property PageSize: integer read fPageSize write SetPageSize; + property Orientation: TOrientation read fOrientation write fOrientation; // Run-time modification ignored; write present only for dynamical control creation purpose + property TickStyle: TTickStyle read fTickStyle write fTickStyle; // Run-time modification ignored; write present only for dynamical control creation purpose property OnChange: TNotifyEvent read EOnChange write EOnChange; end; @@ -147,7 +152,7 @@ function LMessages_Dummy(const Msg: TLMCommand): boolean; { TProgressBar } -constructor TProgressBar.Create(AOwner:TComponent); +constructor TProgressBar.Create(AOwner: TComponent); begin inherited; ATType := ATTProgressBar; @@ -166,7 +171,7 @@ procedure TProgressBar.CreateHandle; SetStep(fStep); end; -procedure TProgressBar.CreateParams(var Params : TCreateParams); +procedure TProgressBar.CreateParams(var Params: TCreateParams); const PROGRESS_CLASS = 'msctls_progress32'; begin inherited; @@ -237,7 +242,7 @@ procedure TProgressBar.StepBy(Value: integer); { TTrackBar } -constructor TTrackBar.Create(AOwner:TComponent); +constructor TTrackBar.Create(AOwner: TComponent); begin inherited; ATType := ATTTrackBar; @@ -261,7 +266,7 @@ procedure TTrackBar.CreateHandle; fOnChangeOK := true; // OnChange is now OK for being activated end; -procedure TTrackBar.CreateParams(var Params : TCreateParams); +procedure TTrackBar.CreateParams(var Params: TCreateParams); const TRACKBAR_CLASS = 'msctls_trackbar32'; begin inherited; @@ -347,9 +352,9 @@ procedure TTrackBar.SetPageSize(Value: integer); end; // Scroll messages coming from form -procedure TTrackBar.ComponentNotif(var Msg: TMessage); +function TTrackBar.ComponentNotif(var Msg: TMessage): boolean; begin - inherited; + result := inherited ComponentNotif(Msg); case Msg.Msg of WM_HSCROLL, WM_VSCROLL: if fOnChangeOK and Assigned(EOnChange) then diff --git a/sources/Controls.pas b/sources/Controls.pas index 72ee8a0..a09a609 100644 --- a/sources/Controls.pas +++ b/sources/Controls.pas @@ -12,15 +12,26 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * Bug fix and modification: background color support + * TStringGrid and TSelectDirectoryDialog control types added + * TWinControl: notifications for child controls modified + * Bug fix for nested groupboxes with Windows XP (not enabled by default - see LLCL_OPT_NESTEDGROUPBOXWINXPFIX option) + * KeysToShiftState/KeyDataToShiftState moved to LLCLOSInt + * TVisualControl: 'Alignment' property added (not standard - design time only) + * TWinControl: modifications in WMEraseBkGnd, WMPaint and ColorCall + * TWinControl: DoubleBuffered added, used only by Forms (not enabled by default - see LLCL_OPT_DOUBLEBUFF option) + * TWinControl: WM_SIZE and WM_MOVE taken into account only by Forms + * TWinControl: fix for StaticText control when size is modified Version 1.00: * TWinControl: BringToFront (not standard) * TWinControl: TabStop and ControlCount properties @@ -101,7 +112,8 @@ interface TAllControlTypes = (ATTNone, ATTCustomForm, ATTLabel, ATTButton, ATTEdit, ATTCheckBox, ATTRadioButton, ATTGroupBox, ATTMemo, ATTComboBox, ATTListBox, ATTStaticText, ATTImage, ATTProgressBar, ATTTrackBar, ATTMenuItem, ATTMainMenu, ATTPopupMenu, - ATTTimer, ATTTrayIcon, ATTOpenDialog, ATTSaveDialog); + ATTTimer, ATTTrayIcon, ATTOpenDialog, ATTSaveDialog, ATTSelectDirectoryDialog, + ATTStringGrid); TMouseButton = (mbLeft, mbRight, mbMiddle); @@ -171,6 +183,7 @@ TVisualControl = class(TControl) fVisible, fTransparent: boolean; fCaption: string; + fAlignment: TAlignment; fShowCommand: integer; fAutoSize: boolean; EOnShow: TNotifyEvent; @@ -213,6 +226,7 @@ TVisualControl = class(TControl) property Color: integer read fColor write SetColor; property Transparent: boolean read fTransparent write fTransparent; property Caption: string read fCaption write SetCaption; + property Alignment: TAlignment read fAlignment write fAlignment; // Run-time modification ignored; write present only for dynamical control creation purpose property Visible: boolean read fVisible write SetVisible; property AutoSize: boolean read fAutoSize write fAutoSize; property ParentFont: boolean read fParentFont write fParentFont; @@ -256,8 +270,10 @@ TWinControl = class(TVisualControl) fArrowKeysInternal: boolean; // Controls using arrow keys internally fSpecTabStop: boolean; // For specific TabStop fKeyboardMsg: byte; // Specific for keyboard messages (see TComboBox): 0=Standard, 1=Do not Inherit, 2=Do not PostProcess, 3+=Specific + fTabTestFirstCtrl: TWinControl; fOldProc: TFNWndProc; fClicked: boolean; + fDoubleBuffered: boolean; EOnKeyPress: TKeyPressEvent; EOnKeyDown: TKeyEvent; EOnKeyUp: TKeyEvent; @@ -281,7 +297,6 @@ TWinControl = class(TVisualControl) function ForWMChar(var Msg: TWMKey; EOnForKeyPress: TKeyPressEvent): boolean; procedure ForControlCall(var Msg: TMessage; CControlIdent: integer; CATType: TAllControlTypes); function GetChildControl(Value: THandle): integer; - procedure ForWMHVScroll(var Msg: TWMHScroll); // (or TWMVScroll) procedure UpdTextSize(const Value: string); protected procedure ReadProperty(const PropName: string; Reader: TReader); override; @@ -296,19 +311,20 @@ TWinControl = class(TVisualControl) function GetTabOrder(): integer; procedure SetTabOrder(Value: integer); procedure ClickCall(ChangeFocus: boolean; DoSetFocus: boolean); - procedure ColorCall(var Msg: TWMCtlColorStatic); + function ColorCall(var Msg: TWMCtlColorStatic): boolean; function ColorForSubCont(SubContMsg: integer; SubConthWnd: THandle): boolean; virtual; procedure FormFocus(); function SpecialKeyProcess(var CharCode: Word): TKeyProcess; virtual; function GetSpecTabStop(): boolean; virtual; - procedure ComponentNotif(var Msg: TMessage); virtual; + function ForwardChildMsg(var Msg: TMessage; WndChild: THandle): boolean; virtual; + function ComponentNotif(var Msg: TMessage): boolean; virtual; procedure AdjustTextSize(var Size: TSize); virtual; - procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; - procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP; - procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN; - procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP; - procedure WMLDblClick(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; - procedure WMRDblClick(var Msg: TWMLButtonDblClk); message WM_RBUTTONDBLCLK; + procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; // Used in Grids, if "DefNo_StdMouseMessages" + procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP; // Used in Grids, if "DefNo_StdMouseMessages" + procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN; // Used in Grids, if "DefNo_StdMouseMessages" + procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP; // Used in Grids, if "DefNo_StdMouseMessages" + procedure WMLDblClick(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; // Used in Grids, if "DefNo_StdMouseMessages" + procedure WMRDblClick(var Msg: TWMRButtonDblClk); message WM_RBUTTONDBLCLK; // Used in Grids, if "DefNo_StdMouseMessages" procedure WMChar(var Msg: TWMChar); message WM_CHAR; procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN; procedure WMKeyUp(var Msg: TWMKeyUp); message WM_KEYUP; @@ -336,6 +352,7 @@ TWinControl = class(TVisualControl) procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE; procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL; // Used also in ComCtrls (TrackBar indirectly) procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL; // Used also in ComCtrls (TrackBar indirectly) + procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY; // Used also in Grids (StringGrid indirectly) property ArrowKeysInternal: boolean read fArrowKeysInternal write fArrowKeysInternal; property SpecTabStop: boolean read GetSpecTabStop write fSpecTabStop; property KeyboardMsg: byte read fKeyboardMsg write fKeyboardMsg; // (Not LCL/VCL standard) @@ -358,6 +375,7 @@ TWinControl = class(TVisualControl) property Enabled: boolean read fEnabled write SetEnabled; property Controls: TList read fControls; property ControlCount: integer read GetCCount write SetCCount; + property DoubleBuffered: boolean read fDoubleBuffered write fDoubleBuffered; property OnKeyPress: TKeyPressEvent read EOnKeyPress write EOnKeyPress; property OnKeyDown: TKeyEvent read EOnKeyDown write EOnKeyDown; property OnKeyUp: TKeyEvent read EOnKeyUp write EOnKeyUp; @@ -401,13 +419,11 @@ TPCustomForm = class(TCustomForm); // To access to protected part UITYPE_ACCELERATOR = 0; UITYPE_FOCUS = 1; -// // Can contain controls + // Can contain controls TContainControls = [ATTCustomForm, ATTGroupBox]; // Click on control doesn't set focus TNonClickFocusCtrl = [ATTCustomForm, ATTStaticText, ATTProgressBar]; -function KeysToShiftState(Keys: Word): TShiftState; forward; -function KeyDataToShiftState(KeyData: integer): TShiftState; forward; function TWCWndProc(hWnd: THandle; Msg: cardinal; awParam, alParam: NativeUInt): NativeUInt; stdcall; forward; //------------------------------------------------------------------------------ @@ -420,27 +436,6 @@ function LMessages_Dummy(const Msg: TLMCommand): boolean; end; {$ENDIF FPC} -function KeysToShiftState(Keys: Word): TShiftState; -begin - result := []; - if Keys and MK_SHIFT<>0 then Include(result, ssShift); - if Keys and MK_CONTROL<>0 then Include(result, ssCtrl); - if Keys and MK_LBUTTON<>0 then Include(result, ssLeft); - if Keys and MK_RBUTTON<>0 then Include(result, ssRight); - if Keys and MK_MBUTTON<>0 then Include(result, ssMiddle); - if LLCL_GetKeyState(VK_MENU) < 0 then Include(result, ssAlt); -end; - -function KeyDataToShiftState(KeyData: integer): TShiftState; -const - AltMask = $20000000; -begin - result := []; - if LLCL_GetKeyState(VK_SHIFT)<0 then Include(result, ssShift); - if LLCL_GetKeyState(VK_CONTROL)<0 then Include(result, ssCtrl); - if KeyData and AltMask<>0 then Include(result, ssAlt); -end; - function TWCWndProc(hWnd: THandle; Msg: cardinal; awParam, alParam: NativeUInt): NativeUInt; stdcall; var obj: TObject; dsp: TMessage; @@ -553,7 +548,7 @@ destructor TVisualControl.Destroy; end; procedure TVisualControl.ReadProperty(const PropName: string; Reader: TReader); -const Properties: array[0..10] of PChar = ( +const Properties: array[0..11] of PChar = ( 'Left', 'Top', 'Width', 'Height', 'Color', @@ -562,32 +557,34 @@ procedure TVisualControl.ReadProperty(const PropName: string; Reader: TReader); 'ParentFont', 'Visible', 'AutoSize', + 'Alignment', 'OnShow' ); begin case StringIndex(PropName, Properties) of - 0 : begin - fLeft := Reader.IntegerProperty; - UpdPosInGroup(USP_INGROUPLEFT); // FPC only - end; - 1 : begin - fTop := Reader.IntegerProperty; - UpdPosInGroup(USP_INGROUPTOP); // FPC only - end; - 2 : fWidth := Reader.IntegerProperty; - 3 : fHeight := Reader.IntegerProperty; - 4 : - begin - fColor := Reader.ColorProperty; - fHasDesignColor := true; - end; - 5 : fTransparent := Reader.BooleanProperty; - 6 : fCaption := Reader.StringProperty; - 7 : fParentFont := Reader.BooleanProperty; - 8 : fVisible := Reader.BooleanProperty; - 9 : fAutoSize := Reader.BooleanProperty; - 10: TMethod(EOnShow) := FindMethod(Reader); - else inherited; + 0 : begin + fLeft := Reader.IntegerProperty; + UpdPosInGroup(USP_INGROUPLEFT); // FPC only + end; + 1 : begin + fTop := Reader.IntegerProperty; + UpdPosInGroup(USP_INGROUPTOP); // FPC only + end; + 2 : fWidth := Reader.IntegerProperty; + 3 : fHeight := Reader.IntegerProperty; + 4 : + begin + fColor := Reader.ColorProperty; + fHasDesignColor := true; + end; + 5 : fTransparent := Reader.BooleanProperty; + 6 : fCaption := Reader.StringProperty; + 7 : fParentFont := Reader.BooleanProperty; + 8 : fVisible := Reader.BooleanProperty; + 9 : fAutoSize := Reader.BooleanProperty; + 10: Reader.IdentProperty(fAlignment, TypeInfo(TAlignment)); // ('Alignment' no standard) + 11: TMethod(EOnShow) := FindMethod(Reader); + else inherited; end; end; @@ -770,7 +767,7 @@ procedure TGraphicControl.ControlInit(RuntimeCreate: boolean); procedure TGraphicControl.CheckCallPaint(AHandle: THandle); begin if Visible then - if LLCL_RectVisible(AHandle, ClientRect()) then // Pb2 for CheckBox -> Not relevant + if LLCL_RectVisible(AHandle, ClientRect()) then // Pb2 for GroupBox -> Not relevant begin Canvas.Handle := AHandle; Paint; @@ -829,7 +826,7 @@ procedure TWinControl.ReadProperty(const PropName: string; Reader: TReader); ); begin case StringIndex(PropName, Properties) of - 0 : fCaption := Reader.StringProperty; + 0 : fCaption := Reader.StringProperty; // ('Text' no standard for TWinControl) 1 : TabOrder := Reader.IntegerProperty; 2 : fTabStop := Reader.BooleanProperty; 3 : fEnabled := Reader.BooleanProperty; @@ -839,7 +836,7 @@ procedure TWinControl.ReadProperty(const PropName: string; Reader: TReader); 7 : TMethod(EOnMouseDown) := FindMethod(Reader); 8 : TMethod(EOnMouseUp) := FindMethod(Reader); 9 : TMethod(EOnDblClick) := FindMethod(Reader); - else inherited; + else inherited; end; end; @@ -904,8 +901,6 @@ procedure TWinControl.CreateParams(var Params: TCreateParams); Style := WS_CHILD; if Visible then Style := Style or WS_VISIBLE; - if fTabStop then - Style := Style or WS_TABSTOP; X := fLeft; Y := fTop; Width := fWidth; @@ -927,7 +922,10 @@ procedure TWinControl.SetHandle(Value: THandle); fOldProc := TFNWndProc(LLCL_GetWindowLongPtr(fHandle, GWL_WNDPROC)); LLCL_SetWindowLongPtr(fHandle, GWL_USERDATA, NativeUInt(self)); // faster than SetProp() LLCL_SetWindowLongPtr(fHandle, GWL_WNDPROC, NativeUInt(@TWCWndProc)); - LLCL_SendMessage(fHandle, WM_SETFONT, WPARAM(Font.Handle), 0); + {$ifdef LLCL_OPT_NESTEDGROUPBOXWINXPFIX} + if not (ATType=ATTGroupBox) then + {$endif} + LLCL_SendMessage(fHandle, WM_SETFONT, WPARAM(Font.Handle), 0); SetEnabled(fEnabled); end; end; @@ -982,35 +980,44 @@ procedure TWinControl.ClickCall(ChangeFocus: boolean; DoSetFocus: boolean); EOnClick(self); end; -procedure TWinControl.ColorCall(var Msg: TWMCtlColorStatic); +function TWinControl.ColorCall(var Msg: TWMCtlColorStatic): boolean; var AColor: integer; var AHandle: THandle; var i: integer; begin + result := true; for i := 0 to fControls.Count-1 do begin if (Msg.ChildWnd=TWinControl(fControls[i]).Handle) or TWinControl(fControls[i]).ColorForSubCont(Msg.Msg, Msg.ChildWnd) then with TWinControl(fControls[i]) do begin - AColor := Font.Color; - if fParentFont and (fParent<>nil) then - AColor := fParent.Font.Color; + {$ifdef LLCL_OPT_NESTEDGROUPBOXWINXPFIX} + if ATType=ATTGroupBox then + LLCL_SelectObject(Msg.ChildDC, Font.Handle); + {$endif} + if fParentFont then + AColor := fParent.Font.Color // (fParent<>nil) + else + AColor := Font.Color; LLCL_SetTextColor(Msg.ChildDC, AColor); - AColor := Color; - AHandle := Canvas.Brush.Handle; if (ATType in [ATTButton, ATTCheckBox, ATTRadioButton, ATTGroupBox, ATTTrackBar]) or ((ATType=ATTStaticText) and Transparent) then - if fParent<>nil then begin - AColor := fParent.Color; + AColor := fParent.Color; // (fParent<>nil) AHandle := fParent.Canvas.Brush.Handle; - end; + end + else + begin + AColor := Color; + AHandle := Canvas.Brush.Handle; + end; LLCL_SetBkColor(Msg.ChildDC, AColor); Msg.Result := LRESULT(AHandle); exit; end; end; + result := false; end; // Color for a sub control (ComboBox) ? @@ -1031,9 +1038,25 @@ function TWinControl.SpecialKeyProcess(var CharCode: Word): TKeyProcess; result := tkStandard; // Standard (i.e. none), by default end; +// Call to forward messages to the concerned child control +function TWinControl.ForwardChildMsg(var Msg: TMessage; WndChild: THandle): boolean; +var ChildIndex: integer; +begin + result := true; + if WndChild<>0 then + begin + ChildIndex := GetChildControl(WndChild); + // Forwards messages to the concerned child control + if (ChildIndex>=0) then + with TWinControl(fControls[ChildIndex]) do + result := ComponentNotif(Msg); + end; +end; + // Messages forwarded to the concerned child control (received in parent form - equivalent of CN_* messages) -procedure TWinControl.ComponentNotif(var Msg: TMessage); +function TWinControl.ComponentNotif(var Msg: TMessage): boolean; begin + result := true; end; // Text size adjustement @@ -1111,13 +1134,14 @@ procedure TWinControl.NewFormFocus(NewFocus: TNewFocusType); if aControl<>nil then with aControl do if NewParentFocus(NewCallFocus, CurTabOrder, NewControl, true) then - NewControl.SetFocus(); + NewControl.SetFocus(); end; // Focus for new control in parent (Can be recursively called) function TWinControl.NewParentFocus(NewFocus: TNewFocusType; ContTabOrder: integer; var NewControl: TWinControl; UpperAllowed: boolean): boolean; var CurTabOrder, NewTabOrder, NewOverTabOrder: integer; var NewIndex, NewOverIndex: integer; +var FirstCtrlCall: boolean; var i: integer; begin result := false; @@ -1182,7 +1206,18 @@ function TWinControl.NewParentFocus(NewFocus: TNewFocusType; ContTabOrder: integ with TWinControl(fControls[NewIndex]) do // Container (Groupbox) and tabulation, so search in lower level if ((NewFocus in [tftNextGroup, tftPrevGroup]) and (not fTabStop) and (ATType in [ATTGroupBox])) then - result := NewParentFocus(NewFocus, -1, NewControl, true) + begin + FirstCtrlCall := false; + if fTabTestFirstCtrl=nil then + begin + FirstCtrlCall := true; + fTabTestFirstCtrl := TWinControl(self.fControls[NewIndex]); + end; + if FirstCtrlCall or (fTabTestFirstCtrl<>TWinControl(self.fControls[NewIndex])) then + result := NewParentFocus(NewFocus, -1, NewControl, true); + if FirstCtrlCall then + fTabTestFirstCtrl := nil; + end else begin NewControl := TWinControl(self.fControls[NewIndex]); @@ -1327,7 +1362,7 @@ function TWinControl.ForWMKeyDownUpForm(var Msg: TWMKey; UpOrDown: integer): boo function TWinControl.ForWMKeyDownUp(var Msg: TWMKey; EOnForKeyDownUp: TKeyEvent): boolean; begin if Assigned(EOnForKeyDownUp) then - EOnForKeyDownUp(self, Msg.CharCode, KeyDataToShiftState(Msg.KeyData)); + EOnForKeyDownUp(self, Msg.CharCode, TShiftState(LLCLS_KeyDataToShiftState(Msg.KeyData))); result := (Msg.CharCode=0); end; @@ -1372,18 +1407,6 @@ function TWinControl.GetChildControl(Value: THandle): integer; end; end; -procedure TWinControl.ForWMHVScroll(var Msg: TWMHScroll); -var ChildIndex: integer; -begin - if Msg.ScrollBar<>0 then - begin - ChildIndex := GetChildControl(Msg.ScrollBar); - // Forwards scroll messages to the concerned child control - if (ChildIndex>=0) then - with TWinControl(fControls[ChildIndex]) do ComponentNotif(TMessage(Msg)); - end; -end; - // Text size update (AutoSize) procedure TWinControl.UpdTextSize(const Value: string); var Size: TSize; @@ -1482,12 +1505,12 @@ procedure TWinControl.WMLButtonDown(var Msg: TWMLButtonDown); fClicked := true; // OnMouseDown for control if Assigned(EOnMouseDown) then - EOnMouseDown(self, mbLeft, KeysToShiftState(Msg.Keys), Msg.XPos, Msg.YPos); + EOnMouseDown(self, mbLeft, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)), Msg.XPos, Msg.YPos); end; procedure TWinControl.WMLButtonUp(var Msg: TWMLButtonUp); begin - if ATType<>ATTGroupBox then // Because of WM_NCHitTest message modification + if ATType<>ATTGroupBox then // Because of WM_NCHitTest message modification inherited; // Note: Clicks for Windows button classes (Button, CheckBox, RadioButton and // StaticText, but not GroupBox) are processed through BN_CLICKED messages @@ -1498,7 +1521,7 @@ procedure TWinControl.WMLButtonUp(var Msg: TWMLButtonUp); fClicked := false; // OnMouseUp for control if Assigned(EOnMouseUp) then - EOnMouseUp(self, mbLeft, KeysToShiftState(Msg.Keys), Msg.XPos, Msg.YPos); + EOnMouseUp(self, mbLeft, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)), Msg.XPos, Msg.YPos); end; procedure TWinControl.WMRButtonDown(var Msg: TWMRButtonDown); @@ -1506,7 +1529,7 @@ procedure TWinControl.WMRButtonDown(var Msg: TWMRButtonDown); inherited; // OnMouseDown for control if Assigned(EOnMouseDown) then - EOnMouseDown(self, mbRight, KeysToShiftState(Msg.Keys), Msg.XPos, Msg.YPos); + EOnMouseDown(self, mbRight, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)), Msg.XPos, Msg.YPos); end; procedure TWinControl.WMRButtonUp(var Msg: TWMRButtonUp); @@ -1514,7 +1537,7 @@ procedure TWinControl.WMRButtonUp(var Msg: TWMRButtonUp); inherited; // OnMouseUp only for control (no click for right button) if Assigned(EOnMouseUp) then - EOnMouseUp(self, mbRight, KeysToShiftState(Msg.Keys), Msg.XPos, Msg.YPos); + EOnMouseUp(self, mbRight, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)), Msg.XPos, Msg.YPos); end; procedure TWinControl.WMLDblClick(var Msg: TWMLButtonDblClk); @@ -1528,7 +1551,7 @@ procedure TWinControl.WMLDblClick(var Msg: TWMLButtonDblClk); // (Order different for Delphi and FPC) {$IFDEF FPC} if Assigned(EOnMouseDown) then - EOnMouseDown(self, mbLeft, KeysToShiftState(Msg.Keys) + [ssDouble], Msg.XPos, Msg.YPos); + EOnMouseDown(self, mbLeft, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)) + [ssDouble], Msg.XPos, Msg.YPos); if not (ATType in [ATTButton]) then if Assigned(EOnDblClick) then EOnDblClick(self); @@ -1537,7 +1560,7 @@ procedure TWinControl.WMLDblClick(var Msg: TWMLButtonDblClk); if Assigned(EOnDblClick) then EOnDblClick(self); if Assigned(EOnMouseDown) then - EOnMouseDown(self, mbLeft, KeysToShiftState(Msg.Keys) + [ssDouble], Msg.XPos, Msg.YPos); + EOnMouseDown(self, mbLeft, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)) + [ssDouble], Msg.XPos, Msg.YPos); {$ENDIF} end; @@ -1546,7 +1569,7 @@ procedure TWinControl.WMRDblClick(var Msg: TWMRButtonDblClk); inherited; // Replaced by OnMouseDown for control (no double click for right button) if Assigned(EOnMouseDown) then - EOnMouseDown(self, mbRight, KeysToShiftState(Msg.Keys) + [ssDouble], Msg.XPos, Msg.YPos); + EOnMouseDown(self, mbRight, TShiftState(LLCLS_KeysToShiftState(Msg.Keys)) + [ssDouble], Msg.XPos, Msg.YPos); end; procedure TWinControl.WMChar(var Msg: TWMChar); @@ -1610,7 +1633,7 @@ procedure TWinControl.WMChar(var Msg: TWMChar); case Msg.CharCode of VK_TAB: // Tabulation begin - if ssShift in KeyDataToShiftState(Msg.KeyData) then + if ssShift in TShiftState(LLCLS_KeyDataToShiftState(Msg.KeyData)) then TabFocusType := tftPrevGroup // Shift tabulation (previous group control) else TabFocusType := tftNextGroup; // Tabulation (next group control) @@ -1657,7 +1680,7 @@ procedure TWinControl.WMKeyUp(var Msg: TWMKeyUp); procedure TWinControl.WMSysKeyDown(var Msg: TWMSysKeyDown); begin // UI indicators... - if ssAlt in KeyDataToShiftState(Msg.KeyData) then + if ssAlt in TShiftState(LLCLS_KeyDataToShiftState(Msg.KeyData)) then ClearUI(UITYPE_ACCELERATOR); if ForWMKeyDownUpForm(Msg, 0) then // 0=Down exit; @@ -1689,26 +1712,59 @@ procedure TWinControl.WMSysChar(var Msg: TWMSysChar); end; procedure TWinControl.WMPaint(var Msg: TWMPaint); -var PSDummy: TPaintStruct; +var PSForm: TPaintStruct; +{$ifdef LLCL_OPT_DOUBLEBUFF} +var hSaveHDC: HDC; +var hMemBMP, hSaveObj: HGDIOBJ; +var FormRect: TRECT; +{$endif} var i: integer; begin - if (fGraphics.Count>0) or (ATType=ATTCustomform) then // Only if graphical controls are present, or possible OnPaint event - with Canvas do begin - if ATType=ATTCustomform then - Handle := LLCL_BeginPaint(self.fHandle, PSDummy) - else - Handle := LLCL_GetDC(self.fHandle); // Pb1 for CheckBox -> Flickering - for i := 0 to fGraphics.Count-1 do - with TGraphicControl(fGraphics[i]) do - CheckCallPaint(Handle); - if ATType=ATTCustomform then - begin - TPCustomForm(self).CallOnPaint; // Currently, only Forms can have this property - LLCL_EndPaint(self.fHandle, PSDummy); - end - else - LLCL_ReleaseDC(self.fHandle, Handle); - end; + if (fGraphics.Count>0) or (ATType=ATTCustomForm) then // Only if graphical controls are present, or possible OnPaint event + with Canvas do + begin +{$ifdef LLCL_OPT_DOUBLEBUFF} + hSaveHDC := 0; hMemBMP := 0; hSaveObj := 0; // (to avoid compilation warning) +{$endif} + if ATType=ATTCustomForm then + begin + Handle := LLCL_BeginPaint(self.fHandle, PSForm); +{$ifdef LLCL_OPT_DOUBLEBUFF} + if fDoubleBuffered then + begin + FormRect := ClientRect(); + hSaveHDC := Handle; + Handle := LLCL_CreateCompatibleDC(hSaveHDC); + hMemBMP := LLCL_CreateCompatibleBitmap(hSaveHDC, FormRect.Right - FormRect.Left, FormRect.Bottom - FormRect.Top); + hSaveObj := LLCL_SelectObject(Handle, hMemBMP); + end; +{$endif} + LLCL_FillRect(Handle, PSForm.rcPaint, Brush.Handle); // (See WM_ERASEBKGND) + end + else + Handle := LLCL_GetDC(self.fHandle); // Pb1 for GroupBox -> Flickering + for i := 0 to fGraphics.Count-1 do + with TGraphicControl(fGraphics[i]) do + CheckCallPaint(Handle); + if ATType=ATTCustomForm then + begin + TPCustomForm(self).CallOnPaint; // Currently, only Forms can have this property +{$ifdef LLCL_OPT_DOUBLEBUFF} + if fDoubleBuffered then + begin + LLCL_BitBlt(hSaveHDC, PSForm.rcPaint.Left, PSForm.rcPaint.Top, PSForm.rcPaint.Right - PSForm.rcPaint.Left, PSForm.rcPaint.Bottom - PSForm.rcPaint.Top, Handle, PSForm.rcPaint.Left, PSForm.rcPaint.Top, SRCCOPY); + LLCL_SelectObject(Handle, hSaveObj); + LLCL_DeleteObject(hMemBMP); + LLCL_DeleteDC(Handle); + end; +{$endif} + LLCL_EndPaint(self.fHandle, PSForm); + // (No inherited) + exit; + end + else + LLCL_ReleaseDC(self.fHandle, Handle); + end; inherited; end; @@ -1725,49 +1781,47 @@ procedure TWinControl.WMSetFocus(var Msg: TWMSetFocus); end; procedure TWinControl.WMEraseBkGnd(var Msg: TWMEraseBkGnd); -var BrushColorSave: integer; +var CtlOrParent: TWinControl; begin // Modified for some TWinControls - if (ATType in [ATTCustomForm, ATTGroupBox, ATTComboBox]) - or ((ATType=ATTStaticText) and (not Transparent)) then - begin - with Canvas do begin - Handle := Msg.DC; - BrushColorSave := Brush.Color; - if ATType=ATTComboBox then // (Only csSimple style concerned) - Brush.Color := self.Parent.Color; - FillRect(ClientRect()); - if ATType=ATTComboBox then // (Only csSimple style concerned) - Brush.Color := BrushColorSave; - end; - Msg.result := 1; - end + if ATType=ATTCustomForm then + Msg.Result := 1 // (Done inside WM_PAINT) else - inherited; + if (ATType=ATTGroupBox) or ((ATType=ATTComboBox) and (TComboBox(self).Style=csSimple)) then + begin + if (ATType=ATTComboBox) then + CtlOrParent := fParent // (fParent<>nil) + else + CtlOrParent := self; + LLCL_FillRect(Msg.DC, ClientRect(), CtlOrParent.Canvas.Brush.Handle); + Msg.Result := 1; + end + else + inherited; end; procedure TWinControl.WMColorStatic(var Msg: TWMCtlColorStatic); begin - inherited; - ColorCall(Msg); + if not ColorCall(Msg) then + inherited; end; procedure TWinControl.WMColorEdit(var Msg: TWMCtlColorEdit); begin - inherited; - ColorCall(Msg); + if not ColorCall(Msg) then + inherited; end; procedure TWinControl.WMColorListBox(var Msg: TWMCtlColorListBox); begin - inherited; - ColorCall(Msg); + if not ColorCall(Msg) then + inherited; end; procedure TWinControl.WMColorButton(var Msg: TWMCtlColorBtn); begin - inherited; - ColorCall(Msg); + if not ColorCall(Msg) then + inherited; end; procedure TWinControl.WMTimer(var Msg: TWMTimer); @@ -1784,47 +1838,52 @@ procedure TWinControl.WMTray(var Msg: TMessage); procedure TWinControl.WMCommand(var Msg: TWMCommand); var ChildIndex: integer; -var i: integer; begin inherited; if Msg.Ctl<>0 then begin ChildIndex := GetChildControl(Msg.Ctl); - case Msg.NotifyCode of - BN_CLICKED: - if ChildIndex>=0 then - begin - with TWinControl(fControls[ChildIndex]) do - begin - ClickCall(false, false); - // No more in click state - fClicked := false; - end; - end - else - for i := 0 to fControls.Count-1 do - with TWinControl(fControls[i]) do - if (ATType in [ATTGroupBox]) then - WMCommand(Msg); - end; - // Forwards WM_COMMAND messages to the concerned child control - if (Msg.Msg=WM_COMMAND) and (ChildIndex>=0) then - with TWinControl(fControls[ChildIndex]) do ComponentNotif(TMessage(Msg)); + if ChildIndex>=0 then + with TWinControl(fControls[ChildIndex]) do + case Msg.NotifyCode of + BN_CLICKED: + begin + ClickCall(false, false); + // No more in click state + fClicked := false; + end; + else + ComponentNotif(TMessage(Msg)); + end; end; end; procedure TWinControl.WMSize(var Msg: TWMSize); begin inherited; - fWidth := Msg.Width; - fHeight := Msg.Height; + // Currently unused for other controls, because + // only the client area is concerned + if ATType=ATTCustomForm then + begin + fWidth := Msg.Width; + fHeight := Msg.Height; + end + else + // Forces redraw + if ATType=ATTStaticText then + Caption := fCaption; end; procedure TWinControl.WMMove(var Msg: TWMMove); begin inherited; - fLeft := Msg.XPos; - fTop := Msg.YPos; + // Currently unused for other controls, because + // only the client area is concerned + if ATType=ATTCustomForm then + begin + fLeft := Msg.XPos; + fTop := Msg.YPos; + end; end; procedure TWinControl.WMNCHitTest(var Msg: TWMNCHitTest); @@ -1844,18 +1903,24 @@ procedure TWinControl.WMMouseMove(var Msg: TWMMouseMove); procedure TWinControl.WMHScroll(var Msg: TWMHScroll); begin inherited; - ForWMHVScroll(Msg); + ForwardChildMsg(TMessage(Msg), Msg.ScrollBar); end; procedure TWinControl.WMVScroll(var Msg: TWMVScroll); begin inherited; - ForWMHVScroll(TWMHScroll(Msg)); + ForwardChildMsg(TMessage(Msg), Msg.ScrollBar); +end; + +procedure TWinControl.WMNotify(var Msg: TWMNotify); +begin + if ForwardChildMsg(TMessage(Msg), Msg.NMHdr^.hwndFrom) then + inherited; end; { TMouse } -function TMouse.GetCursorPos: TPoint; +function TMouse.GetCursorPos(): TPoint; begin LLCL_GetCursorPos(result); end; diff --git a/sources/Dialogs.pas b/sources/Dialogs.pas index f3941e2..a9c1ee2 100644 --- a/sources/Dialogs.pas +++ b/sources/Dialogs.pas @@ -12,15 +12,18 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * SelectDirectory added (for FPC/Lazarus) + * TSelectDirectoryDialog added for FPC/Lazarus (not enabled by default - see LLCL_OPT_USESELECTDIRECTORYDIALOG in LLCLOptions.inc) Version 1.00: * Application.BiDiMode used for ShowMessage (through Application.MessageBox) * TOpenDialog and TSaveDialog implemented @@ -119,9 +122,20 @@ TSaveDialog = class(TOpenDialog) public constructor Create(AOwner: TComponent); override; end; -{$endif} + +{$ifdef LLCL_OPT_USESELECTDIRECTORYDIALOG} + TSelectDirectoryDialog = class(TOpenDialog) + public + constructor Create(AOwner: TComponent); override; + function Execute: boolean; override; + end; +{$endif LLCL_OPT_USESELECTDIRECTORYDIALOG} +{$endif LLCL_OPT_USEDIALOG} procedure ShowMessage(const Msg: string); +{$IFDEF FPC} // SelectDirectory is in FileCtrl.pas for Delphi +function SelectDirectory(const Caption: string; const InitialDirectory: string; out Directory: string): Boolean; overload; +{$ENDIF FPC} //------------------------------------------------------------------------------ @@ -129,9 +143,10 @@ implementation uses {$ifdef LLCL_OPT_USEDIALOG} - {$IFDEF FPC}{$ELSE}CommDlg,{$ENDIF} + {$IFDEF FPC}FileCtrl,{$ELSE}CommDlg,{$ENDIF} Forms, SysUtils; {$else} + {$IFDEF FPC}FileCtrl,{$ENDIF} Forms; {$endif} @@ -171,6 +186,13 @@ procedure ShowMessage(const Msg: string); Application.MessageBox(@Msg[1], @Application.Title[1], MB_OK or MB_ICONMASK); end; +{$IFDEF FPC} +function SelectDirectory(const Caption: string; const InitialDirectory: string; out Directory: string): Boolean; +begin + result := FC_SelectDirectory(Caption, InitialDirectory, [sdNewFolder, sdShowEdit, sdNewUI], Directory); +end; +{$ENDIF FPC} + {$ifdef LLCL_OPT_USEDIALOG} //------------------------------------------------------------------------------ @@ -292,13 +314,33 @@ constructor TSaveDialog.Create(AOwner: TComponent); inherited; ATType := ATTSaveDialog; end; -{$endif} + +{$ifdef LLCL_OPT_USESELECTDIRECTORYDIALOG} +{ TSelectDirectoryDialog } + +constructor TSelectDirectoryDialog.Create(AOwner: TComponent); +begin + inherited; + ATType := ATTSelectDirectoryDialog; +end; + +function TSelectDirectoryDialog.Execute: boolean; +var sdOptions: TSelectDirExtOpts; +begin + if ofOldStyleDialog in Options then + sdOptions := [] + else + sdOptions := [sdNewFolder, sdShowEdit, sdNewUI]; + result := FC_SelectDirectory(fTitle, fInitialDir, sdOptions, fFileName); +end; +{$endif LLCL_OPT_USESELECTDIRECTORYDIALOG} //------------------------------------------------------------------------------ +{$endif} {$ifdef LLCL_OPT_USEDIALOG} initialization - RegisterClasses([TOpenDialog, TSaveDialog]); + RegisterClasses([TOpenDialog, TSaveDialog {$ifdef LLCL_OPT_USESELECTDIRECTORYDIALOG}, TSelectDirectoryDialog{$endif}]); {$endif} {$IFDEF FPC} diff --git a/sources/ExtCtrls.pas b/sources/ExtCtrls.pas index fd202c4..3bb4970 100644 --- a/sources/ExtCtrls.pas +++ b/sources/ExtCtrls.pas @@ -12,15 +12,19 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * TImage: Changed added (when bitmap data are changed) + * TImage: SetStretch modified + * LLCL_OPT_USEIMAGE option added (enabled by default - see LLCLOptions.inc) Version 1.00: * TImage: Show and Hide added (see TGraphicControl) * TImage: Stretch added @@ -66,6 +70,7 @@ {$I LLCLFPCInc.inc} // For mode {$undef LLCL_FPC_MODESECTION} {$ENDIF} +{$ifdef FPC_OBJFPC} {$define LLCL_OBJFPC_MODE} {$endif} // Object pascal mode {$I LLCLOptions.inc} // Options @@ -78,6 +83,8 @@ interface Classes, Controls, {$ifdef LLCL_OPT_USEMENUS}Menus,{$endif} Graphics; type + +{$ifdef LLCL_OPT_USEIMAGE} TImage = class(TGraphicControl) private fPicture: TPicture; @@ -85,6 +92,7 @@ TImage = class(TGraphicControl) function GetPicture(): TPicture; procedure SetPicture(APicture: TPicture); procedure SetStretch(const Value: boolean); + procedure Changed(Sender: TObject); protected procedure ReadProperty(const PropName: string; Reader: TReader); override; function SubProperty(const SubPropName: string): TPersistent; override; @@ -95,6 +103,7 @@ TImage = class(TGraphicControl) property Picture: TPicture read GetPicture write SetPicture; property Stretch: boolean read fStretch write SetStretch; end; +{$endif LLCL_OPT_USEIMAGE} TTimer = class(TNonVisualControl) private @@ -187,8 +196,10 @@ implementation {$PUSH} {$HINTS OFF} {$ENDIF} +{$ifdef LLCL_OPT_USEIMAGE} type TPPicture = class(TPicture); // To access to protected part +{$endif LLCL_OPT_USEIMAGE} const NIF_MESSAGE = $00000001; // SysTray @@ -217,6 +228,7 @@ function LMessages_Dummy(const Msg: TLMCommand): boolean; end; {$ENDIF FPC} +{$ifdef LLCL_OPT_USEIMAGE} { TImage } constructor TImage.Create(AOwner: TComponent); @@ -236,6 +248,7 @@ function TImage.GetPicture(): TPicture; begin if fPicture=nil then fPicture := TPicture.Create; + fPicture.OnChange := {$IFDEF LLCL_OBJFPC_MODE}@{$ENDIF}Changed; result := fPicture; end; @@ -248,7 +261,13 @@ procedure TImage.SetStretch(const Value: boolean); begin if fStretch=Value then exit; fStretch := Value; - Show; + Changed(self); +end; + +procedure TImage.Changed(Sender: TObject); +begin + if Visible then + InvalidateEx(true); end; procedure TImage.ReadProperty(const PropName: string; Reader: TReader); @@ -274,6 +293,7 @@ procedure TImage.Paint; if fPicture<>nil then TPPicture(fPicture).DrawRect(ClientRect, Canvas, fStretch); // not VCL standard, but works for BITMAP end; +{$endif LLCL_OPT_USEIMAGE} { TTimer } @@ -530,7 +550,7 @@ procedure TTrayIcon.ShowBalloonHint; //------------------------------------------------------------------------------ initialization - RegisterClasses([TImage, TTimer, TTrayIcon]); + RegisterClasses([TTimer, TTrayIcon {$ifdef LLCL_OPT_USEIMAGE}, TImage{$endif}]); {$IFDEF FPC} {$POP} diff --git a/sources/FileCtrl.pas b/sources/FileCtrl.pas new file mode 100644 index 0000000..6e1d65f --- /dev/null +++ b/sources/FileCtrl.pas @@ -0,0 +1,117 @@ +unit FileCtrl; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * SelectDirectory added (for Delphi) +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +uses + LLCLOSInt; + +type + TSelectDirExtOpt = (sdNewFolder, sdShowEdit, sdShowShares, sdNewUI, + sdShowFiles, sdValidateDir); + TSelectDirExtOpts = set of TSelectDirExtOpt; + +{$IFNDEF FPC} // SelectDirectory is in Dialogs.pas for FPC/Lazarus +function SelectDirectory(const Caption: string; const Root: string; var Directory: string): boolean; overload; +{$if CompilerVersion >= 18)} // Delphi 2006 or after +function SelectDirectory(const Caption: string; const Root: string; var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): boolean; overload; +{$ifend} +{$ENDIF} + +// (Not VCL/LCL standard - Called from Dialogs.pas for FPC) +function FC_SelectDirectory(const Caption: string; const InitialDirectory: string; Options: TSelectDirExtOpts; var Directory: string): Boolean; + +//------------------------------------------------------------------------------ + +implementation + +uses + {$IFNDEF FPC}ShlObj,{$ENDIF} + Forms; + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +//------------------------------------------------------------------------------ + +{$IFNDEF FPC} +function SelectDirectory(const Caption: string; const Root: string; var Directory: string): Boolean; +begin + result := FC_SelectDirectory(Caption, Root, [], Directory); +end; + +{$if CompilerVersion >= 18)} // Delphi 2006 or after +function SelectDirectory(const Caption: string; const Root: string; var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: TWinControl = nil): boolean; overload; +begin + result := FC_SelectDirectory(Caption, Root, Options, Directory); +end; +{$ifend} + +{$ENDIF} + +function FC_SelectDirectory(const Caption: string; const InitialDirectory: string; Options: TSelectDirExtOpts; var Directory: string): Boolean; +var BrowseInfo: TBrowseInfo; +begin + FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); + BrowseInfo.hwndOwner := Application.MainForm.Handle; + BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; + if (sdNewUI in Options) or (sdShowShares in Options) then + begin + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NEWDIALOGSTYLE; + if not (sdNewFolder in Options) then + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_NONEWFOLDERBUTTON; + if (sdShowShares in Options) then + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_SHAREABLE; + end; + if (sdShowEdit in Options) then + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_EDITBOX; + if (sdShowFiles in Options) then + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_BROWSEINCLUDEFILES; + if (sdValidateDir in Options) and (sdShowEdit in Options) then + BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_VALIDATE; + result := LLCLS_SH_BrowseForFolder(BrowseInfo, Caption, InitialDirectory, Directory); +end; + +//------------------------------------------------------------------------------ + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/FileUtil.pas b/sources/FileUtil.pas index 36654f1..b79fdf0 100644 --- a/sources/FileUtil.pas +++ b/sources/FileUtil.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. * UTF8 file functions (equivalent of SysUtils ones - mapped to LazFileutils) diff --git a/sources/Forms.pas b/sources/Forms.pas index e9673be..6ee6c4b 100644 --- a/sources/Forms.pas +++ b/sources/Forms.pas @@ -12,15 +12,19 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * Bug fix: Color in TCustomForm + * TForm: 'BorderStyle', 'Position' and 'FormStyle' properties now accessible (design time only) + * TApplication: AppHandle moved in protected part Version 1.00: * Old unused properties removed: OldCreateOrder, PixelsPerInch and TextHeight * IsAccel function added @@ -177,6 +181,9 @@ TCustomForm = class(TWinControl) property ActiveControl: TWinControl read fActiveControl write SetActiveControl; property KeyPreview: boolean read fKeyPreview write fKeyPreview; property WindowState: TWindowState read fWindowState write SetWindowState; + property BorderStyle: TFormBorderStyle read fBorderStyle write fBorderStyle; // Run-time modification ignored; write present only for dynamical control creation purpose + property Position: TPosition read fPosition write fPosition; // Run-time modification ignored; write present only for dynamical control creation purpose + property FormStyle: TFormStyle read fFormStyle write fFormStyle; // Run-time modification ignored; write present only for dynamical control creation purpose {$ifdef LLCL_OPT_USEMENUS} property Menu: TMainMenu read fMenu write fMenu; {$endif} @@ -213,7 +220,6 @@ TApplication = class(TComponent) {$endif} EOnMinimize, EOnRestore: TNotifyEvent; - function AppHandle(): THandle; procedure SetTitle(const Value: string); procedure SetBiDiMode(const Value: TBiDiMode); {$ifndef DefNo_MainFormOnTaskBar} @@ -224,6 +230,8 @@ TApplication = class(TComponent) {$ifdef LLCL_OPT_TOPFORM} procedure SetVisible(ShowCall: boolean); {$endif} + protected + function AppHandle(): THandle; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -328,7 +336,7 @@ function RPos(const SubStr : string; const S: string): cardinal; { TCustomForm } -constructor TCustomForm.Create(AOwner:TComponent); +constructor TCustomForm.Create(AOwner: TComponent); begin ATType := ATTCustomForm; // Needed before inherited inherited; @@ -427,7 +435,8 @@ procedure TCustomForm.CreateHandle; SetBounds(aRect.Left, aRect.Top, Width, Height); // UI if CheckWin32Version(LLCL_WIN2000_MAJ, LLCL_WIN2000_MIN) then - LLCL_PostMessage(Handle, WM_CHANGEUISTATE, WPARAM(UIS_INITIALIZE or ((UISF_HIDEFOCUS or UISF_HIDEACCEL) shl 16)), 0); + // (Clear UI states if LLCL_OPT_NESTEDGROUPBOXWINXPFIX activated) + LLCL_PostMessage(Handle, WM_CHANGEUISTATE, WPARAM({$ifdef LLCL_OPT_NESTEDGROUPBOXWINXPFIX}UIS_CLEAR{$else}UIS_INITIALIZE{$endif} or ((UISF_HIDEFOCUS or UISF_HIDEACCEL) shl 16)), 0); end; procedure TCustomForm.CreateParams(var Params : TCreateParams); @@ -833,7 +842,6 @@ procedure TApplication.CreateHandle; var WndClass: TWndClass; var Style, ExStyle: cardinal; var SystemMenu: THandle; -var sClassName: string; // Conversion needed (especially because System and RTL are not fully Unicode for FPC) begin // Application Class FillChar(WndClass, SizeOf(WndClass), 0); @@ -850,8 +858,7 @@ procedure TApplication.CreateHandle; ExStyle := 0; if (not fMainFormOnTaskBar) then ExStyle := ExStyle or WS_EX_APPWINDOW; - sClassName := string(WndClass.lpszClassName); - fHandle := LLCL_CreateWindowEx(ExStyle, @sClassName[1], @fTitle[1], Style, + fHandle := LLCL_CreateWindowEx(ExStyle, TAPPL_CLASS, @fTitle[1], Style, LLCL_GetSystemMetrics(SM_CXSCREEN) div 2, LLCL_GetSystemMetrics(SM_CYSCREEN) div 2, 0, 0, 0, 0, WndClass.hInstance, nil); SystemMenu := LLCL_GetSystemMenu(fHandle, False); diff --git a/sources/Graphics.pas b/sources/Graphics.pas index 72ee388..08334cf 100644 --- a/sources/Graphics.pas +++ b/sources/Graphics.pas @@ -12,15 +12,20 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * TBitmap: PNG files support added (not enabled by default - see LLCL_OPT_PNGSUPPORT/LLCL_OPT_PNGSIMPLIFIED in LLCLOptions.inc) + * TBitmap: transparent bitmap support added (not enabled by default - see LLCL_OPT_IMGTRANSPARENT in LLCLOptions.inc) + * TGraphicData: ClearData added + * TGraphicData, TPicture: OnChange added (when bitmap data are changed) Version 1.00: * TIcon (minimal) added - Intermediate TGraphicData class created * TPicture: Stretch and LoadFromFile added (only for .BMP bitmap files) @@ -95,7 +100,7 @@ TFont = class(TPersistent) fStyle: TFontStyles; function GetHandle(): THandle; protected - procedure ReadProperty(const PropName: string; Reader: TReader); override; + procedure ReadProperty(const PropName: string; Reader: TReader); override; public destructor Destroy; override; procedure Assign(AFont: TFont); @@ -169,17 +174,37 @@ TGraphicData = class(TPersistent) private fSize: integer; fData: pByte; + EOnChange: TNotifyEvent; + procedure ClearData(); protected procedure ReadProperty(const PropName: string; Reader: TReader); override; + property BinaryData: pByte read fData write fData; // (Not standard) + property BinaryDataSize: integer read fSize write fSize; // " " public destructor Destroy; override; + property OnChange: TNotifyEvent read EOnChange write EOnChange; end; TBitmap = class(TGraphicData) private +{$IFDEF LLCL_OPT_IMGTRANSPARENT} + TranspType: integer; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} function GetEmpty(): boolean; - procedure LoadFromMemory(BufferBitmap: pointer; BufferSize: integer); procedure DrawRect(const R: TRect; Canvas: TCanvas; Stretch: boolean); + procedure MoveToData(BufferBitmap: pointer; BufferSize: integer); +{$IFDEF LLCL_OPT_PNGSUPPORT} + function ConvertFromPNG(): boolean; +{$ENDIF LLCL_OPT_PNGSUPPORT} +{$IFDEF LLCL_OPT_IMGTRANSPARENT} + procedure TranspPreProcess(); + function TranspProcess(DestHDC: HDC; const R: TRect; Stretch: boolean): boolean; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} + protected +{$IFDEF LLCL_OPT_PNGSUPPORT} + procedure ReadProperty(const PropName: string; Reader: TReader); override; +{$ENDIF LLCL_OPT_PNGSUPPORT} + function LoadFromMemory(BufferBitmap: pointer; BufferSize: integer): boolean; public procedure Assign(ABitmap: TBitmap); procedure LoadFromResourceName(Instance: THandle; const ResName: string); @@ -189,9 +214,12 @@ TBitmap = class(TGraphicData) /// this TImage component only handle a bitmap TPicture = class(TPersistent) - fBitmap: TBitmap; - function GetBitmap(): TBitmap; - procedure SetBitmap(ABitmap: TBitMap); + private + fBitmap: TBitmap; + EOnChange: TNotifyEvent; + function GetBitmap(): TBitmap; + procedure SetBitmap(ABitmap: TBitmap); + procedure SetOnChange(Value: TNotifyEvent); protected procedure DrawRect(const R: TRect; Canvas: TCanvas; Stretch: boolean); public @@ -202,6 +230,7 @@ TPicture = class(TPersistent) {$ENDIF FPC} procedure LoadFromFile(const FileName: string); property Bitmap: TBitmap read GetBitmap write SetBitmap; + property OnChange: TNotifyEvent read EOnChange write SetOnChange; end; TIcon = class(TGraphicData) @@ -215,37 +244,6 @@ TIcon = class(TGraphicData) property Handle: THandle read fHandle write SetHandle; end; - PBMP = ^TBMP; - // match DFM binary content - TBMP = packed record - ClassName: string[7]; // "TBitmap" - Size: integer; - FileHeader: TBitmapFileHeader; - InfoHeader: TBitmapInfo; - end; - - TIconHeader = packed record - idReserved: Word; // Reserved (must always be 0) - idType: Word; // Image type (1 for icon) - idCount: Word; // Number of images - end; - TIconDirEntry = packed record - bWidth: Byte; // Image width in pixels - bHeight: Byte; // Image height in pixels - bColorCount: Byte; // Number of colors in color palette (0 if no color palette) - bReserved: Byte; // Reserved (must be 0) - wPlanes: Word; // Color planes (0 or 1) - wBitCount: Word; // Bits per pixel - dwBytesInRes: DWORD; // Size of image data - dwImageOffset: DWORD; // Offset of BMP/PNG data - end; - P1ICO = ^T1ICO; - T1ICO = packed record - FullSize: DWORD; - IconHeader: TIconHeader; - IconDirEntry: TIconDirEntry; - end; - const clBlack = $000000; clMaroon = $000080; @@ -298,12 +296,75 @@ TIcon = class(TGraphicData) implementation uses +{$IFDEF LLCL_OPT_PNGSUPPORT} + LLCLPng, +{$ENDIF LLCL_OPT_PNGSUPPORT} SysUtils; {$IFDEF FPC} {$PUSH} {$HINTS OFF} {$ENDIF} +type + PBMP = ^TBMP; + // match DFM binary content + TBMP = packed record + ClassName: string[7]; // "TBitmap" + Size: integer; + FileHeader: TBitmapFileHeader; + InfoHeader: TBitmapInfo; + end; +const + TBMP_HEADERSIZE = 8 + 4; // SizeOf(TBMP.ClassName) + SizeOf(TBMP.Size); + +{$IFDEF LLCL_OPT_PNGSUPPORT} +type + TPNGFileData = packed record + Signature1: Longword; + Signature2: Longword; + Data: array [0..0] of byte; + end; + PPNG = ^TPNG; + TPNG = packed record + ClassName: string[23]; // "TPortableNetworkGraphic" + Size: integer; + FileData: TPNGFileData; + end; +const + TPNG_HEADERSIZE = 24 + 4; // SizeOf(TPNG.ClassName) + SizeOf(TPNG.Size); +{$ENDIF LLCL_OPT_PNGSUPPORT} + +type + TIconHeader = packed record + idReserved: Word; // Reserved (must always be 0) + idType: Word; // Image type (1 for icon) + idCount: Word; // Number of images + end; + TIconDirEntry = packed record + bWidth: Byte; // Image width in pixels + bHeight: Byte; // Image height in pixels + bColorCount: Byte; // Number of colors in color palette (0 if no color palette) + bReserved: Byte; // Reserved (must be 0) + wPlanes: Word; // Color planes (0 or 1) + wBitCount: Word; // Bits per pixel + dwBytesInRes: DWORD; // Size of image data + dwImageOffset: DWORD; // Offset of BMP/PNG data + end; + P1ICO = ^T1ICO; + T1ICO = packed record + FullSize: DWORD; + IconHeader: TIconHeader; + IconDirEntry: TIconDirEntry; + end; + +const + TBITMAPNAME = 'TBitmap'; + TBITMAPIDENT = $4D42; // 'BM' inversed +{$IFDEF LLCL_OPT_PNGSUPPORT} + TPNGGRAPHICNAME = 'TPortableNetworkGraphic'; + TPNGSIGNATURE1 = $474E5089; // #89'PNG' inversed +{$ENDIF LLCL_OPT_PNGSUPPORT} + //------------------------------------------------------------------------------ { TFont } @@ -323,7 +384,7 @@ procedure TFont.ReadProperty(const PropName: string; Reader: TReader); 1 : fHeight := Reader.IntegerProperty; 2 : fName := Reader.StringProperty; 3 : Reader.SetProperty(fStyle, TypeInfo(TFontStyle)); - else inherited; + else inherited; end; end; @@ -437,7 +498,7 @@ procedure TCanvas.SetFont(Value: TFont); procedure TCanvas.FillRect(const R: TRect); begin - LLCL_FillRect(fHandle, R, Brush.GetHandle()); + LLCL_FillRect(fHandle, R, Brush.Handle); end; procedure TCanvas.Rectangle(x1,y1,x2,y2: integer); @@ -509,8 +570,7 @@ function TCanvas.TextHeight(const s: string): integer; destructor TGraphicData.Destroy; begin - if Assigned(fData) then - FreeMem(fData); + ClearData(); inherited; end; @@ -519,25 +579,32 @@ procedure TGraphicData.ReadProperty(const PropName: string; Reader: TReader); begin case StringIndex(PropName, Properties) of 0 : fData := Reader.BinaryProperty(fSize); - else inherited; + else inherited; end; end; +procedure TGraphicData.ClearData(); +begin + LLCLS_FreeMemAndNil(fData); + fSize := 0; + if Assigned(EOnChange) then + EOnChange(self); +end; + { TBitmap } procedure TBitmap.Assign(ABitmap: TBitmap); begin - if Assigned(fData) then - FreeMem(fData); + ClearData(); + {$IFDEF LLCL_OPT_IMGTRANSPARENT} + TranspType := 0; + {$ENDIF LLCL_OPT_IMGTRANSPARENT} if Assigned(ABitmap) then begin fSize := ABitmap.fSize; + GetMem(fData, fSize); Move(ABitmap.fData, fData, fSize); - end - else - begin - fData := nil; - fSize := 0; + // (No ConvertFromPNG call, because it's not supposed to be possible here) end; end; @@ -549,76 +616,234 @@ function TBitmap.GetEmpty(): boolean; procedure TBitmap.DrawRect(const R: TRect; Canvas: TCanvas; Stretch: boolean); var Width, Height, YCoord: integer; begin - if Assigned(fData) and (fSize>=SizeOf(TBitmapFileHeader)) then + if Assigned(fData) and (fSize>=(TBMP_HEADERSIZE + SizeOf(TBitmapFileHeader))) then with PBMP(fData)^ do - if (string(ClassName)='TBitmap') and (FileHeader.bfType=$4D42) then // 'BM' inversed - if Stretch then - begin - LLCL_SetStretchBltMode(Canvas.Handle, HALFTONE); + if (string(ClassName)=TBITMAPNAME) and (FileHeader.bfType=TBITMAPIDENT) then + begin + YCoord := 0; + Width := R.Right - R.Left; + Height := R.Bottom - R.Top; + if Stretch then + LLCL_SetStretchBltMode(Canvas.Handle, HALFTONE) + else + begin + if InfoHeader.bmiHeader.biWidth=2 then + begin + // (Rect used though not really corresponding - Width<>Right and Height<>Bottom); + TranspProcess(Canvas.Handle, Rect(R.Left, R.Top, Width, Height), Stretch); + exit; + end; + end; + {$ENDIF LLCL_OPT_IMGTRANSPARENT} + if Stretch then LLCL_StretchDIBits( - Canvas.Handle, // handle of device context - R.Left, // x-coordinate of upper-left corner of dest. rectangle - R.Top, // y-coordinate of upper-left corner of dest. rectangle - R.Right-R.Left, // dest. rectangle width - R.Bottom-R.Top, // dest. rectangle height - 0, // x-coordinate of lower-left corner of source rect. - 0, // y-coordinate of lower-left corner of source rect. - InfoHeader.bmiHeader.biWidth, // source rectangle width - InfoHeader.bmiHeader.biHeight, // source rectangle height - {$IFDEF FPC} // Avoid compilation warnings - pByte(pByte(@FileHeader)+FileHeader.bfOffBits), // address of array with DIB bits - {$ELSE FPC} - pByte(NativeUInt(@FileHeader)+NativeUInt(FileHeader.bfOffBits)), // address of array with DIB bits - {$ENDIF FPC} - InfoHeader, // address of structure with bitmap info. - DIB_RGB_COLORS, // RGB or palette indices - SRCCOPY); - end - else - begin - Width := InfoHeader.bmiHeader.biWidth; - if Width > (R.Right-R.Left) then Width := (R.Right-R.Left); - YCoord := 0; - Height := InfoHeader.bmiHeader.biHeight; - if Height > (R.Bottom-R.Top) then - begin - YCoord := Height - (R.Bottom-R.Top); - Height := (R.Bottom-R.Top); - end; + Canvas.Handle, // handle of device context + R.Left, // x-coordinate of upper-left corner of dest. rectangle + R.Top, // y-coordinate of upper-left corner of dest. rectangle + Width, // dest. rectangle width + Height, // dest. rectangle height + 0, // x-coordinate of lower-left corner of source rect. + YCoord, // y-coordinate of lower-left corner of source rect. + InfoHeader.bmiHeader.biWidth, // source rectangle width + InfoHeader.bmiHeader.biHeight, // source rectangle height + {$IFDEF FPC} // Avoid compilation warnings + pByte(pByte(@FileHeader) + FileHeader.bfOffBits), // address of array with DIB bits + {$ELSE FPC} + pByte(NativeUInt(@FileHeader) + NativeUInt(FileHeader.bfOffBits)), // address of array with DIB bits + {$ENDIF FPC} + InfoHeader, // address of structure with bitmap info. + DIB_RGB_COLORS, // RGB or palette indices + SRCCOPY) + else LLCL_SetDIBitsToDevice( - Canvas.Handle, // handle of device context - R.Left, // x-coordinate of upper-left corner of dest. rectangle - R.Top, // y-coordinate of upper-left corner of dest. rectangle - Width, // image width - Height, // image height - 0, // x-coordinate of lower-left corner of source rect. - YCoord, // y-coordinate of lower-left corner of source rect. - 0, // first scan line in array - InfoHeader.bmiHeader.biHeight, // number of scan lines - {$IFDEF FPC} // Avoid compilation warnings - pByte(pByte(@FileHeader)+FileHeader.bfOffBits), // address of array with DIB bits - {$ELSE FPC} - pByte(NativeUInt(@FileHeader)+NativeUInt(FileHeader.bfOffBits)), // address of array with DIB bits - {$ENDIF FPC} - InfoHeader, // address of structure with bitmap info. - DIB_RGB_COLORS // RGB or palette indices - ); - end; + Canvas.Handle, // handle of device context + R.Left, // x-coordinate of upper-left corner of dest. rectangle + R.Top, // y-coordinate of upper-left corner of dest. rectangle + Width, // image width + Height, // image height + 0, // x-coordinate of lower-left corner of source rect. + YCoord, // y-coordinate of lower-left corner of source rect. + 0, // first scan line in array + InfoHeader.bmiHeader.biHeight, // number of scan lines + {$IFDEF FPC} // Avoid compilation warnings + pByte(pByte(@FileHeader) + FileHeader.bfOffBits), // address of array with DIB bits + {$ELSE FPC} + pByte(NativeUInt(@FileHeader) + NativeUInt(FileHeader.bfOffBits)), // address of array with DIB bits + {$ENDIF FPC} + InfoHeader, // address of structure with bitmap info. + DIB_RGB_COLORS // RGB or palette indices + ); + end; end; -procedure TBitmap.LoadFromMemory(BufferBitmap: pointer; BufferSize: integer); +procedure TBitmap.MoveToData(BufferBitmap: pointer; BufferSize: integer); begin - if Assigned(fData) then - FreeMem(fData); - fSize := BufferSize+(SizeOf(PBMP(fData)^.ClassName)+SizeOf(PBMP(fData)^.Size)); + ClearData(); + {$IFDEF LLCL_OPT_IMGTRANSPARENT} + TranspType := 0; + {$ENDIF LLCL_OPT_IMGTRANSPARENT} + fSize := TBMP_HEADERSIZE + BufferSize; GetMem(fData, fSize); with PBMP(fData)^ do begin // mimic .dfm binary stream - ClassName := 'TBitmap'; + ClassName := TBITMAPNAME; Size := BufferSize; Move(BufferBitmap^, FileHeader, BufferSize); end; end; +{$IFDEF LLCL_OPT_PNGSUPPORT} +function TBitmap.ConvertFromPNG(): boolean; +var BufferBitmap: PByteArray; +var BufferSize: cardinal; +begin + result := false; + if Assigned(fData) and (fSize>=(TPNG_HEADERSIZE + SizeOf(TPNGFileData))) then + with PPNG(fData)^ do + if (string(ClassName)=TPNGGRAPHICNAME) and (FileData.Signature1=TPNGSIGNATURE1) then + begin + if PNGToBMP(@FileData, Size, BufferBitmap, BufferSize) then + begin + MoveToData(BufferBitmap, BufferSize); + FreeMem(BufferBitmap); + result := true; + end; + end; + if not result then + ClearData(); +end; + +procedure TBitmap.ReadProperty(const PropName: string; Reader: TReader); +const Properties: array[0..0] of PChar = ('Data'); +begin + case StringIndex(PropName, Properties) of + 0 : begin + inherited; + if (fSize>=(TPNG_HEADERSIZE + SizeOf(TPNGFileData))) and (PPNG(fData)^.FileData.Signature1=TPNGSIGNATURE1) then + ConvertFromPNG(); + end; + else inherited; + end; +end; +{$ENDIF LLCL_OPT_PNGSUPPORT} + +{$IFDEF LLCL_OPT_IMGTRANSPARENT} +procedure TBitmap.TranspPreProcess(); +var pData, pDataTmp, pDataLoop: pByteArray; +var NbrPixels: integer; +var bAlpha: byte; +var IsTransp: boolean; +var i1, i2: integer; +begin + IsTransp := false; + TranspType := 1; + if CheckWin32Version(LLCL_WIN2000_MAJ, LLCL_WIN2000_MIN) and LLCLS_CheckAlphaBlend() then + begin + with PBMP(fData)^ do + begin + NbrPixels := InfoHeader.bmiHeader.biHeight * InfoHeader.bmiHeader.biWidth; + GetMem(pDataTmp, NbrPixels * 4); + {$IFDEF FPC} // Avoid compilation warnings + pData := pByteArray(pByte(@FileHeader) + FileHeader.bfOffBits); + {$ELSE FPC} + pData := pByteArray(NativeUInt(@FileHeader) + NativeUInt(FileHeader.bfOffBits)); + {$ENDIF FPC} + end; + Move(pData^, pDataTmp^, NbrPixels * 4); + pDataLoop := pDataTmp; + // Premultiply for AlphaBlend + for i1 := 0 to NbrPixels-1 do + begin + bAlpha := pDataLoop^[3]; + if bAlpha=0 then + PLongword(pDataLoop)^ := 0 + else + begin + IsTransp := true; + if bAlpha<>$FF then + for i2 := 0 to 2 do + pDataLoop^[i2] := (pDataLoop^[i2] * bAlpha) div $FF; + end; + inc(pByte(pDataLoop), 4); + end; + if IsTransp then + begin + TranspType := 2; + Move(pDataTmp^, pData^, NbrPixels * 4); + end; + FreeMem(pDataTmp); + end; +end; + +function TBitmap.TranspProcess(DestHDC: HDC; const R: TRect; Stretch: boolean): boolean; +var BMPHDC: HDC; +var BMPHandle: HBITMAP; +var ftn: BLENDFUNCTION; +var BMPWidth, BMPHeight: integer; +begin + ftn.BlendOp := AC_SRC_OVER; + ftn.BlendFlags := 0; + ftn.SourceConstantAlpha := $FF; + ftn.AlphaFormat := AC_SRC_ALPHA; + with PBMP(fData)^ do + begin + BMPHDC := LLCL_CreateCompatibleDC(DestHDC); + {$IFDEF FPC} // Avoid compilation warnings + BMPHandle := LLCL_CreateDIBitmap(DestHDC, @InfoHeader, CBM_INIT, pByte(pByte(@FileHeader) + FileHeader.bfOffBits), @InfoHeader, DIB_RGB_COLORS); + {$ELSE FPC} + BMPHandle := LLCL_CreateDIBitmap(DestHDC, @InfoHeader, CBM_INIT, pByte(NativeUInt(@FileHeader) + NativeUInt(FileHeader.bfOffBits)), @InfoHeader, DIB_RGB_COLORS); + {$ENDIF FPC} + LLCL_SelectObject(BMPHDC, BMPHandle); + BMPWidth := InfoHeader.bmiHeader.biWidth; + BMPHeight := InfoHeader.bmiHeader.biHeight; + if not Stretch then + begin + if BMPWidth>R.Right then BMPWidth := R.Right; + if BMPHeight>R.Bottom then BMPHeight := R.Bottom; + end; + result := LLCLS_AlphaBlend(DestHDC, R.Left, R.Top, R.Right, R.Bottom, BMPHDC, 0, 0, BMPWidth, BMPHeight, ftn); + LLCL_DeleteObject(BMPHandle); + LLCL_DeleteDC(BMPHDC); + end; +end; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} + +function TBitmap.LoadFromMemory(BufferBitmap: pointer; BufferSize: integer): boolean; +begin + result := true; + ClearData(); + // minimal checks + if (BufferSize>=SizeOf(TBitmapFileHeader)) and (PWord(BufferBitmap)^=TBITMAPIDENT) then + MoveToData(BufferBitmap, BufferSize) + else +{$IFDEF LLCL_OPT_PNGSUPPORT} + if (BufferSize>=SizeOf(TPNGFileData)) and (PLongword(BufferBitmap)^=TPNGSIGNATURE1) then + begin + fSize := TPNG_HEADERSIZE + BufferSize; + GetMem(fData, fSize); + with PPNG(fData)^ do begin + ClassName := TPNGGRAPHICNAME; + Size := BufferSize; + Move(BufferBitmap^, FileData, BufferSize); + result := ConvertFromPNG(); // (fData and fSize cleared inside ConvertFromPNG, if not OK) + end; + end + else +{$ENDIF LLCL_OPT_PNGSUPPORT} + result := false; +end; + procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string); var HResInfo: THandle; var HGlobal: THandle; @@ -631,9 +856,9 @@ procedure TBitmap.LoadFromResourceName(Instance: THandle; const ResName: string) HRes := LLCL_LockResource(HGlobal); if Assigned(HRes) then begin LoadFromMemory(HRes, SizeOfResource(Instance, HResInfo)); - LLCL_UnlockResource(NativeUInt(HRes)); + // LLCL_UnlockResource(NativeUInt(HRes)); obsolete for Windows 32/64 end; - LLCL_FreeResource(HGlobal); + // LLCL_FreeResource(HGlobal); obsolete for Windows 32/64 end; end; end; @@ -652,18 +877,13 @@ procedure TBitmap.LoadFromFile(const FileName: string); if FileHandle<>0 then begin FileSizeLow := LLCL_GetFileSize(FileHandle, FileSizeHigh); - if (FileSizeLow>14) and (FileSizeLow<>INVALID_FILE_SIZE) and (FileSizeHigh=0) then // (bitmap < 4GB) + if (FileSizeLow>8) and (FileSizeLow<>INVALID_FILE_SIZE) and (FileSizeHigh=0) then // (data < 4GB) if integer(LLCL_SetFilePointer(FileHandle, 0, nil, FILE_BEGIN))<>INVALID_SET_FILE_POINTER then begin BufferSize := FileSizeLow; GetMem(Buffer, BufferSize); if LLCL_ReadFile(FileHandle, Buffer^, BufferSize, FileSizeLow, nil) then - // Minimal check - if pWord(Buffer)^=$4D42 then // 'BM' inversed - begin - LoadFromMemory(Buffer, BufferSize); - IsOk := true; - end; + IsOK := LoadFromMemory(Buffer, BufferSize); FreeMem(Buffer); end; LLCL_CloseHandle(FileHandle); @@ -696,11 +916,16 @@ function TPicture.GetBitmap(): TBitmap; result := fBitmap; end; -procedure TPicture.SetBitmap(ABitmap: TBitMap); +procedure TPicture.SetBitmap(ABitmap: TBitmap); begin Bitmap.Assign(ABitmap); // (not fBitmap); end; +procedure TPicture.SetOnChange(Value: TNotifyEvent); +begin + Bitmap.OnChange := Value; // (not fBitmap) +end; + procedure TPicture.DrawRect(const R: TRect; Canvas: TCanvas; Stretch: boolean); begin if Assigned(fBitmap) then @@ -735,12 +960,12 @@ procedure TIcon.ReadProperty(const PropName: string; Reader: TReader); if fSize>SizeOf(T1ICO) then with P1ICO(fData)^ do if (FullSize>SizeOf(T1ICO)) and (IconHeader.idCount>=1) and (IconDirEntry.dwBytesInRes>0) and - (IconDirEntry.dwImageOffset+IconDirEntry.dwBytesInRes<=FullSize) then + (IconDirEntry.dwImageOffset + IconDirEntry.dwBytesInRes<=FullSize) then {$IFDEF FPC} // Avoid compilation warnings - fHandle := LLCL_CreateIconFromResource(pByte(fData+SizeOf(FullSize)+IconDirEntry.dwImageOffset), + fHandle := LLCL_CreateIconFromResource(pByte(fData + SizeOf(FullSize) + IconDirEntry.dwImageOffset), IconDirEntry.dwBytesInRes, true, $00030000); {$ELSE FPC} - fHandle := LLCL_CreateIconFromResource(pByte(NativeUInt(fData)+NativeUInt(SizeOf(FullSize))+NativeUInt(IconDirEntry.dwImageOffset)), + fHandle := LLCL_CreateIconFromResource(pByte(NativeUInt(fData) + NativeUInt(SizeOf(FullSize)) + NativeUInt(IconDirEntry.dwImageOffset)), IconDirEntry.dwBytesInRes, true, $00030000); {$ENDIF FPC} end; diff --git a/sources/Grids.pas b/sources/Grids.pas new file mode 100644 index 0000000..cf105c5 --- /dev/null +++ b/sources/Grids.pas @@ -0,0 +1,1527 @@ +unit Grids; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * TStringGrid implemented +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +// Various conditional options +// Undefining following: better TStringGrid compatibility, bigger executable +{$define DefNo_DefaultRowHeight} // No DefaultRowHeight support (for instance to allow possible use of ImageList in ListView control) +{$define DefNo_ColumnSort} // No column sort +{$define DefNo_StdMouseMessages} // No mouse messages standardization +{$define DefNo_HeaderSupport} // No specific header support +{$define DefNo_Column1Edit} // No edition possible for 1st column +// Undefining following: better ListView compatibility, slightly bigger executable +{$define DefNo_RightClickSelect} // No right-click allowed to select (need to undefine DefNo_StdMouseMessages for full support) +{$define DefNo_CtrlASelectAll} // No Ctrl+A to select all + +// All previous options +{$ifdef LLCL_OPT_GRIDSOPT_ALL} + {$define LLCL_OPT_GRIDSOPT_2} + {$define LLCL_OPT_GRIDSOPT_LV} +{$endif} +// TStringGrid compatibility Level 2 +{$ifdef LLCL_OPT_GRIDSOPT_2} + {$define LLCL_OPT_GRIDSOPT_1} + {$undef DefNo_StdMouseMessages}{$undef DefNo_HeaderSupport}{$undef DefNo_Column1Edit} +{$endif} +// TStringGrid compatibility Level 1 +{$ifdef LLCL_OPT_GRIDSOPT_1} + {$undef DefNo_DefaultRowHeight}{$undef DefNo_ColumnSort} +{$endif} +// ListView compatibility +{$ifdef LLCL_OPT_GRIDSOPT_LV} + {$undef DefNo_RightClickSelect}{$undef DefNo_CtrlASelectAll} +{$endif} + +uses + LLCLOSInt, Windows, {$IFDEF FPC}LCLType, LMessages{$ELSE}Messages{$ENDIF}, + Classes, Controls, Graphics; + +type + TGridOption = (goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, + goRangeSelect, goDrawFocusSelected, goRowSizing, goColSizing, goRowMoving, + goColMoving, goEditing, goTabs, goRowSelect, goAlwaysShowEditor, goThumbTracking); + TGridOptions = set of TGridOption; + TSortOrder = (soAscending, soDescending); + + TGridCoord = record + X: integer; + Y: integer; + end; + TGridRect = record + case Integer of + 0: (Left, Top, Right, Bottom: integer); + 1: (TopLeft, BottomRight: TGridCoord); + end; + + TOnSelectCellEvent = procedure (Sender: TObject; ACol, ARow: integer; var CanSelect: boolean) of object; + TOnCompareCells = procedure (Sender: TObject; ACol, ARow, BCol, BRow: integer; var Result: integer) of object; + THdrEvent = procedure(Sender: TObject; IsColumn: boolean; Index: integer) of object; + TGetEditEvent = procedure (Sender: TObject; ACol, ARow: integer; var Value: string) of object; + TSetEditEvent = procedure (Sender: TObject; ACol, ARow: integer; const Value: string) of object; + + // (No intermediate classes used) + TStringGrid = class(TWinControl) + private + fColCount, + fRowCount: integer; + fDefaultColWidth, + fDefaultRowHeight: integer; + fFixedCols, + fFixedRows: integer; + fRealFixedRows: integer; // (No RealFixedCols property as FixedCols is ignored) + fOptions: TGridOptions; + fColWidths: array of integer; + fRowHeights: array of integer; + fHasInitColWidths, + fHasInitRowHeights: boolean; + fCol, + fRow: integer; + fSelection: TGridRect; + fInitialCells: TStringList; + {$ifndef DefNo_DefaultRowHeight} + fImageListHandle: HIMAGELIST; + {$endif DefNo_DefaultRowHeight} + EOnSelectCell: TOnSelectCellEvent; + fSortOrder: TSortOrder; // Theoretically, only for + fColumnClickSorts: boolean; // FPC/Lazarus (not for Delphi) + fSortColumn: integer; // " " + EOnCompareCells: TOnCompareCells; // " " + EOnHeaderClick: THdrEvent; // " " + EOnGetEditText: TGetEditEvent; + EOnSetEditText: TSetEditEvent; + // (internals) + fRowSelect: boolean; + fCurCtrlState: integer; // 0=None, 1=Ctrl+A, 2=Ctrl+Other (Click, Space, ...) + fLastItemFocused: integer; + {$ifndef DefNo_HeaderSupport} + fhWndHeader: THandle; + fHeaderWndProc: TFNWndProc; + {$else DefNo_HeaderSupport} + hWndHeader: THandle; + {$endif DefNo_HeaderSupport} + // + procedure AddCols(Value: integer; Base: integer; UseDefColWidth: boolean); + procedure DelCols(Value: integer; Base: integer); + procedure AddRows(Value: integer; Base: integer; UseDefRowHeight: boolean); + procedure DelRows(Value: integer; Base: integer); + procedure SetColCount(AValue: integer); + procedure SetRowCount(AValue: integer); + procedure SetDefaultColWidth(AValue: integer); + procedure SetDefaultRowHeight(AValue: integer); + function GetColWidths(Index: integer): integer; + procedure SetColWidths(Index: integer; Value: integer); + function GetRowHeights(Index: integer): integer; + procedure SetRowHeights(Index: integer; Value: integer); + function GetCells(ACol, ARow: integer): string; + procedure SetCells(ACol, ARow: integer; const Value: string); + function GetInitialCellsIndex(ACol, ARow: integer): integer; + function GetInitialCells(ACol, ARow: integer): string; + procedure SetInitialCells(ACol, ARow: integer; const Value: string); + function GetCols(Index: integer): TStringList; + procedure SetCols(Index: integer; Value: TStringList); + function GetRows(Index: integer): TStringList; + procedure SetRows(Index: integer; Value: TStringList); + procedure SetCol(AValue: integer); + function GetRow(): integer; + procedure SetRow(AValue: integer); + function GetSelection(): TGridRect; + function NewRealFixedRows(NewValue: integer): integer; + procedure UpdRealFixedRows(NewValue: integer); + function CheckColRow(ACol, ARow: integer; Mode: integer): boolean; + function IsColumnOK(ACol: integer): boolean; + procedure UpdateHeaderStyle(); + procedure ModifyHeaderStyle(AValue: cardinal; AMask: cardinal); + procedure SetColumnClickSorts(AValue: boolean); + {$ifndef DefNo_ColumnSort} + procedure ModifyHeaderColFmt(ACol: integer; AMode: integer); + procedure CallSort(FormerSortColumn: integer); + {$endif DefNo_ColumnSort} + procedure RestoreLastFocusedItem(); + function ProcessNotification(var Msg: TMessage; IsForHeader: boolean): boolean; + {$ifndef DefNo_Column1Edit} + procedure CallEditCurRow(); + {$endif DefNo_Column1Edit} + {$ifndef DefNo_HeaderSupport} + procedure ForMouseButton(MouseButton: TMouseButton; ShiftState: TShiftState; alParam: NativeUInt; EOnMouse: TMouseEvent); + function GethWndHeader(): THandle; + procedure SethWndHeader(Value: THandle); + property hWndHeader: THandle read GethWndHeader write SethWndHeader; + {$endif DefNo_HeaderSupport} + protected + procedure CreateHandle; override; + procedure CreateParams(var Params: TCreateParams); override; + procedure ReadProperty(const PropName: string; Reader: TReader); override; + {$if (not Defined(DefNo_CtrlASelectAll)) or (not Defined(DefNo_Column1Edit))} + function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; + {$ifend} + procedure SetColor(AValue: integer); override; + {$if (not Defined(DefNo_HeaderSupport)) or (not Defined(DefNo_Column1Edit))} + function ForwardChildMsg(var Msg: TMessage; WndChild: THandle): boolean; override; + {$ifend} + function ComponentNotif(var Msg: TMessage): boolean; override; + {$ifndef DefNo_StdMouseMessages} + procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP; // (received only with DblClick) + procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN; + procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP; + procedure WMLDblClick(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure WMRDblClick(var Msg: TWMRButtonDblClk); message WM_RBUTTONDBLCLK; + {$endif DefNo_StdMouseMessages} + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SortColRow(IsColumn: boolean; Index: integer); // Only for columns (i.e. IsColumn=true) + property Options: TGridOptions read fOptions write fOptions; // Run-time modification ignored; write present only for dynamical control creation purpose + property ColCount: integer read fColCount write SetColCount; + property RowCount: integer read fRowCount write SetRowCount; + property DefaultColWidth: integer read fDefaultColWidth write SetDefaultColWidth; + property DefaultRowHeight: integer read fDefaultRowHeight write SetDefaultRowHeight; // LLCL: Fixed row (i.e. title) not concerned + property ColWidths[Index: integer]: integer read GetColWidths write SetColWidths; + property RowHeights[Index: integer]: integer read GetRowHeights write SetRowHeights; // LLCL: Ignored + property FixedRows: integer read fFixedRows write fFixedRows; // LLCL: Just 0 or (<>0=)1 - Run-time modification ignored; write present only for dynamical control creation purpose + property FixedCols: integer read fFixedCols write fFixedCols; // LLCL: Ignored + property Cells[ACol, ARow: integer]: string read GetCells write SetCells; + property Cols[Index: integer]: TStringList read GetCols write SetCols; + property Rows[Index: integer]: TStringList read GetRows write SetRows; + property Col: integer read fCol write SetCol; // LLCL: (mainly) Ignored + property Row: integer read GetRow write SetRow; + property Selection: TGridRect read GetSelection; + property OnSelectCell: TOnSelectCellEvent read EOnSelectCell write EOnSelectCell; + property SortOrder: TSortOrder read fSortOrder write fSortOrder; + property SortColumn: integer read fSortColumn; + property ColumnClickSorts: boolean read fColumnClickSorts write SetColumnClickSorts; + property OnCompareCells: TOnCompareCells read EOnCompareCells write EOnCompareCells; + property OnHeaderClick: THdrEvent read EOnHeaderClick write EOnHeaderClick; + property OnGetEditText: TGetEditEvent read EOnGetEditText write EOnGetEditText; + property OnSetEditText: TSetEditEvent read EOnSetEditText write EOnSetEditText; + end; + +//------------------------------------------------------------------------------ + +implementation + +uses +{$IFNDEF FPC} + CommCtrl, +{$ENDIF} + SysUtils; + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +{$IFDEF FPC} +// Some ListView constants +// - to avoid CommCtrl: conflict with Variants unit +// - and to avoid warnings (range check error) +const + LVS_EX_GRIDLINES = $00000001; + LVS_EX_HEADERDRAGDROP = $00000010; + LVS_EX_FULLROWSELECT = $00000020; + LVM_FIRST = $1000; + LVM_GETHEADER = (LVM_FIRST + 31); + LVM_SETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 54); + LVN_FIRST = UINT(- 100); + LVN_ITEMCHANGING = UINT(LVN_FIRST - 0); + LVN_ITEMCHANGED = UINT(LVN_FIRST - 1); +{$ifndef DefNo_ColumnSort} + LVN_COLUMNCLICK = UINT(LVN_FIRST - 8); +{$endif DefNo_ColumnSort} +{$ifndef DefNo_Column1Edit} + LVN_KEYDOWN = UINT(LVN_FIRST - 55); + LVN_BEGINLABELEDITA = UINT(LVN_FIRST - 5); + LVN_BEGINLABELEDITW = UINT(LVN_FIRST - 75); + LVN_ENDLABELEDITA = UINT(LVN_FIRST - 6); + LVN_ENDLABELEDITW = UINT(LVN_FIRST - 76); +{$endif DefNo_Column1Edit} + NM_FIRST = 0; + NM_CLICK = UINT(NM_FIRST - 2); +{$ifndef DefNo_StdMouseMessages} + NM_DBLCLK = UINT(NM_FIRST - 3); + NM_RCLICK = UINT(NM_FIRST - 5); + NM_RDBLCLK = UINT(NM_FIRST - 6); +{$else DefNo_StdMouseMessages} +{$ifndef DefNo_Column1Edit} + NM_DBLCLK = UINT(NM_FIRST - 3); +{$endif DefNo_Column1Edit} +{$endif DefNo_StdMouseMessages} +{$ENDIF FPC} +// Missing ListView constants +const +{$ifndef DefNo_ColumnSort} + LVM_SORTITEMSEX = (LVM_FIRST + 81); + HDF_SORTUP = $0400; + HDF_SORTDOWN = $0200; +{$endif DefNo_ColumnSort} + HDS_NOSIZING = $0800; + LVKF_ALT = $0001; + LVKF_CONTROL = $0002; + LVKF_SHIFT = $0004; + +{$ifndef DefNo_StdMouseMessages} +type + TNMItemActivate = record + hdr: NMHDR; + iItem: integer; + iSubItem: integer; + uNewState: cardinal; + uOldState: cardinal; + uChanged: cardinal; + ptAction: TPOINT; + lParam: LPARAM; + uKeyFlags: cardinal + end; + PNMItemActivate = ^TNMItemActivate; +{$endif DefNo_StdMouseMessages} + +{$ifndef DefNo_Column1Edit} + TNMLVKeyDown = record + hdr: NMHDR; + wVKey: Word; + flags: cardinal; + end; + PNMLVKeyDown = ^TNMLVKeydown; + + TNMLVDispInfo = record + hdr: NMHDR; + item: LV_ITEM; + end; + PNMLVDispInfo = ^TNMLVDispInfo; +{$endif DefNo_Column1Edit} + +procedure LV_SetColumnTitleText(hwndLV: HWND; iCol: integer; sText: string); forward; +procedure LV_SetItemText(hwndLV: HWND; iItem, iSubItem: integer; sText: string); forward; +procedure LV_SetItemState(hwndLV: HWND; iItem: integer; state, stateMask: cardinal); forward; +{$ifndef DefNo_ColumnSort} +function LV_CompareFunc(iItem1: LPARAM; iItem2: LPARAM; Handle: LPARAM): integer; stdcall; forward; +{$endif DefNo_ColumnSort} +function LV_KeysToShiftState(Keys: cardinal): TShiftState; forward; + +{$ifndef DefNo_HeaderSupport} +function ELVWndProc(hWnd: THandle; Msg: cardinal; awParam, alParam: NativeUInt): NativeUInt; stdcall; forward; +{$endif DefNo_HeaderSupport} + +// Workaround for Unicode FPC when using the standard SysUtils unit +{$if Defined(FPC) and Defined(UNICODE) and Declared(MaxEraCount)} + {$define Def_FPC_StdSys} +{$ifend} +{$ifdef Def_FPC_StdSys} +function Grids_IntToStr(Value: integer): string; forward; +function Grids_StrToInt(const S: string): integer; forward; +{$endif} + +//------------------------------------------------------------------------------ + +{$IFDEF FPC} +// Dummy function to avoid compilation hint (LMessages not used) +function LMessages_Dummy(const Msg: TLMCommand): boolean; +begin + result := false; +end; +{$ENDIF FPC} + +procedure LV_SetColumnTitleText(hwndLV: HWND; iCol: integer; sText: string); +var lvc: LV_COLUMN; +begin + FillChar(lvc, SizeOf(lvc), 0); + lvc.mask := LVCF_TEXT; + // lvc.pszText set in function call + LLCLS_LV_SetColumnWithTitleText(2, hwndLV, iCol, lvc, sText); // 2=SETCOLUMN +end; + +procedure LV_SetItemText(hwndLV: HWND; iItem, iSubItem: integer; sText: string); +var lvi: LV_ITEM; +begin + FillChar(lvi, SizeOf(lvi), 0); + lvi.mask := LVIF_TEXT; + lvi.iItem := iItem; + lvi.iSubItem := iSubItem; + // lvi.pszText set in function call + LLCLS_LV_SetItemWithText(2, hwndLV, lvi, sText); // 2=SETTITEM +end; + +procedure LV_SetItemState(hwndLV: HWND; iItem: integer; state, stateMask: cardinal); +var lvi: LV_ITEM; +begin + // ListView_SetItemState(hwndLV, iItem, state, stateMask); + FillChar(lvi, SizeOf(lvi), 0); + lvi.state := state; + lvi.stateMask := stateMask; + LLCL_SendMessage(hwndLV, LVM_SETITEMSTATE, iItem, LPARAM(@lvi)); +end; + +{$ifndef DefNo_ColumnSort} +// Callback function for Listview sorting +function LV_CompareFunc(iItem1: LPARAM; iItem2: LPARAM; Handle: LPARAM): integer; stdcall; +var obj: TObject; +var i1, i2: integer; +var s1, s2: string; +begin + result := 0; + obj := TObject(LLCL_GetWindowLongPtr(THandle(Handle), GWL_USERDATA)); + if Assigned(obj) then + with TStringGrid(obj) do + begin + i1 := iItem1 + fRealFixedRows; + i2 := iItem2 + fRealFixedRows; + if (i10 then Include(result, ssShift); + if Keys and LVKF_CONTROL<>0 then Include(result, ssCtrl); + if Keys and LVKF_ALT<>0 then Include(result, ssAlt); +end; + +{$ifndef DefNo_HeaderSupport} +// Callback function for Listview Header Control (StringGrid) +function ELVWndProc(hWnd: THandle; Msg: cardinal; awParam, alParam: NativeUInt): NativeUInt; stdcall; +var obj: TObject; +var LVWndProc: TFNWndProc; +var MouseButton: TMouseButton; +begin + LVWndProc := nil; + obj := TObject(LLCL_GetWindowLongPtr(hWnd, GWL_USERDATA)); + if Assigned(obj) then + with TStringGrid(obj) do + begin + LVWndProc := fHeaderWndProc; + case Msg of + WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK, + WM_RBUTTONDOWN, WM_RBUTTONUP, WM_RBUTTONDBLCLK: + begin + case Msg of + WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK: + begin + MouseButton := mbLeft; + SetFocus; + end + else + MouseButton := mbRight; + end; + case Msg of + WM_LBUTTONDOWN, WM_RBUTTONDOWN: + ForMouseButton(MouseButton, TShiftState(LLCLS_KeysToShiftState(awParam)), alParam, OnMouseDown); + WM_LBUTTONUP, WM_RBUTTONUP: + ForMouseButton(MouseButton, TShiftState(LLCLS_KeysToShiftState(awParam)), alParam, OnMouseUp); + WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK: + begin +{$IFDEF FPC} + ForMouseButton(MouseButton, TShiftState(LLCLS_KeysToShiftState(awParam)) + [ssDouble], alParam, OnMouseDown); + if (Msg=WM_LBUTTONDBLCLK) and Assigned(OnDblClick) then + OnDblClick(TStringGrid(obj)); +{$ELSE FPC} + if (Msg=WM_LBUTTONDBLCLK) and Assigned(OnDblClick) then + OnDblClick(TStringGrid(obj)); + ForMouseButton(MouseButton, TShiftState(LLCLS_KeysToShiftState(awParam)) + [ssDouble], alParam, OnMouseDown); +{$ENDIF} + end; + end; + end; + end; + end; + if not Assigned(LVWndProc) then + result := LLCL_DefWindowProc(hWnd, Msg, awParam, alParam) + else + result := LLCL_CallWindowProc({$IFDEF FPC}TFNWndProc(LVWndProc){$ELSE}LVWndProc{$ENDIF}, hWnd, Msg, awParam, alParam); +end; +{$endif DefNo_HeaderSupport} + +{$ifdef Def_FPC_StdSys} +function Grids_IntToStr(Value: integer): string; +begin + Str(Value, result); +end; + +function Grids_StrToInt(const S: string): integer; +var E: integer; +begin + Val(S, result, E); + if E<>0 then + result := 0; +end; +{$endif Def_FPC_StdSys} + +{ TStringGrid } + +constructor TStringGrid.Create(AOwner: TComponent); +begin + inherited; + ATType := ATTStringGrid; + fColCount := 5; + fRowCount := 5; + fFixedCols := 1; + fFixedRows := 1; + {$ifndef DefNo_ColumnSort} + fSortColumn := -1; + {$endif DefNo_ColumnSort} + fDefaultColWidth := 64; + fDefaultRowHeight := {$IFDEF FPC}20{$ELSE}24{$ENDIF}; + fOptions := [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect]; + SetLength(fColWidths, 0); + SetLength(fRowHeights, 0); + ArrowKeysInternal := true; + Color := LLCL_GetSysColor(integer(clWindow) and $FF); + fInitialCells := TStringList.Create; +end; + +procedure TStringGrid.CreateHandle; +const + ICC_LISTVIEW_CLASSES = $0001; // (See remark for InitCommonControl) +var PostExStyle: cardinal; +var i: integer; +begin + LLCLS_InitCommonControl(ICC_LISTVIEW_CLASSES); // Avoid to include ComCtrls just for InitCommonControl + inherited; + PostExStyle := 0; + if (goVertLine in fOptions) or (goHorzLine in fOptions) then + PostExStyle := PostExStyle or LVS_EX_GRIDLINES; + if goRowSelect in fOptions then + begin + PostExStyle := PostExStyle or LVS_EX_FULLROWSELECT; + fRowSelect := true; + end; + if goColMoving in fOptions then + PostExStyle := PostExStyle or LVS_EX_HEADERDRAGDROP; + if PostExStyle<>0 then + // ListView_SetExtendedListViewStyle(Handle, PostExStyle); + LLCL_SendMessage(Handle, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, PostExStyle); + // Default + SetLength(fColWidths, fColCount); + SetLength(fRowHeights, fRowCount); + SetDefaultRowHeight(fDefaultRowHeight); + // Colors + if HasDesignColor or (not ParentFont) then + SetColor(Color); + // Columns and Rows + if (fColCount>0) then + AddCols(fColCount, 0, (not fHasInitColWidths)); + if (fRowCount - fRealFixedRows)>0 then // fRealFixedRows has been set in CreateParams + AddRows(fRowCount - fRealFixedRows, 0, (not fHasInitRowHeights)); + // Header + UpdateHeaderStyle(); + // Initial Selection + if fRowCount>fRealFixedRows then Row := fRealFixedRows; + if fColCount>0 then Col := 0; + // Initial Cell values + if fInitialCells.Count>0 then + begin + for i := 0 to pred({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[0])) do + SetCells({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[1 + (i*3) + 0]), {$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[1 + (i*3) + 1]), fInitialCells[1 + (i*3) + 2]); + fInitialCells.Clear; + end; +{$ifndef DefNo_ColumnSort} + // Sort + if IsColumnOK(fSortColumn) then + CallSort(-1); +{$endif DefNo_ColumnSort} +end; + +procedure TStringGrid.CreateParams(var Params: TCreateParams); +begin + inherited; + with Params do + begin + WinClassName := WC_LISTVIEW; + Style := Style or LVS_REPORT; + fRealFixedRows := NewRealFixedRows(fFixedRows); + if fRealFixedRows=0 then + Style := Style or LVS_NOCOLUMNHEADER; + if not (goRangeSelect in fOptions) then + Style := Style or LVS_SINGLESEL; + if goRowSelect in fOptions then + Style := Style or LVS_SHOWSELALWAYS; + {$ifndef DefNo_Column1Edit} + if goEditing in fOptions then + Style := Style or LVS_EDITLABELS; + {$endif DefNo_Column1Edit} + ExStyle := ExStyle or WS_EX_STATICEDGE; + end; +end; + +procedure TStringGrid.ReadProperty(const PropName: string; Reader: TReader); +const Properties: array[0..15] of PChar = ( + 'ColCount', 'RowCount', 'FixedCols', 'FixedRows', 'DefaultColWidth', 'DefaultRowHeight','Options', + 'ColWidths', 'RowHeights', 'Cells', 'OnSelectCell', 'OnGetEditText', 'OnSetEditText', 'OnCompareCells', 'OnHeaderClick', 'ColumnClickSorts'); +begin + case StringIndex(PropName, Properties) of + 0 : fColCount := Reader.IntegerProperty; + 1 : fRowCount := Reader.IntegerProperty; + 2 : fFixedCols := Reader.IntegerProperty; + 3 : fFixedRows := Reader.IntegerProperty; + 4 : fDefaultColWidth := Reader.IntegerProperty; + 5 : fDefaultRowHeight := Reader.IntegerProperty; + 6 : Reader.SetProperty(fOptions, TypeInfo(TGridOption)); + 7 : if fColCount>0 then + begin + SetLength(fColWidths, fColCount); + Reader.ReadIntArray(fColWidths); + fHasInitColWidths := true; + end; + 8 : if fRowCount>0 then + begin + SetLength(fRowHeights, fRowCount); + Reader.ReadIntArray(fRowHeights); + fHasInitRowHeights := true; + end; + 9 : Reader.ReadStringInts(fInitialCells); + 10: TMethod(EOnSelectCell) := FindMethod(Reader); + 11: TMethod(EOnGetEditText) := FindMethod(Reader); + 12: TMethod(EOnSetEditText) := FindMethod(Reader); + 13: TMethod(EOnCompareCells) := FindMethod(Reader); + 14: TMethod(EOnHeaderClick) := FindMethod(Reader); + 15: fColumnClickSorts := Reader.BooleanProperty; + else inherited; + end; +end; + +destructor TStringGrid.Destroy; +begin + hWndHeader := 0; + fInitialCells.Free; + // fImageListHandle is supposed to be destroyed by Windows when the ListView control is destroyed + inherited; +end; + +{$if (not Defined(DefNo_CtrlASelectAll)) or (not Defined(DefNo_Column1Edit))} +function TStringGrid.SpecialKeyProcess(var CharCode: Word): TKeyProcess; +begin + result := inherited SpecialKeyProcess(CharCode); // tkStandard by default + {$ifndef DefNo_CtrlASelectAll} + // Ctrl+A = Select All + if CharCode=cardinal(^A) then + begin + // Select all (don't change focus) + fCurCtrlState := 1; + LV_SetItemState(Handle, -1, LVIS_SELECTED , LVIS_SELECTED); + fCurCtrlState := 0; + result := tkSkip; + end; + {$endif DefNo_CtrlASelectAll} + {$ifndef DefNo_Column1Edit} + // Enter (processed in ProcessNotification); + if CharCode=VK_RETURN then + if goEditing in fOptions then + result := tkForceStandard ; + {$endif DefNo_Column1Edit} +end; +{$ifend} + +procedure TStringGrid.SetColor(AValue: integer); +var AColor: integer; +begin + inherited; + if Handle=0 then exit; // Because may be called before created + // ListView_SetBkColor(Handle, Color); + LLCL_SendMessage(Handle, LVM_SETBKCOLOR, 0, Color); + // ListView_SetTextBkColor(Handle, Color); + LLCL_SendMessage(Handle, LVM_SETTEXTBKCOLOR, 0, Color); + AColor := Font.Color; + if ParentFont and (Parent<>nil) then + AColor := Parent.Font.Color; + // ListView_SetTextColor(Handle, AColor); + LLCL_SendMessage(Handle, LVM_SETTEXTCOLOR, 0, AColor); + // Forces full paint + LLCL_InvalidateRect(Handle, nil, true); +end; + +{$if (not Defined(DefNo_HeaderSupport)) or (not Defined(DefNo_Column1Edit))} +function TStringGrid.ForwardChildMsg(var Msg: TMessage; WndChild: THandle): boolean; +begin + // (No inherited - TStringGrid has not child controls) + result := (hWndHeader<>0) and (WndChild=hWndHeader); + if result then + result := ProcessNotification(Msg, true); +end; +{$ifend} + +function TStringGrid.ComponentNotif(var Msg: TMessage): boolean; +begin + result := inherited ComponentNotif(Msg); + if result then + result := ProcessNotification(Msg, false); +end; + +{$ifndef DefNo_StdMouseMessages} +// All mouse messages for Listview are processed only in ComponentNotif +// because ListView eats/interprets them +// For instance, for a left button click the received messages are: +// WM_NOTIFY(NM_CLICK), then WM_LBUTTONDOWN (WM_LBUTTONUP absent and WM_LBUTTONDOWN after click) +// +// On the contrary, all all mouse messages for Listview Control Header +// are processed through the specific callback function (see ELVWndProc) +procedure TStringGrid.WMLButtonDown(var Msg: TWMLButtonDown); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; + +procedure TStringGrid.WMLButtonUp(var Msg: TWMLButtonUp); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; + +procedure TStringGrid.WMRButtonDown(var Msg: TWMRButtonDown); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; + +procedure TStringGrid.WMRButtonUp(var Msg: TWMRButtonUp); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; + +procedure TStringGrid.WMLDblClick(var Msg: TWMLButtonDblClk); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; + +procedure TStringGrid.WMRDblClick(var Msg: TWMRButtonDblClk); +begin + DefaultHandler(Msg); // (Processed in ComponentNotif) +end; +{$endif DefNo_StdMouseMessages} + +procedure TStringGrid.AddCols(Value: integer; Base: integer; UseDefColWidth: boolean); +var lvc: LV_COLUMN; +var i: integer; +begin + if Handle=0 then exit; // Because may be called before created + FillChar(lvc, SizeOf(lvc), 0); + for i:=0 to pred(Value) do + begin + lvc.mask := LVCF_FMT or LVCF_WIDTH or LVCF_TEXT or LVCF_SUBITEM; + lvc.fmt := LVCFMT_LEFT; // (could be changed) + // lvc.pszText set in function call + lvc.cchTextMax := LLCLC_LISTVIEW_MAXCHAR; + lvc.iSubItem := Base + i; + if UseDefColWidth then + fColWidths[lvc.iSubItem] := fDefaultColWidth; + lvc.cx := fColWidths[lvc.iSubItem]; + // ListView_InsertColumn(Handle, lvc.iSubItem, lvc); + LLCLS_LV_SetColumnWithTitleText(1, Handle, lvc.iSubItem, lvc, ''); // 1=INSERTCOLUMN + end; +end; + +procedure TStringGrid.DelCols(Value: integer; Base: integer); +var i, TmpValue: integer; +begin + if Handle=0 then exit; // Because may be called before created + TmpValue := Value; + if (Base-Value)<0 then TmpValue := Base; // Sanity + for i:=0 to pred(TmpValue) do + // ListView_DeleteColumn(Handle, Base-i); + LLCL_SendMessage(Handle, LVM_DELETECOLUMN, Base-i, 0); +end; + +procedure TStringGrid.AddRows(Value: integer; Base: integer; UseDefRowHeight: boolean); +var lvi: LV_ITEM; +var i: integer; +begin + if Handle=0 then exit; // Because may be called before created + FillChar(lvi, SizeOf(lvi), 0); + for i:=0 to pred(Value) do + begin + lvi.mask := LVIF_TEXT or LVIF_DI_SETITEM; + // lvi.pszText set in function call + lvi.cchTextMax := LLCLC_LISTVIEW_MAXCHAR; + lvi.iItem := Base + i; + if UseDefRowHeight then + fRowHeights[lvi.iItem] := fDefaultRowHeight; + // ListView_InsertItem(Handle, lvi); + LLCLS_LV_SetItemWithText(1, Handle, lvi, ''); // 1=INSERTITEM + end; +end; + +procedure TStringGrid.DelRows(Value: integer; Base: integer); +var i, TmpValue: integer; +begin + if Handle=0 then exit; // Because may be called before created + TmpValue := Value; + if (Base-Value)<0 then TmpValue := Base; // Sanity + if TmpValue=Base then + // ListView_DeleteAllItems(Handle) + LLCL_SendMessage(Handle, LVM_DELETEALLITEMS, 0, 0) + else + for i:=0 to pred(TmpValue) do + // ListView_DeleteItem(Handle, Base-i); + LLCL_SendMessage(Handle, LVM_DELETEITEM, Base-i, 0); +end; + +procedure TStringGrid.SetColCount(AValue: integer); +var TmpValue, SavColCount: integer; +begin + SavColCount := fColCount; + if AValue<0 then TmpValue := 0 else TmpValue := AValue; + SetLength(fColWidths, TmpValue); + fColCount := TmpValue; + if TmpValue>SavColCount then + AddCols(TmpValue - SavColCount, SavColCount, true) + else + if TmpValueSavRowCount then + begin + AddRows(TmpValue - SavRowCount, SavRowCount, true); + // Update selection if necessary + if fRow=fRowCount then + Row := fRowCount - 1; + end; +end; + +procedure TStringGrid.SetDefaultColWidth(AValue: integer); +var i: integer; +begin + for i:=0 to pred(fColCount) do + SetColWidths(i, AValue); +end; + +procedure TStringGrid.SetDefaultRowHeight(AValue: integer); +var i: integer; +begin + for i:=0 to pred(fRowCount) do + SetRowHeights(i, AValue); +{$ifndef DefNo_DefaultRowHeight} + if Handle=0 then exit; // Because may be called before created + if fImageListHandle<>0 then + LLCLS_LV_ImageList_Destroy(fImageListHandle); + i := AValue; + if i>=1 then i := i - 1; + fImageListHandle := LLCLS_LV_ImageList_Create(1 , i, ILC_COLOR4, 10, 10); + // ListView_SetImageList(Handle, fImageListHandle, LVSIL_SMALL); + LLCL_SendMessage(Handle, LVM_SETIMAGELIST, LVSIL_SMALL, LPARAM(fImageListHandle)); +{$endif DefNo_DefaultRowHeight} +end; + +function TStringGrid.GetColWidths(Index: integer): integer; +var lvc: LV_COLUMN; +begin + result := fColWidths[Index]; + if Handle=0 then exit; // Because may be called before created + FillChar(lvc, SizeOf(lvc), 0); + lvc.mask := LVCF_WIDTH; + // ListView_GetColumn(Handle, Index, lvc); + LLCL_SendMessage(Handle, LVM_GETCOLUMN, Index, LPARAM(@lvc)); + result := lvc.cx; + fColWidths[Index] := result; +end; + +procedure TStringGrid.SetColWidths(Index: integer; Value: integer); +var lvc: LV_COLUMN; +begin + fColWidths[Index] := Value; + if Handle=0 then exit; // Because may be called before created + FillChar(lvc, SizeOf(lvc), 0); + lvc.mask := LVCF_WIDTH; + lvc.cx := Value; + // ListView_SetColumn(Handle, Index, lvc); + LLCL_SendMessage(Handle, LVM_SETCOLUMN, Index, LPARAM(@lvc)); +end; + +function TStringGrid.GetRowHeights(Index: integer): integer; +begin + result := fRowHeights[Index]; +end; + +procedure TStringGrid.SetRowHeights(Index: integer; Value: integer); +begin + fRowHeights[Index] := Value; +end; + +function TStringGrid.GetCells(ACol, ARow: integer): string; +begin + CheckColRow(ACol, ARow, 1+2); // 1+2: Check Column and Row + if Handle=0 then // Because may be called before created + begin + result := GetInitialCells(ACol, ARow); + exit; + end; + if (fRealFixedRows>0) and (ARow=0) then + result := LLCLS_LV_GetColumnTitleText(Handle, ACol) + else + result := LLCLS_LV_GetItemText(Handle, ARow - fRealFixedRows, ACol); +end; + +procedure TStringGrid.SetCells(ACol, ARow: integer; const Value: string); +begin + CheckColRow(ACol, ARow, 1+2); // 1+2: Check Column and Row + if Handle=0 then // Because may be called before created + begin + SetInitialCells(ACol, ARow, Value); + exit; + end; + if (fRealFixedRows>0) and (ARow=0) then + LV_SetColumnTitleText(Handle, ACol, Value) + else + // ListView_SetItemText(Handle, ARow - fRealFixedRows, ACol, @Value[1]); + LV_SetItemText(Handle, ARow - fRealFixedRows, ACol, Value); +end; + +function TStringGrid.GetInitialCellsIndex(ACol, ARow: integer): integer; +var i: integer; +begin + result := -1; + if fInitialCells.Count>0 then + for i := 0 to pred({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[0])) do + if ({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[1 + (i*3) + 0])=ACol) and ({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[1 + (i*3) + 1])=ARow) then + begin + result := i; + break; + end; +end; + +// Gets initial cells value (instead of cells value) +function TStringGrid.GetInitialCells(ACol, ARow: integer): string; +var i: integer; +begin + result := ''; + i := GetInitialCellsIndex(ACol, ARow); + if i>=0 then + result := fInitialCells[1 + (i*3) + 2]; +end; + +// Sets initial cells value (instead of cells value) +procedure TStringGrid.SetInitialCells(ACol, ARow: integer; const Value: string); +var i: integer; +begin + i := GetInitialCellsIndex(ACol, ARow); + if i>=0 then + fInitialCells[1 + (i*3) + 2] := Value + else + begin + if fInitialCells.Count=0 then + fInitialCells.Add('1') + else + fInitialCells[0] := {$ifdef Def_FPC_StdSys}Grids_IntToStr{$else}IntToStr{$endif}({$ifdef Def_FPC_StdSys}Grids_StrToInt{$else}StrToInt{$endif}(fInitialCells[0]) + 1); + fInitialCells.Add({$ifdef Def_FPC_StdSys}Grids_IntToStr{$else}IntToStr{$endif}(ACol)); + fInitialCells.Add({$ifdef Def_FPC_StdSys}Grids_IntToStr{$else}IntToStr{$endif}(ARow)); + fInitialCells.Add(Value); + end; +end; + +function TStringGrid.GetCols(Index: integer): TStringList; +var i: integer; +begin + result := TStringList.Create; + for i:=0 to pred(fColCount) do + result.Add(GetCells(Index, i)); +end; + +procedure TStringGrid.SetCols(Index: integer; Value: TStringList); +var i: integer; +begin + for i:=0 to pred(fColCount) do + SetCells(Index, i, Value[i]); +end; + +function TStringGrid.GetRows(Index: integer): TStringList; +var i: integer; +begin + result := TStringList.Create; + for i:=0 to pred(fRowCount) do + result.Add(GetCells(i, Index)); +end; + +procedure TStringGrid.SetRows(Index: integer; Value: TStringList); +var i: integer; +begin + for i:=0 to pred(fColCount) do + SetCells(i, Index, Value[i]); +end; + +procedure TStringGrid.SetCol(AValue: integer); +var TmpValue: integer; +begin + TmpValue := AValue; +{$IFDEF FPC} + if TmpValue>=fColCount then TmpValue := fColCount - 1; // Order + if TmpValue<0 then TmpValue := 0; // matters +{$ELSE} + CheckColRow(0, TmpValue, 1); // 1: Check Column only +{$ENDIF} + fCol := TmpValue; +end; + +function TStringGrid.GetRow(): integer; +var i: integer; +begin + result := fRow; + if Handle=0 then exit; // Because may be called before created + // ListView_GetNextItem(Handle, -1, LVNI_SELECTED or LVNI_FOCUSED); + i := LLCL_SendMessage(Handle, LVM_GETNEXTITEM, -1, LVNI_SELECTED or LVNI_FOCUSED); + if i<0 then + // ListView_GetNextItem(Handle, -1, LVNI_FOCUSED); + i := LLCL_SendMessage(Handle, LVM_GETNEXTITEM, -1, LVNI_FOCUSED); + if i<0 then i:=0; + fRow := i + fRealFixedRows; + result := fRow; +end; + +procedure TStringGrid.SetRow(AValue: integer); +var TmpValue: integer; +begin + TmpValue := AValue; +{$IFDEF FPC} + if TmpValue>=fRowCount then TmpValue := fRowCount - 1; // Order + if TmpValue<0 then TmpValue := 0; // matters +{$ELSE} + CheckColRow(0, TmpValue, 2); // 2: Check Row only +{$ENDIF} + if (fRealFixedRows>0) and (TmpValuefRealFixedRows then + TmpValue := fRealFixedRows + else + TmpValue := 0; + fRow := TmpValue; + if Handle=0 then exit; // Because may be called before created + // Unselect all + LV_SetItemState(Handle, -1, 0, LVIS_SELECTED or LVIS_FOCUSED); + // Select it + if fRow>=fRealFixedRows then + if (fRow - fRealFixedRows)=0 do + begin + if fRowSelect then + fSelection.Right := fColCount - 1 + else + fSelection.Right := 0; + fSelection.Bottom := i + fRealFixedRows; + // ListView_GetNextItem(Handle, i, LVNI_SELECTED); + i := LLCL_SendMessage(Handle, LVM_GETNEXTITEM, i, LVNI_SELECTED); + end; + result := fSelection; +end; + +// Computes new RealFixed value +function TStringGrid.NewRealFixedRows(NewValue: integer): integer; +begin + result := 0; + if NewValue>0 then + if fRowCount>=1 then // Always 1 max + result := 1; // in LLCL +end; + +// Updates RealFixed value +procedure TStringGrid.UpdRealFixedRows(NewValue: integer); +var i: NativeUInt; +begin + if NewValue = fRealFixedRows then exit; + fRealFixedRows := NewValue; + if Handle=0 then exit; // Because may be called before created + i := LLCL_GetWindowLongPtr(Handle, GWL_STYLE); + if NewValue=0 then + LLCL_SetWindowLongPtr(Handle, GWL_STYLE, i or LVS_NOCOLUMNHEADER) + else + begin + LLCL_SetWindowLongPtr(Handle, GWL_STYLE, i and (not LVS_NOCOLUMNHEADER)); + UpdateHeaderStyle(); + end; +end; + +// Raises an error if ACol or/and ARow incorrect +function TStringGrid.CheckColRow(ACol, ARow: integer; Mode: integer): boolean; +begin + result := true; + if (Mode and 1)<>0 then + result := (fColWidths[ACol]=0); + if (Mode and 2)<>0 then + result := (fRowHeights[ARow]=0); +end; + +// Checks if Acol is correct (no error raised) +function TStringGrid.IsColumnOK(ACol: integer): boolean; +begin + result := (ACol>=0) and (ACol0 then + begin + if hWndHeader=0 then + // ListView_GetHeader(Handle); + hWndHeader := LLCL_SendMessage(Handle, LVM_GETHEADER, 0, 0); + if hWndHeader<>0 then + LLCL_SetWindowLongPtr(hWndHeader, GWL_STYLE, + (LLCL_GetWindowLongPtr(hWndHeader, GWL_STYLE) or AValue) and (not AMask)); + end + else + hWndHeader := 0; +end; + +// Updates Listview header style (after header creation) +procedure TStringGrid.UpdateHeaderStyle(); +begin +{$ifndef DefNo_ColumnSort} + SetColumnClickSorts(fColumnClickSorts); +{$else DefNo_ColumnSort} + ModifyHeaderStyle(0, HDS_BUTTONS); +{$endif DefNo_ColumnSort} + if not (goColSizing in fOptions) then + ModifyHeaderStyle(HDS_NOSIZING, 0); // Only for Vista+ +end; + +{$ifndef DefNo_ColumnSort} +// Modifies Listview header format for a column (Only for ComCtl32 version 6.00+) +procedure TStringGrid.ModifyHeaderColFmt(ACol: integer; AMode: integer); +var HDI: THDITEM; +begin + if fRealFixedRows>0 then + begin + if hWndHeader<>0 then + begin + FillChar(HDI, SizeOf(HDI), 0); + HDI.Mask := HDI_FORMAT; + // Header_GetItem(hHeader, ACol, HDI) + if boolean(LLCL_SendMessage(hWndHeader, HDM_GETITEM, WParam(ACol), LParam(@HDI))) then + begin + case AMode of + 0: // Ascending order + HDI.fmt := (HDI.fmt and (not HDF_SORTDOWN)) or HDF_SORTUP; + 1: // Descending order + HDI.fmt := (HDI.fmt or HDF_SORTDOWN) and (not HDF_SORTUP); + else // No order + HDI.fmt := HDI.fmt and (not (HDF_SORTDOWN or HDF_SORTUP)); + end; + end; + // Header_SetItem(hHeader, ACol, HDI) + LLCL_SendMessage(hWndHeader, HDM_SETITEM, WParam(ACol), LParam(@HDI)); + end; + end; +end; + +procedure TStringGrid.SetColumnClickSorts(AValue: boolean); +begin + fColumnClickSorts := AValue; + if Handle=0 then exit; // Because may be called before created + if AValue then + ModifyHeaderStyle(HDS_BUTTONS, 0) + else + begin + if Assigned(OnHeaderClick) then + ModifyHeaderStyle(HDS_BUTTONS, 0) + else + ModifyHeaderStyle(0, HDS_BUTTONS); + if IsColumnOK(fSortColumn) then + ModifyHeaderColFmt(fSortColumn, -1); // -1 = no order + end; +end; + +// Sort call +procedure TStringGrid.CallSort(FormerSortColumn: integer); +begin + if FormerSortColumn<>fSortColumn then + if IsColumnOK(FormerSortColumn) then + ModifyHeaderColFmt(FormerSortColumn, -1); // -1 = no order + ModifyHeaderColFmt(fSortColumn, Ord(fSortOrder)); + // ListView_SortItemsEx(Handle, Handle, @LV_CompareFunc); + LLCL_SendMessage(Handle, LVM_SORTITEMSEX, Handle, LPARAM(@LV_CompareFunc)); +end; +{$else DefNo_ColumnSort} +procedure TStringGrid.SetColumnClickSorts(AValue: boolean); +begin + fColumnClickSorts := AValue; +end; +{$endif DefNo_ColumnSort} + +// Restores focus to last item having it +procedure TStringGrid.RestoreLastFocusedItem; +begin + fCurCtrlState := 2; + LV_SetItemState(Handle, fLastItemFocused, LVIS_FOCUSED, LVIS_FOCUSED); + fCurCtrlState := 0; +end; + +// Processes notification (for Listview or Header Control) +function TStringGrid.ProcessNotification(var Msg: TMessage; IsForHeader: boolean): boolean; +var nItem, nSubItem: integer; +var lChangeAllowed: boolean; +{$ifndef DefNo_ColumnSort} +var SortColumnSave: integer; +{$endif DefNo_ColumnSort} +{$ifndef DefNo_StdMouseMessages} +var MouseButton: TMouseButton; +var ShiftState: TShiftState; +{$endif DefNo_StdMouseMessages} +{$ifndef DefNo_Column1Edit} +var CellValue: string; +{$endif DefNo_Column1Edit} +var uOldState, uNewState: cardinal; +begin + result := true; + case TWMNotify(Msg).NMHdr^.code of + LVN_ITEMCHANGING: + begin + nItem := PNMListView(Msg.lParam)^.iItem; + if nItem>=0 then + begin + lChangeAllowed := true; + uOldState := PNMListView(Msg.lParam)^.uOldState; + uNewState := PNMListView(Msg.lParam)^.uNewState; + // Ctrl+Click/Space not allowed for selection/unselection +{$ifdef DefNo_RightClickSelect} + if ((LLCL_GetKeyState(VK_CONTROL)<0) or (LLCL_GetKeyState(VK_RBUTTON)<0)) and (fCurCtrlState=0) then +{$else DefNo_RightClickSelect} + if (LLCL_GetKeyState(VK_CONTROL)<0) and (fCurCtrlState=0) then +{$endif DefNo_RightClickSelect} + begin + // No more selected - forces to selected again + if (((uOldState and LVIS_SELECTED)<>0) and ((uNewState and LVIS_SELECTED)=0)) + or + // Newly selected - forces to not selected again + (((uOldState and LVIS_SELECTED)=0) and ((uNewState and LVIS_SELECTED)<>0)) then + lChangeAllowed := false; +{$ifdef DefNo_RightClickSelect} + // RightClick + if LLCL_GetKeyState(VK_RBUTTON)<0 then + lChangeAllowed := false; +{$endif DefNo_RightClickSelect} + // Newly focused + if ((uOldState and LVIS_FOCUSED)=0) and ((uNewState and LVIS_FOCUSED)<>0) then + begin + lChangeAllowed := false; + RestoreLastFocusedItem(); + end; + if (not lChangeAllowed) then + begin + Msg.result := LRESULT(true); + result := false; + exit; + end; + end; + // OnSelectCell event (may append more than once, especially if click on selected item) + if ((uNewState and LVIS_SELECTED)<>0) then + begin + if Assigned(EOnSelectCell) then + begin + if fRealFixedRows>0 then nItem := nItem + 1; + nSubItem := PNMListView(Msg.lParam)^.iSubItem; + EOnSelectCell(self, nSubItem, nItem, lChangeAllowed); + if (not lChangeAllowed) then + begin + RestoreLastFocusedItem(); + Msg.result := LRESULT(true); + result := false; + end; + end; + end; + end; + end; + LVN_ITEMCHANGED: + begin + nItem := PNMListView(Msg.lParam)^.iItem; + if nItem>=0 then + begin + if (LLCL_GetKeyState(VK_CONTROL)>=0) and (fCurCtrlState=0) then + // Save last focused item + if (PNMListView(Msg.lParam)^.uNewState and LVIS_FOCUSED)<>0 then + fLastItemFocused := nItem; + end; + end; +{$ifndef DefNo_ColumnSort} + LVN_COLUMNCLICK: // Column title click + begin + // (no mouse button down/up events for title) + nSubItem := PNMListView(Msg.lParam)^.iSubItem; + if IsColumnOK(nSubItem) then + begin + if fColumnClickSorts then + begin + SortColumnSave := fSortColumn; + if nSubItem=fSortColumn then + begin + // Inverses order + if fSortOrder=soAscending then + fSortOrder := soDescending + else + fSortOrder := soAscending; + end + else + begin + fSortColumn := nSubItem; + fSortOrder := soAscending; + end; + CallSort(SortColumnSave); + SetRow(Row); // Re-focus on current selected row (only one, even if several are selected) + end; + if Assigned(OnHeaderClick) then + OnHeaderClick(self, true, nSubItem); + end; + end; +{$endif DefNo_ColumnSort} +{$ifndef DefNo_StdMouseMessages} + NM_CLICK, NM_DBLCLK, NM_RCLICK, NM_RDBLCLK: + begin + // Note concerning Listview Header Control (i.e. first row, if have fixed rows): + // OnMouseDown/OnMouseUp and OnClick/OnDblClick events not generated + if IsForHeader then exit; // (Got only NM_RCLICK for Listview Header) + if (TWMNotify(Msg).NMHdr^.code=NM_CLICK) or (TWMNotify(Msg).NMHdr^.code=NM_DBLCLK) then MouseButton := mbLeft else MouseButton := mbRight; + ShiftState := LV_KeysToShiftState(PNMItemActivate(Msg.lParam)^.uKeyFlags); + // for valid item/subitem (equivalent to AllowOutboundEvents=false) + nItem := PNMListView(Msg.lParam)^.iItem; +{$IFNDEF FPC} + // Delphi: double-click before mouse button down + if nItem>=0 then + case TWMNotify(Msg).NMHdr^.code of + NM_DBLCLK: + begin + if Assigned(OnDblClick) then + if not (ssCtrl in ShiftState) then + OnDblClick(self); +{$ifndef DefNo_Column1Edit} + if goEditing in fOptions then + CallEditCurRow(); +{$endif DefNo_Column1Edit} + end; + end; +{$ENDIF NFPC} + // mouse button down + if Assigned(OnMouseDown) then + OnMouseDown(self, MouseButton, ShiftState, PNMItemActivate(Msg.lParam)^.ptAction.X, PNMItemActivate(Msg.lParam)^.ptAction.Y); + // click and double-click + if nItem>=0 then + case TWMNotify(Msg).NMHdr^.code of + NM_CLICK: + if Assigned(OnClick) then + if not (ssCtrl in ShiftState) then + OnClick(self); +{$ifndef DefNo_RightClickSelect} + // In LLCL, right-click can also select an item + NM_RCLICK: + if Assigned(OnClick) then + if (not (ssCtrl in ShiftState)) and (not (ssShift in ShiftState)) then + OnClick(self); +{$endif DefNo_RightClickSelect} +{$IFDEF FPC} + // Free Pascal: double-click between mouse button down/up + NM_DBLCLK: + begin + if Assigned(OnDblClick) then + if not (ssCtrl in ShiftState) then + OnDblClick(self); +{$ifndef DefNo_Column1Edit} + if goEditing in fOptions then + CallEditCurRow(); +{$endif DefNo_Column1Edit} + end; +{$ENDIF FPC} + end; + // mouse button up + if Assigned(OnMouseUp) then + OnMouseUp(self, MouseButton, ShiftState, PNMItemActivate(Msg.lParam)^.ptAction.X, PNMItemActivate(Msg.lParam)^.ptAction.Y); + end; +{$else DefNo_StdMouseMessages} + NM_CLICK: // Left double-click processed in this case in standard WMLDblClick (Control.pas) + begin + if Assigned(OnClick) then + OnClick(self); + end; +{$endif DefNo_StdMouseMessages} +{$ifndef DefNo_Column1Edit} + LVN_KEYDOWN: + begin + if IsForHeader then exit; + if goEditing in fOptions then + if (PNMLVKeyDown(Msg.lParam)^.wVKey=VK_RETURN) or (PNMLVKeyDown(Msg.lParam)^.wVKey=VK_F2) then + CallEditCurRow(); + end; + LVN_BEGINLABELEDITA, LVN_BEGINLABELEDITW: + begin + if Assigned(OnGetEditText) then + begin + nItem := PNMLVDispInfo(Msg.lParam)^.item.iItem; + if fRealFixedRows>0 then nItem := nItem + 1; + nSubItem := PNMLVDispInfo(Msg.lParam)^.item.iSubItem; + CellValue := Cells[nSubItem, nItem]; + OnGetEditText(self, nSubItem, nItem, CellValue); + // (Can't update text if modified during OnGetEditText call) + end; + end; + LVN_ENDLABELEDITA, LVN_ENDLABELEDITW: + begin + if Assigned(OnSetEditText) then + begin + nItem := PNMLVDispInfo(Msg.lParam)^.item.iItem; + if fRealFixedRows>0 then nItem := nItem + 1; + nSubItem := PNMLVDispInfo(Msg.lParam)^.item.iSubItem; + if PNMLVDispInfo(Msg.lParam)^.item.pszText<>nil then + begin + if TWMNotify(Msg).NMHdr^.code=LVN_ENDLABELEDITA then + CellValue := LLCLS_GetTextAPtr(PAnsiChar(PNMLVDispInfo(Msg.lParam)^.item.pszText)) + else + CellValue := LLCLS_GetTextWPtr(PWideChar(PNMLVDispInfo(Msg.lParam)^.item.pszText)); + Cells[nSubItem, nItem] := CellValue; + OnSetEditText(self, nSubItem, nItem, CellValue); + // (Called only once when editing is done - like OnEditingDone) + end; + end; + end; +{$endif DefNo_Column1Edit} + end; +end; + +{$ifndef DefNo_Column1Edit} +procedure TStringGrid.CallEditCurRow(); +var nItem: integer; +begin + nItem := Row; + if fRealFixedRows>0 then nItem := nItem - 1; + if nItem>=0 then + // ListView_EditLabel(Handle, iItem); + LLCL_PostMessage(Handle, LVM_EDITLABEL, nItem, 0); +end; +{$endif DefNo_Column1Edit} + +{$ifndef DefNo_HeaderSupport} +// Mouse events call +procedure TStringGrid.ForMouseButton(MouseButton: TMouseButton; ShiftState: TShiftState; alParam: NativeUInt; EOnMouse: TMouseEvent); +begin + if Assigned(EOnMouse) then + EOnMouse(self, MouseButton, ShiftState, TSmallPoint(cardinal(alParam)).X, TSmallPoint(cardinal(alParam)).Y); +end; + +// Header Control property +function TStringGrid.GethWndHeader(): THandle; +begin + if fhWndHeader=0 then + begin + // ListView_GetHeader(Handle); + fhWndHeader := LLCL_SendMessage(Handle, LVM_GETHEADER, 0, 0); + if fhWndHeader<>0 then + begin + fHeaderWndProc := TFNWndProc(LLCL_SetWindowLongPtr(fhWndHeader, GWL_WNDPROC, NativeUInt(@ELVWndProc))); + LLCL_SetWindowLongPtr(fhWndHeader, GWL_USERDATA, NativeUInt(self)); + end; + end; + result := fhWndHeader; +end; + +procedure TStringGrid.SethWndHeader(Value: THandle); +begin + if Value=0 then + begin + if Assigned(fHeaderWndProc) then + LLCL_SetWindowLongPtr(fhWndHeader, GWL_WNDPROC, NativeUInt(fHeaderWndProc)); + fHeaderWndProc := nil; + end; + fhWndHeader := Value; +end; +{$endif DefNo_HeaderSupport} + +// Public method +procedure TStringGrid.SortColRow(IsColumn: boolean; Index: integer); +{$ifndef DefNo_ColumnSort} +var SortColumnSave: integer; +{$endif DefNo_ColumnSort} +begin +{$ifndef DefNo_ColumnSort} + // Only for columns + if not IsColumn then exit; + CheckColRow(0, Index, 1); // 1: Check Column only + SortColumnSave := fSortColumn; + fSortColumn := Index; + if Handle=0 then exit; // Because may be called before created + CallSort(SortColumnSave); +{$endif DefNo_ColumnSort} +end; + +//------------------------------------------------------------------------------ + +initialization + RegisterClasses([TStringGrid]); + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/IniFiles.pas b/sources/IniFiles.pas new file mode 100644 index 0000000..93c810e --- /dev/null +++ b/sources/IniFiles.pas @@ -0,0 +1,155 @@ +unit IniFiles; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * TIniFile implemented +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +uses + LLCLOSInt, + Classes, SysUTils; + +type + // (No intermediate classes used) + TIniFile = class(TObject) + private + fFileName: string; + public + constructor Create(const AFileName: string); + function ReadString(const Section, Ident, Default: string): string; virtual; + procedure WriteString(const Section, Ident, Value: string); virtual; + function ReadInteger(const Section, Ident: string; Default: integer): integer; virtual; + procedure WriteInteger(const Section, Ident: string; Value: integer); virtual; + function ReadInt64(const Section, Ident: string; Default: int64): int64; virtual; + procedure WriteInt64(const Section, Ident: string; Value: int64); virtual; + function ReadBool(const Section, Ident: string; Default: boolean): boolean; virtual; + procedure WriteBool(const Section, Ident: string; Value: boolean); virtual; + // (Caution: string date formating with LLCL SysUtils is specific) + function ReadDate(const Section, Ident: string; Default: TDateTime): TDateTime; virtual; + procedure WriteDate(const Section, Ident: string; Value: TDateTime); virtual; + procedure DeleteKey(const Section, Ident: string); virtual; + procedure EraseSection(const Section: string); virtual; + property FileName: string read fFileName; + end; + +//------------------------------------------------------------------------------ + +implementation + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +{ TIniFile } + +constructor TIniFile.Create(const AFileName: string); +begin + inherited Create(); + if ExtractFilePath(AFileName)='' then + fFileName := '.\' + AFileName + else + fFileName := AFileName; +end; + +function TIniFile.ReadString(const Section, Ident, Default: string): string; +begin + result := LLCLS_INI_ReadString(fFileName, Section, Ident, Default); +end; + +procedure TIniFile.WriteString(const Section, Ident, Value: string); +begin + LLCLS_INI_WriteString(fFileName, Section, Ident, Value); +end; + +function TIniFile.ReadInteger(const Section, Ident: string; Default: integer): integer; +begin + result := StrToIntDef(ReadString(Section, Ident, ''), Default); +end; + +procedure TIniFile.WriteInteger(const Section, Ident: string; Value: integer); +begin + WriteString(Section, Ident, IntToStr(Value)); +end; + +function TIniFile.ReadInt64(const Section, Ident: string; Default: int64): int64; +begin + result := StrToInt64Def(ReadString(Section, Ident, ''), Default); +end; + +procedure TIniFile.WriteInt64(const Section, Ident: string; Value: int64); +begin + WriteString(Section, Ident, IntToStr(Value)); +end; + +function TIniFile.ReadBool(const Section, Ident: string; Default: boolean): boolean; +begin + result := (ReadInteger(Section, Ident, integer(Default))<>0); +end; + +procedure TIniFile.WriteBool(const Section, Ident: string; Value: boolean); +const BoolString: array[boolean] of string = ('0', '1'); +begin + WriteString(Section, Ident, BoolString[Value]); +end; + +function TIniFile.ReadDate(const Section, Ident: string; Default: TDateTime): TDateTime; +begin + if not TryStrToDate(ReadString(Section, Ident, ''), result) then + result := Default; +end; + +procedure TIniFile.WriteDate(const Section, Ident: string; Value: TDateTime); +begin + WriteString(Section, Ident, DateToStr(Value)); +end; + +procedure TIniFile.DeleteKey(const Section, Ident: string); +begin + LLCLS_INI_Delete(fFileName, @Section[1], @Ident[1]); +end; + +procedure TIniFile.EraseSection(const Section: string); +begin + LLCLS_INI_Delete(fFileName, @Section[1], nil); +end; + +//------------------------------------------------------------------------------ + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/Interfaces.pp b/sources/Interfaces.pp index f578729..b07fb3a 100644 --- a/sources/Interfaces.pp +++ b/sources/Interfaces.pp @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. diff --git a/sources/LCLIntF.pas b/sources/LCLIntF.pas new file mode 100644 index 0000000..67959bf --- /dev/null +++ b/sources/LCLIntF.pas @@ -0,0 +1,110 @@ +unit LCLIntF; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + + Notes: + - very basic unit specific to FPC/Lazarus (not used with Delphi). +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +uses + LLCLOSInt, + Windows; + +const + LM_USER = Windows.WM_USER; + +function CallWindowProc(lpPrevWndFunc: TFarProc; Handle: HWND; Msg: UINT; WParam: WParam; LParam: LParam): integer; +function PostMessage(Handle: HWND; Msg: Cardinal; WParam: WParam; LParam: LParam): boolean; +function SendMessage(Handle: HWND; Msg: Cardinal; WParam: WParam; LParam: LParam): LRESULT; + +function MakeLong(A, B: word): DWORD; inline; +function MakeWParam(l, h: word): WPARAM; inline; +function MakeLParam(l, h: word): LPARAM; inline; +function MakeLResult(l, h: word): LRESULT; inline; + +//------------------------------------------------------------------------------ + +implementation + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +//------------------------------------------------------------------------------ + +function CallWindowProc(lpPrevWndFunc: TFarProc; Handle: HWND; Msg: UINT; WParam: WParam; LParam: LParam): integer; +begin + result := LLCL_CallWindowProc(lpPrevWndFunc, Handle, Msg, WParam, LParam); +end; + +function PostMessage(Handle: HWND; Msg: Cardinal; WParam: WParam; LParam: LParam): boolean; +begin + result := LLCL_PostMessage(Handle, Msg, WParam, LParam); +end; + +function SendMessage(Handle: HWND; Msg: Cardinal; WParam: WParam; LParam: LParam): LRESULT; +begin + result := LLCL_SendMessage(Handle, Msg, WParam, LParam); +end; + +function MakeLong(A, B: word): DWORD; inline; +begin + result := A or (B shl 16); +end; + +function MakeWParam(l, h: word): WPARAM; inline; +begin + result := MakeLong(l, h); +end; + +function MakeLParam(l, h: word): LPARAM; inline; +begin + result := MakeLong(l, h); +end; + +function MakeLResult(l, h: word): LRESULT; inline; +begin + result := MakeLong(l, h); +end; + +//------------------------------------------------------------------------------ + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/LCLType.pp b/sources/LCLType.pp index 81efe5a..256608b 100644 --- a/sources/LCLType.pp +++ b/sources/LCLType.pp @@ -12,15 +12,17 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * RT_**** constants added (point to Windows declarations) Version 1.00: * File creation. @@ -45,17 +47,33 @@ interface type TCreateParams = record // Not present in Control.pas for FPC/Lazarus - Caption: PChar; - Style: cardinal; - ExStyle: cardinal; - X, Y: integer; - Width, Height: integer; - WndParent: HWnd; - Param: pointer; - WindowClass: TWndClass; - WinClassName: array[0..63] of Char; + Caption: PChar; + Style: cardinal; + ExStyle: cardinal; + X, Y: integer; + Width, Height: integer; + WndParent: HWnd; + Param: pointer; + WindowClass: TWndClass; + WinClassName: array[0..63] of Char; end; +const + RT_CURSOR = Windows.RT_CURSOR; + RT_BITMAP = Windows.RT_BITMAP; + RT_ICON = Windows.RT_ICON; + RT_MENU = Windows.RT_MENU; + RT_DIALOG = Windows.RT_DIALOG; + RT_STRING = Windows.RT_STRING; + RT_FONTDIR = Windows.RT_FONTDIR; + RT_FONT = Windows.RT_FONT; + RT_ACCELERATOR = Windows.RT_ACCELERATOR; + RT_RCDATA = Windows.RT_RCDATA; + RT_MESSAGETABLE = Windows.RT_MESSAGETABLE; + RT_GROUP_CURSOR = Windows.RT_GROUP_CURSOR; + RT_GROUP_ICON = Windows.RT_GROUP_ICON; + RT_VERSION = Windows.RT_VERSION; + //------------------------------------------------------------------------------ implementation diff --git a/sources/LLCLFPCInc.inc b/sources/LLCLFPCInc.inc index f530351..c49e453 100644 --- a/sources/LLCLFPCInc.inc +++ b/sources/LLCLFPCInc.inc @@ -1,11 +1,11 @@ { - Optional compilation directives for FPC/Lazarus + Optional compilation directives for FPC/Lazarus - This file is a part of the Light LCL (LLCL). + This file is a part of the Light LCL (LLCL). - Notes: - - specific to FPC/Lazarus (not used with Delphi), - - external file because of Delphi (i.e. $if problem). + Notes: + - specific to FPC/Lazarus (not used with Delphi), + - external file because of Delphi (i.e. $if problem). } {$ifdef LLCL_FPC_MODESECTION} @@ -14,7 +14,12 @@ {$mode objfpc}{$H+} // {$mode delphi} // {$mode objfpc}{$modeswitch unicodestrings}{$H+} // Requires FPC 2.7.1+ -// {$mode delphiunicode} // Requires FPC 2.7.1+ +// {$mode delphiunicode}{$codepage UTF8} // Requires FPC 2.7.1+ + +// Specific (i.e. not LCL standard) Ansi only option (no UTF8 at all) +// Can't be used with any Unicode mode ({$modeswitch unicodestrings} or {$mode delphiunicode}) +// {$define LLCL_FPC_ANSI_ONLY} +{$IFDEF UNICODE} {$undef LLCL_FPC_ANSI_ONLY} {$ENDIF} {$else LLCL_FPC_MODESECTION} //------------------------------------------------------------------------------ @@ -44,18 +49,20 @@ // LLCLOSInt {$define LLCL_MISSING_WINDOWS_DEC} // Windows declarations missing +{$define LLCL_FPC_UTF8_EXTINC} // Constant message strings: UTF8 type {$if defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 999999)} {$undef LLCL_MISSING_WINDOWS_DEC} {$ifend} {$if defined(LLCL_FPC_27PLUS)} {$define LLCL_EXTWIN_WIDESTRUCT} // External Windows wide structures {$define LLCL_FPC_CPSTRING} // RawByteStrings have code page - {$ifdef EnableUTF8RTL} - {$define LLCL_FPC_UTF8RTL} // Has UTF8 RTL (LCL) + {$define LLCL_FPC_UTF8RTL} // Has UTF8 RTL (LCL) + {$ifdef DisableUTF8RTL} + {$undef LLCL_FPC_UTF8RTL} // Compliant with LCL {$endif} -{$else} - {$ifdef EnableUTF8RTL} - {$error EnableUTF8RTL requires FPC 2.7.1+} + {$ifdef LLCL_FPC_ANSI_ONLY} // Specific to LLCL + {$undef LLCL_FPC_UTF8RTL} // " " + {$undef LLCL_FPC_UTF8_EXTINC} // " " {$endif} {$ifend} diff --git a/sources/LLCLOSInt.pas b/sources/LLCLOSInt.pas index 1d159f2..7c237b9 100644 --- a/sources/LLCLOSInt.pas +++ b/sources/LLCLOSInt.pas @@ -12,15 +12,24 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * Transparent bitmap functions added + * ListView functions added + * Directory selection functions/structures added + * Ini files functions added + * Clipboard functions added + * Unicode version for FPC/Lazarus now uses Unicode Windows APIs only by default + * New specific mode support for FPC/Lazarus: Ansi only (see LLCL_FPC_ANSI_ONLY in LLCLFPCInc.inc) + * Internal function LLCLS_FreeMemAndNil added Version 1.00: * File creation. * Windows API and structures (only a subset) @@ -44,7 +53,15 @@ {$IFDEF DisableWindowsUnicodeSupport} {$DEFINE LLCL_UNICODE_API_A} // Ansi only {$ELSE} // (Ansi already means Ansi only) - {$DEFINE LLCL_UNICODE_API_W} // Ansi and Wide + {$IFDEF UNICODE} + {$DEFINE LLCL_UNICODE_API_W_ONLY} // Wide only + {$ELSE} + {$IFDEF LLCL_FPC_ANSI_ONLY} + {$DEFINE LLCL_UNICODE_API_A} // Ansi only + {$ELSE} + {$DEFINE LLCL_UNICODE_API_W} // Ansi and Wide + {$ENDIF} + {$ENDIF} {$ENDIF} {$ELSE FPC} {$IFDEF UNICODE} // Defined insided Delphi @@ -70,8 +87,8 @@ {$IFDEF LLCL_OPT_UNICODE_API_W_ONLY} {$UNDEF LLCL_UNICODE_API_A} + {$DEFINE LLCL_UNICODE_API_W} {$DEFINE LLCL_UNICODE_API_W_ONLY} - {$DEFINE LLCL_UNICODE_API_W_ONLY_ONLY} {$ENDIF} {$IFDEF LLCL_UNICODE_API_W_ONLY} // (Sanity) @@ -86,7 +103,11 @@ {$IFDEF UNICODE} {$DEFINE LLCL_UNICODE_STR_UTF16} // UTF16 {$ELSE} // - {$DEFINE LLCL_UNICODE_STR_UTF8} // or UTF8 + {$IFDEF LLCL_FPC_ANSI_ONLY} + {$DEFINE LLCL_UNICODE_STR_ANSI} // (or Ansi) + {$ELSE} // + {$DEFINE LLCL_UNICODE_STR_UTF8} // or UTF8 + {$ENDIF} {$ENDIF} {$ELSE FPC} {$IFDEF UNICODE} @@ -102,12 +123,12 @@ interface uses {$IFNDEF FPC} - ShellApi, + ShellApi, CommCtrl, ShlObj, {$ENDIF NFPC} Windows, CommDlg; {$IFDEF FPC} - {$I LLCLFPCInc.inc} // (for LLCL_MISSING_WINDOWS_DEC, LLCL_EXTWIN_WIDESTRUCT, LLCL_FPC_UTF8RTL, LLCL_FPC_CPSTRING, LLCL_FPC_ANSISYS or LLCL_FPC_UNISYS) + {$I LLCLFPCInc.inc} // (for LLCL_MISSING_WINDOWS_DEC, LLCL_EXTWIN_WIDESTRUCT, LLCL_FPC_UTF8RTL, LLCL_FPC_CPSTRING, LLCL_FPC_ANSI_LLCL, LLCL_FPC_ANSISYS or LLCL_FPC_UNISYS) {$ELSE FPC} {$if not Declared(CompilerVersion)} const CompilerVersion = 1; // Before Delphi 6 @@ -115,6 +136,7 @@ interface {$if CompilerVersion<20} // Before Delphi 2009 type NativeInt = Integer; type unicodestring = widestring; + type UnicodeChar = WideChar; type PUnicodeChar = PWideChar; {$ifend} {$if CompilerVersion<21} // Before Delphi 2010 @@ -135,7 +157,7 @@ interface // Constant message strings (language adaptation) //{$DEFINE LLCL_STR_USE_EXTINC} {$IFDEF LLCL_STR_USE_EXTINC} -{$if Defined(FPC) or Defined(UNICODE)} +{$if Defined(LLCL_FPC_UTF8_EXTINC) or Defined(UNICODE)} {$I LLCLSTREXTInc_UTF8.inc} {$else} {$I LLCLSTREXTInc_ANSI.inc} @@ -176,6 +198,12 @@ interface LLCL_WINXP_MAJ = 5; LLCL_WINXP_MIN = 01; LLCL_WINVISTA_MAJ = 6; LLCL_WINVISTA_MIN = 00; +// Structure Redefinitions +type + // Identical to TShiftState in Classes.pas (avoid to include Classes) + LLCL_TShiftState = + set of (ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble); + // API Redefinitions {$IFDEF FPC} type @@ -183,6 +211,7 @@ interface {$ELSE FPC} type HANDLE = THandle; + HIMAGELIST = THandle; LPSECURITY_ATTRIBUTES = PSecurityAttributes; {$ENDIF FPC} @@ -258,6 +287,11 @@ TNonClientMetricsW = record const INVALID_SET_FILE_POINTER = -1; INVALID_FILE_ATTRIBUTES = -1; +{$IFDEF FPC} + CSTR_LESS_THAN = 1; // string 1 less than string 2 + CSTR_EQUAL = 2; // string 1 equal to string 2 + CSTR_GREATER_THAN = 3; // string 1 greater than string 2 +{$ENDIF FPC} {$IFDEF LLCL_MISSING_WINDOWS_DEC} // Note: currently (FPC 2.6.4/2.7.x/3.x.x), PBM_GETPOS absent (WM_USER+8), and can't use CmmCtrl const @@ -266,9 +300,9 @@ TNonClientMetricsW = record type {$IFNDEF LLCL_UNICODE_API_W_ONLY} // (Internal only structure) - TCustomLogFont = TLogFontA; + TCustomLogFont = TLogFontA; {$ELSE} - TCustomLogFont = TLogFontW; + TCustomLogFont = TLogFontW; {$ENDIF} type @@ -352,6 +386,56 @@ TCustomNotifyIconDataExtW = record end; PCustomNotifyIconDataExtW = ^TCustomNotifyIconDataExtW; +{$IFDEF FPC} +// Redefined + TBrowseInfoA = record + hwndOwner: HWND; + pidlRoot: PItemIDList; + pszDisplayName: PAnsiChar; + lpszTitle: PAnsiChar; + ulFlags: cardinal; + lpfn: BFFCALLBACK; + lParam: LPARAM; + iImage: cardinal; + end; + TBrowseInfoW = record + hwndOwner: HWND; + pidlRoot: PItemIDList; + pszDisplayName: PWideChar; + lpszTitle: PWideChar; + ulFlags: cardinal; + lpfn: BFFCALLBACK; + lParam: LPARAM; + iImage: cardinal; + end; +{$IFNDEF LLCL_UNICODE_API_W_ONLY} // (Internal only structure) + TBrowseInfo = TBrowseInfoA; +{$ELSE} + TBrowseInfo = TBrowseInfoW; +{$ENDIF} +const + BIF_RETURNONLYFSDIRS = $0001; + BIF_EDITBOX = $0010; + BIF_VALIDATE = $0020; + BIF_NEWDIALOGSTYLE = $0040; + BIF_NONEWFOLDERBUTTON = $0200; + BIF_NOTRANSLATETARGETS = $0400; + BIF_BROWSEINCLUDEFILES = $4000; + BIF_SHAREABLE = $8000; + BFFM_INITIALIZED = 1; + BFFM_SELCHANGED = 2; + BFFM_VALIDATEFAILEDA = 3; + BFFM_VALIDATEFAILEDW = 4; + BFFM_ENABLEOK = WM_USER + 101; + BFFM_SETSELECTIONA = WM_USER + 102; + BFFM_SETSELECTIONW = WM_USER + 103; +{$ELSE FPC} +const + BIF_NONEWFOLDERBUTTON = $0200; +{$ENDIF FPC} + +// Specific +type TOpenStrParam = record sFilter: string; sFileName: string; @@ -368,7 +452,10 @@ TOpenStrParam = record TCustomWin32FindData = TWin32FindDataW; {$ENDIF} const - LLCLC_LENCOM_WIN32FINDDATA = 44; // Common beginning part, before variable (Ansi/Wide) part + LLCLC_LENCOM_WIN32FINDDATA = 44; // Common beginning part, before variable (Ansi/Wide) part + +const + LLCLC_LISTVIEW_MAXCHAR = 4096; // Maximum number of characters for ListView // API Declarations with both Ansi/Unicode versions @@ -376,9 +463,11 @@ TOpenStrParam = record CKERNEL32 = 'kernel32.dll'; CUSER32 = 'user32.dll'; CGDI32 = 'gdi32.dll'; + MSIMG32 = 'msimg32.dll'; CCOMCTL32 = 'comctl32.dll'; CCOMDLG32 = 'comdlg32.dll'; CSHELL32 = 'shell32.dll'; + COLE32 = 'ole32.dll'; CVERSION = 'version.dll'; function GetVersionExW(var lpVersionInformation: TOSVersionInfoW): BOOL; stdcall; external CKERNEL32 name 'GetVersionExW'; @@ -398,10 +487,11 @@ function GetFullPathNameW(lpFileName: LPCWSTR; nBufferLength: DWORD; lpBuffer: function GetDiskFreeSpaceW(lpRootPathName: LPCWSTR; var lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; stdcall; external CKERNEL32 name 'GetDiskFreeSpaceW'; function GetDiskFreeSpaceExW(lpDirectoryName: LPCWSTR; lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes: PInt64): BOOL; stdcall; external CKERNEL32 name 'GetDiskFreeSpaceExW'; function FormatMessageW(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD; lpBuffer: LPCWSTR; nSize: DWORD; Arguments: Pointer): DWORD; stdcall; external CKERNEL32 name 'FormatMessageW'; -function CharToOemW(lpszSrc: LPCWSTR; lpszDst: LPCSTR): BOOL; stdcall; external CUSER32 name 'CharToOemW'; function CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: LPCWSTR; cchCount1: Integer; lpString2: LPCWSTR; cchCount2: Integer): Integer; stdcall; external CKERNEL32 name 'CompareStringW'; function LoadLibraryW(lpLibFileName: LPCWSTR): HMODULE; stdcall; external CKERNEL32 name 'LoadLibraryW'; function CreateEventW(lpEventAttributes: LPSECURITY_ATTRIBUTES; bManualReset: BOOL; bInitialState: BOOL; lpName: LPCWSTR): HANDLE; stdcall; external CKERNEL32 name 'CreateEventW'; +function GetPrivateProfileStringW(lpAppName, lpKeyName, lpDefault: LPCWSTR; lpReturnedString: LPWSTR; nSize: DWORD; lpFileName: LPCWSTR): DWORD; stdcall; external CKERNEL32 name 'GetPrivateProfileStringW'; +function CharToOemW(lpszSrc: LPCWSTR; lpszDst: LPCSTR): BOOL; stdcall; external CUSER32 name 'CharToOemW'; function RegisterClassW(const lpWndClass: TWndClassW): ATOM; stdcall; external CUSER32 name 'RegisterClassW'; function UnregisterClassW(lpClassName: LPCWSTR; hInstance: HINST): BOOL; stdcall; external CUSER32 name 'UnregisterClassW'; function CreateWindowExW(dwExStyle: DWORD; lpClassName: LPCWSTR; lpWindowName: LPCWSTR; @@ -411,10 +501,10 @@ function CallWindowProcW(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; wPar function PeekMessageW(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; external CUSER32 name 'PeekMessageW'; function DispatchMessageW(const lpMsg: TMsg): longint; stdcall; external CUSER32 name 'DispatchMessageW'; function SendMessageW(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'SendMessageW'; -function PostMessageW(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'PostMessageW'; +function PostMessageW(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): BOOL; stdcall; external CUSER32 name 'PostMessageW'; function GetWindowLongW(hWnd: HWND; nIndex: Integer): longint; stdcall; external CUSER32 name 'GetWindowLongW'; function SetWindowLongW(hWnd: HWND; nIndex: Integer; dwNewLong: longint): longint; stdcall; external CUSER32 name 'SetWindowLongW'; -{$ifdef cpu64} +{$if Defined(CPU64) or Defined(CPU64BITS)} function GetClassLongPtrW(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetClassLongPtrW'; function SetClassLongPtrW(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetClassLongPtrW'; function GetWindowLongPtrW(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetWindowLongPtrW'; @@ -424,7 +514,7 @@ function GetClassLongPtrW(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; ex function SetClassLongPtrW(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetClassLongW'; function GetWindowLongPtrW(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetWindowLongW'; function SetWindowLongPtrW(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetWindowLongW'; -{$endif} +{$ifend} function DrawTextW(hDC: HDC; lpString: LPCWSTR; nCount: Integer; var lpRect: TRect; uFormat: UINT): Integer; stdcall; external CUSER32 name 'DrawTextW'; function LoadIconW(hInstance: HINST; lpIconName: LPCWSTR): HICON; stdcall; external CUSER32 name 'LoadIconW'; function LoadCursorW(hInstance: HINST; lpCursorName: LPCWSTR): HCURSOR; stdcall; external CUSER32 name 'LoadCursorW'; @@ -439,6 +529,8 @@ function ExtTextOutW(DC: HDC; X, Y: Integer; Options: longint; Rect: PRect; Str function GetTextExtentPoint32W(DC: HDC; Str: LPCWSTR; Count: Integer; var Size: TSize): BOOL; stdcall; external CGDI32 name 'GetTextExtentPoint32W'; function CreateFontIndirectW(const p1: TLogFontW): HFONT; stdcall; external CGDI32 name 'CreateFontIndirectW'; function Shell_NotifyIconW(dwMessage: DWORD; lpData: PNotifyIconDataW): BOOL; stdcall; external CSHELL32 name 'Shell_NotifyIconW'; +function SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; stdcall; external CSHELL32 name 'SHBrowseForFolderW'; +function SHGetPathFromIDListW(pidl: PItemIDList; pszPath: LPWSTR): BOOL; stdcall; external CSHELL32 name 'SHGetPathFromIDListW'; function GetOpenFileNameW(var OpenFile: TOpenFilenameW): BOOL; stdcall; external CCOMDLG32 name 'GetOpenFileNameW'; function GetSaveFileNameW(var OpenFile: TOpenFilenameW): BOOL; stdcall; external CCOMDLG32 name 'GetSaveFileNameW'; function GetFileVersionInfoSizeW(lptstrFilename: LPCWSTR; var lpdwHandle: DWORD): DWORD; stdcall; external CVERSION name 'GetFileVersionInfoSizeW'; @@ -462,23 +554,24 @@ function GetFullPathNameA(lpFileName: LPCSTR; nBufferLength: DWORD; lpBuffer: L function GetDiskFreeSpaceA(lpRootPathName: LPCSTR; var lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; stdcall; external CKERNEL32 name 'GetDiskFreeSpaceA'; function GetDiskFreeSpaceExA(lpDirectoryName: LPCSTR; lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes: PInt64): BOOL; stdcall; external CKERNEL32 name 'GetDiskFreeSpaceExA'; function FormatMessageA(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD; lpBuffer: LPCSTR; nSize: DWORD; Arguments: Pointer): DWORD; stdcall; external CKERNEL32 name 'FormatMessageA'; -function CharToOemA(lpszSrc: LPCSTR; lpszDst: LPCSTR): BOOL; stdcall; external CUSER32 name 'CharToOemA'; function CompareStringA(Locale: LCID; dwCmpFlags: DWORD; lpString1: LPCSTR; cchCount1: Integer; lpString2: PAnsiChar; cchCount2: Integer): Integer; stdcall; external CKERNEL32 name 'CompareStringA'; function LoadLibraryA(lpLibFileName: LPCSTR): HMODULE; stdcall; external CKERNEL32 name 'LoadLibraryA'; function CreateEventA(lpEventAttributes: LPSECURITY_ATTRIBUTES; bManualReset: BOOL; bInitialState: BOOL; lpName: LPCSTR): HANDLE; stdcall; external CKERNEL32 name 'CreateEventA'; +function GetPrivateProfileStringA(lpAppName, lpKeyName, lpDefault: LPCSTR; lpReturnedString: LPSTR; nSize: DWORD; lpFileName: LPCSTR): DWORD; stdcall; external CKERNEL32 name 'GetPrivateProfileStringA'; +function CharToOemA(lpszSrc: LPCSTR; lpszDst: LPCSTR): BOOL; stdcall; external CUSER32 name 'CharToOemA'; function RegisterClassA(const lpWndClass: TWndClassA): ATOM; stdcall; external CUSER32 name 'RegisterClassA'; function UnregisterClassA(lpClassName: LPCSTR; hInstance: HINST): BOOL; stdcall; external CUSER32 name 'UnregisterClassA'; function CreateWindowExA(dwExStyle: DWORD; lpClassName: LPCSTR; lpWindowName: LPCSTR; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND; stdcall; external CUSER32 name 'CreateWindowExA'; -function DefWindowProcA(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'DefWindowProcA'; +function DefWindowProcA(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'DefWindowProcA'; function CallWindowProcA(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'CallWindowProcA'; function PeekMessageA(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; external CUSER32 name 'PeekMessageA'; function DispatchMessageA(const lpMsg: TMsg): longint; stdcall; external CUSER32 name 'DispatchMessageA'; function SendMessageA(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'SendMessageA'; -function PostMessageA(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; external CUSER32 name 'PostMessageA'; +function PostMessageA(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): BOOL; stdcall; external CUSER32 name 'PostMessageA'; function GetWindowLongA(hWnd: HWND; nIndex: Integer): longint; stdcall; external CUSER32 name 'GetWindowLongA'; function SetWindowLongA(hWnd: HWND; nIndex: Integer; dwNewLong: longint): longint; stdcall; external CUSER32 name 'SetWindowLongA'; -{$ifdef cpu64} +{$if Defined(CPU64) or Defined(CPU64BITS)} function GetClassLongPtrA(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetClassLongPtrA'; function SetClassLongPtrA(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetClassLongPtrA'; function GetWindowLongPtrA(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetWindowLongPtrA'; @@ -488,7 +581,7 @@ function GetClassLongPtrA(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; ex function SetClassLongPtrA(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetClassLongA'; function GetWindowLongPtrA(hWnd: HWND; nIndex: Integer): NativeUInt; stdcall; external CUSER32 name 'GetWindowLongA'; function SetWindowLongPtrA(hWnd: HWND; nIndex: Integer; dwNewLong: NativeUInt): NativeUInt; stdcall; external CUSER32 name 'SetWindowLongA'; -{$endif} +{$ifend} function DrawTextA(hDC: HDC; lpString: LPCSTR; nCount: Integer; var lpRect: TRect; uFormat: UINT): Integer; stdcall; external CUSER32 name 'DrawTextA'; function LoadIconA(hInstance: HINST; lpIconName: LPCSTR): HICON; stdcall; external CUSER32 name 'LoadIconA'; function LoadCursorA(hInstance: HINST; lpCursorName: LPCSTR): HCURSOR; stdcall; external CUSER32 name 'LoadCursorA'; @@ -503,6 +596,8 @@ function ExtTextOutA(DC: HDC; X, Y: Integer; Options: longint; Rect: PRect; Str function GetTextExtentPoint32A(DC: HDC; Str: LPCSTR; Count: Integer; var Size: TSize): BOOL; stdcall; external CGDI32 name 'GetTextExtentPoint32A'; function CreateFontIndirectA(const p1: TLogFontA): HFONT; stdcall; external CGDI32 name 'CreateFontIndirectA'; function Shell_NotifyIconA(dwMessage: DWORD; lpData: PNotifyIconDataA): BOOL; stdcall; external CSHELL32 name 'Shell_NotifyIconA'; +function SHBrowseForFolderA(var lpbi: TBrowseInfoA): PItemIDList; stdcall; external CSHELL32 name 'SHBrowseForFolderA'; +function SHGetPathFromIDListA(pidl: PItemIDList; pszPath: LPSTR): BOOL; stdcall; external CSHELL32 name 'SHGetPathFromIDListA'; function GetOpenFileNameA(var OpenFile: TOpenFilenameA): BOOL; stdcall; external CCOMDLG32 name 'GetOpenFileNameA'; function GetSaveFileNameA(var OpenFile: TOpenFilenameA): BOOL; stdcall; external CCOMDLG32 name 'GetSaveFileNameA'; function GetFileVersionInfoSizeA(lptstrFilename: LPCSTR; var lpdwHandle: DWORD): DWORD; stdcall; external CVERSION name 'GetFileVersionInfoSizeA'; @@ -542,8 +637,13 @@ function FindClose(hFindFile: HANDLE): BOOL; stdcall; external CKERNEL32 name ' function GetACP(): UINT; stdcall; external CKERNEL32 name 'GetACP'; function GetOEMCP(): UINT; stdcall; external CKERNEL32 name 'GetOEMCP'; function LoadResource(hModule: HINST; hResInfo: HRSRC): HGLOBAL; stdcall; external CKERNEL32 name 'LoadResource'; -function LockResource(hResData: HGLOBAL): pointer; stdcall; external CKERNEL32 name 'LockResource'; +function LockResource(hResData: HGLOBAL): Pointer; stdcall; external CKERNEL32 name 'LockResource'; function FreeResource(hResData: HGLOBAL): BOOL; stdcall; external CKERNEL32 name 'FreeResource'; +function FreeLibrary(hModule: HMODULE): BOOL; stdcall; external CKERNEL32 name 'FreeLibrary'; +function GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; stdcall; external CKERNEL32 name 'GlobalAlloc'; +function GlobalLock(hMem: HGLOBAL): Pointer; stdcall; external CKERNEL32 name 'GlobalLock'; +function GlobalUnlock(hMem: HGLOBAL): BOOL; stdcall; external CKERNEL32 name 'GlobalUnlock'; +function GlobalFree(hMem: HGLOBAL): HGLOBAL; stdcall; external CKERNEL32 name 'GlobalFree'; function TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; external CUSER32 name 'TranslateMessage'; function WaitMessage: BOOL; stdcall; external CUSER32 name 'WaitMessage'; procedure PostQuitMessage(nExitCode: Integer); stdcall; external CUSER32 name 'PostQuitMessage'; @@ -592,6 +692,12 @@ function DeleteMenu(hMenu: HMENU; uPosition, uFlags: UINT): BOOL; stdcall; exte function DestroyMenu(hMenu: HMENU): BOOL; stdcall; external CUSER32 name 'DestroyMenu'; function GetSysColor(nIndex: Integer): DWORD; stdcall; external CUSER32 name 'GetSysColor'; function MessageBeep(uType: UINT): BOOL; stdcall; external CUSER32 name 'MessageBeep'; +function OpenClipboard(hWndNewOwner: HWND): BOOL; stdcall; external CUSER32 name 'OpenClipboard'; +function EmptyClipboard(): BOOL; stdcall; external CUSER32 name 'EmptyClipboard'; +function GetClipboardData(uFormat: UINT): HANDLE; stdcall; external CUSER32 name 'GetClipboardData'; +function SetClipboardData(uFormat: UINT; hMem: HANDLE): HANDLE; stdcall; external CUSER32 name 'SetClipboardData'; +function IsClipboardFormatAvailable(uFormat: UINT): BOOL; stdcall; external CUSER32 name 'IsClipboardFormatAvailable'; +function CloseClipboard(): BOOL; stdcall; external CUSER32 name 'CloseClipboard'; function SetBkMode(DC: HDC; BkMode: Integer): Integer; stdcall; external CGDI32 name 'SetBkMode'; function SetBkColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; external CGDI32 name 'SetBkColor'; function SelectObject(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall; external CGDI32 name 'SelectObject'; @@ -607,7 +713,13 @@ function SetTextColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; external CG function SetStretchBltMode(DC: HDC; StretchMode: Integer): Integer; stdcall; external CGDI32 name 'SetStretchBltMode'; function StretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT; Rop: DWORD): Integer; stdcall; external CGDI32 name 'StretchDIBits'; function SetDIBitsToDevice(DC: HDC; DestX, DestY: Integer; Width, Height: DWORD; SrcX, SrcY: Integer; nStartScan, NumScans: UINT; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT): Integer; stdcall; external CGDI32 name 'SetDIBitsToDevice'; +function BitBlt(hdcDest: HDC; nXDest, nYDest, nWidth, nHeight: Integer; hdcSrc: HDC; nXSrc, nYSrc: Integer; dwRop: DWORD): BOOL; stdcall; external CGDI32 name 'BitBlt'; +function CreateCompatibleDC(hDC: HDC): HDC; stdcall; external CGDI32 name 'CreateCompatibleDC'; +function DeleteDC(hDC: HDC): BOOL; stdcall; external CGDI32 name 'DeleteDC'; +function CreateDIBitmap(hDc: HDC; lpbmih: PBITMAPINFOHEADER; fdwInit: DWORD; lpbInit: pByte; lpbmi: PBITMAPINFO; fuUsage: UINT): HBITMAP; stdcall; external CGDI32 name 'CreateDIBitmap'; +function CreateCompatibleBitmap(hDC: HDC; nWidth, nHeight: Integer): HBITMAP; stdcall; external CGDI32 name 'CreateCompatibleBitmap'; procedure InitCommonControls(); stdcall; external CCOMCTL32 name 'InitCommonControls'; +procedure CoTaskMemFree(pv: Pointer); stdcall; external COLE32 name 'CoTaskMemFree'; // API Functions mapping @@ -622,7 +734,7 @@ function LLCL_CallWindowProc(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; function LLCL_PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; function LLCL_DispatchMessage(const lpMsg: TMsg): longint; function LLCL_SendMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; -function LLCL_PostMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; +function LLCL_PostMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): BOOL; function LLCL_GetWindowLong(hWnd: HWND; nIndex: Integer): longint; function LLCL_SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: longint): longint; function LLCL_GetClassLongPtr(hWnd: HWND; nIndex: Integer): NativeUInt; @@ -690,8 +802,13 @@ function LLCL_FindClose(hFindFile: HANDLE): BOOL; stdcall; function LLCL_GetACP(): UINT; stdcall; function LLCL_GetOEMCP(): UINT; stdcall; function LLCL_LoadResource(hModule: HINST; hResInfo: HRSRC): HGLOBAL; stdcall; -function LLCL_LockResource(hResData: HGLOBAL): pointer; stdcall; +function LLCL_LockResource(hResData: HGLOBAL): Pointer; stdcall; function LLCL_FreeResource(hResData: HGLOBAL): BOOL; stdcall; +function LLCL_FreeLibrary(hModule: HMODULE): BOOL; stdcall; +function LLCL_GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; stdcall; +function LLCL_GlobalLock(hMem: HGLOBAL): Pointer; stdcall; +function LLCL_GlobalUnlock(hMem: HGLOBAL): BOOL; stdcall; +function LLCL_GlobalFree(hMem: HGLOBAL): HGLOBAL; stdcall; function LLCL_TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; function LLCL_WaitMessage: BOOL; stdcall; procedure LLCL_PostQuitMessage(nExitCode: Integer); stdcall; @@ -740,6 +857,12 @@ function LLCL_DeleteMenu(hMenu: HMENU; uPosition, uFlags: UINT): BOOL; stdcall; function LLCL_DestroyMenu(hMenu: HMENU): BOOL; stdcall; function LLCL_GetSysColor(nIndex: Integer): DWORD; stdcall; function LLCL_MessageBeep(uType: UINT): BOOL; stdcall; +function LLCL_OpenClipboard(hWndNewOwner: HWND): BOOL; stdcall; +function LLCL_EmptyClipboard(): BOOL; stdcall; +function LLCL_GetClipboardData(uFormat: UINT): HANDLE; stdcall; +function LLCL_SetClipboardData(uFormat: UINT; hMem: HANDLE): HANDLE; stdcall; +function LLCL_IsClipboardFormatAvailable(uFormat: UINT): BOOL; stdcall; +function LLCL_CloseClipboard(): BOOL; stdcall; function LLCL_SetBkMode(DC: HDC; BkMode: Integer): Integer; stdcall; function LLCL_SetBkColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; function LLCL_SelectObject(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall; @@ -755,6 +878,11 @@ function LLCL_SetTextColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; function LLCL_SetStretchBltMode(DC: HDC; StretchMode: Integer): Integer; stdcall; function LLCL_StretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT; Rop: DWORD): Integer; stdcall; function LLCL_SetDIBitsToDevice(DC: HDC; DestX, DestY: Integer; Width, Height: DWORD; SrcX, SrcY: Integer; nStartScan, NumScans: UINT; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT): Integer; stdcall; +function LLCL_BitBlt(hdcDest: HDC; nXDest, nYDest, nWidth, nHeight: Integer; hdcSrc: HDC; nXSrc, nYSrc: Integer; dwRop: DWORD): BOOL; stdcall; +function LLCL_CreateCompatibleDC(hDC: HDC): HDC; stdcall; +function LLCL_DeleteDC(hDC: HDC): BOOL; stdcall; +function LLCL_CreateDIBitmap(hDc: HDC; lpbmih: PBITMAPINFOHEADER; fdwInit: DWORD; lpbInit: pByte; lpbmi: PBITMAPINFO; fuUsage: UINT): HBITMAP; stdcall; +function LLCL_CreateCompatibleBitmap(hDC: HDC; nWidth, nHeight: Integer): HBITMAP; stdcall; procedure LLCL_InitCommonControls(); stdcall; {$ELSE} function LLCL_GetLastError(): DWORD; stdcall; external CKERNEL32 name 'GetLastError'; @@ -788,8 +916,13 @@ function LLCL_FindClose(hFindFile: HANDLE): BOOL; stdcall; external CKERNEL32 n function LLCL_GetACP(): UINT; stdcall; external CKERNEL32 name 'GetACP'; function LLCL_GetOEMCP(): UINT; stdcall; external CKERNEL32 name 'GetOEMCP'; function LLCL_LoadResource(hModule: HINST; hResInfo: HRSRC): HGLOBAL; stdcall; external CKERNEL32 name 'LoadResource'; -function LLCL_LockResource(hResData: HGLOBAL): pointer; stdcall; external CKERNEL32 name 'LockResource'; +function LLCL_LockResource(hResData: HGLOBAL): Pointer; stdcall; external CKERNEL32 name 'LockResource'; function LLCL_FreeResource(hResData: HGLOBAL): BOOL; stdcall; external CKERNEL32 name 'FreeResource'; +function LLCL_FreeLibrary(hModule: HMODULE): BOOL; stdcall; external CKERNEL32 name 'FreeLibrary'; +function LLCL_GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; stdcall; external CKERNEL32 name 'GlobalAlloc'; +function LLCL_GlobalLock(hMem: HGLOBAL): Pointer; stdcall; external CKERNEL32 name 'GlobalLock'; +function LLCL_GlobalUnlock(hMem: HGLOBAL): BOOL; stdcall; external CKERNEL32 name 'GlobalUnlock'; +function LLCL_GlobalFree(hMem: HGLOBAL): HGLOBAL; stdcall; external CKERNEL32 name 'GlobalFree'; function LLCL_TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; external CUSER32 name 'TranslateMessage'; function LLCL_WaitMessage: BOOL; stdcall; external CUSER32 name 'WaitMessage'; procedure LLCL_PostQuitMessage(nExitCode: Integer); stdcall; external CUSER32 name 'PostQuitMessage'; @@ -838,6 +971,12 @@ function LLCL_DeleteMenu(hMenu: HMENU; uPosition, uFlags: UINT): BOOL; stdcall; function LLCL_DestroyMenu(hMenu: HMENU): BOOL; stdcall; external CUSER32 name 'DestroyMenu'; function LLCL_GetSysColor(nIndex: Integer): DWORD; stdcall; external CUSER32 name 'GetSysColor'; function LLCL_MessageBeep(uType: UINT): BOOL; stdcall; external CUSER32 name 'MessageBeep'; +function LLCL_OpenClipboard(hWndNewOwner: HWND): BOOL; stdcall; external CUSER32 name 'OpenClipboard'; +function LLCL_EmptyClipboard(): BOOL; stdcall; external CUSER32 name 'EmptyClipboard'; +function LLCL_GetClipboardData(uFormat: UINT): HANDLE; stdcall; external CUSER32 name 'GetClipboardData'; +function LLCL_SetClipboardData(uFormat: UINT; hMem: HANDLE): HANDLE; stdcall; external CUSER32 name 'SetClipboardData'; +function LLCL_IsClipboardFormatAvailable(uFormat: UINT): BOOL; stdcall; external CUSER32 name 'IsClipboardFormatAvailable'; +function LLCL_CloseClipboard(): BOOL; stdcall; external CUSER32 name 'CloseClipboard'; function LLCL_SetBkMode(DC: HDC; BkMode: Integer): Integer; stdcall; external CGDI32 name 'SetBkMode'; function LLCL_SetBkColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; external CGDI32 name 'SetBkColor'; function LLCL_SelectObject(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall; external CGDI32 name 'SelectObject'; @@ -853,6 +992,11 @@ function LLCL_SetTextColor(DC: HDC; Color: COLORREF): COLORREF; stdcall; extern function LLCL_SetStretchBltMode(DC: HDC; StretchMode: Integer): Integer; stdcall; external CGDI32 name 'SetStretchBltMode'; function LLCL_StretchDIBits(DC: HDC; DestX, DestY, DestWidth, DestHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT; Rop: DWORD): Integer; stdcall; external CGDI32 name 'StretchDIBits'; function LLCL_SetDIBitsToDevice(DC: HDC; DestX, DestY: Integer; Width, Height: DWORD; SrcX, SrcY: Integer; nStartScan, NumScans: UINT; Bits: Pointer; var BitsInfo: TBitmapInfo; Usage: UINT): Integer; stdcall; external CGDI32 name 'SetDIBitsToDevice'; +function LLCL_BitBlt(hdcDest: HDC; nXDest, nYDest, nWidth, nHeight: Integer; hdcSrc: HDC; nXSrc, nYSrc: Integer; dwRop: DWORD): BOOL; stdcall; external CGDI32 name 'BitBlt'; +function LLCL_CreateCompatibleDC(hDC: HDC): HDC; stdcall; external CGDI32 name 'CreateCompatibleDC'; +function LLCL_DeleteDC(hDC: HDC): BOOL; stdcall; external CGDI32 name 'DeleteDC'; +function LLCL_CreateDIBitmap(hDc: HDC; lpbmih: PBITMAPINFOHEADER; fdwInit: DWORD; lpbInit: pByte; lpbmi: PBITMAPINFO; fuUsage: UINT): HBITMAP; stdcall; external CGDI32 name 'CreateDIBitmap'; +function LLCL_CreateCompatibleBitmap(hDC: HDC; nWidth, nHeight: Integer): HBITMAP; stdcall; external CGDI32 name 'CreateCompatibleBitmap'; procedure LLCL_InitCommonControls(); stdcall; external CCOMCTL32 name 'InitCommonControls'; {$ENDIF} @@ -860,7 +1004,7 @@ procedure LLCL_InitCommonControls(); stdcall; external CCOMCTL32 name 'InitCommo // Ansi APIs without any transformations (for FPC SysUtils only) // (Not sensible to LLCL_UNICODE_API_xxxx) function LLCLSys_CreateFile(lpFileName: PChar; dwDesiredAccess, dwShareMode: DWORD; lpSecurityAttributes: LPSECURITY_ATTRIBUTES; dwCreationDisposition: DWORD; dwFlagsAndAttributes: DWORD; hTemplateFile: HANDLE; var LastOSError: DWORD): HANDLE; -function LLCLSys_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; +function LLCLSys_FindFirstNextFile(const sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; function LLCLSys_GetFileAttributes(lpFileName: PChar): DWORD; function LLCLSys_GetFileAttributesEx(lpFileName: PChar; fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer; var LastOSError: DWORD): BOOL; function LLCLSys_CreateDirectory(lpPathName: PChar; lpSecurityAttributes: PSecurityAttributes): BOOL; @@ -874,7 +1018,7 @@ function LLCLSys_GetFileVersionInfo(lptstrFilename: PChar; dwHandle, dwLen: DWO function LLCLSys_VerQueryValue(pBlock: Pointer; lpSubBlock: PChar; var lplpBuffer: Pointer; var puLen: UINT): BOOL; function LLCLSys_LoadLibrary(lpLibFileName: PChar): HMODULE; // -function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; function LLCLSys_CharUpperBuff(const sText: string): string; function LLCLSys_CharLowerBuff(const sText: string): string; {$ENDIF} @@ -882,7 +1026,7 @@ function LLCLSys_CharLowerBuff(const sText: string): string; // Unicode APIs without any transformations (for FPC SysUtils only) // (Not sensible to LLCL_UNICODE_API_xxxx) function LLCLSys_CreateFile(lpFileName: PUnicodeChar; dwDesiredAccess, dwShareMode: DWORD; lpSecurityAttributes: LPSECURITY_ATTRIBUTES; dwCreationDisposition: DWORD; dwFlagsAndAttributes: DWORD; hTemplateFile: HANDLE; var LastOSError: DWORD): HANDLE; -function LLCLSys_FindFirstNextFile(sFileName: unicodestring; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: unicodestring; var LastOSError: DWORD): HANDLE; +function LLCLSys_FindFirstNextFile(const sFileName: unicodestring; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: unicodestring; var LastOSError: DWORD): HANDLE; function LLCLSys_GetFileAttributes(lpFileName: PUnicodeChar): DWORD; function LLCLSys_GetFileAttributesEx(lpFileName: PUnicodeChar; fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer; var LastOSError: DWORD): BOOL; function LLCLSys_CreateDirectory(lpPathName: PUnicodeChar; lpSecurityAttributes: PSecurityAttributes): BOOL; @@ -896,7 +1040,7 @@ function LLCLSys_GetFileVersionInfo(lptstrFilename: PUnicodeChar; dwHandle, dwL function LLCLSys_VerQueryValue(pBlock: Pointer; lpSubBlock: PUnicodeChar; var lplpBuffer: Pointer; var puLen: UINT): BOOL; function LLCLSys_LoadLibrary(lpLibFileName: PUnicodeChar): HMODULE; // (string instead of unicodestring) -function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; function LLCLSys_CharUpperBuff(const sText: string): string; function LLCLSys_CharLowerBuff(const sText: string): string; {$ENDIF} @@ -906,6 +1050,7 @@ function LLCL_UnlockResource(hResData: THandle): BOOL; stdcall; // Specific functions, and functions that cannot be directly mapped procedure LLCLS_GetOSVersionA(var aPlatform, aMajorVersion, aMinorVersion, aBuildNumber: integer; var aCSDVersion: string); +procedure LLCLS_FreeMemAndNil(var ptr); procedure LLCLS_Init(aPlatForm: integer); function LLCLS_InitCommonControl(CC: integer): BOOL; function LLCLS_GetModuleFileName(hModule: HINST): string; @@ -914,23 +1059,44 @@ function LLCLS_GetNonClientMetrics(var NonClientMetrics: TCustomNonClientMetric function LLCLS_CreateFontIndirect(const lpLogFont: TCustomLogFont; const sName: string): HFONT; function LLCLS_SendMessageSetText(hWnd: HWND; Msg: Cardinal; const sText: string): LRESULT; function LLCLS_SendMessageGetText(hWnd: HWND): string; -function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; function LLCLS_CharUpperBuff(const sText: string): string; function LLCLS_CharLowerBuff(const sText: string): string; function LLCLS_Shell_NotifyIcon(dwMessage: DWORD; lpData: PCustomNotifyIconData; UseExtStruct: boolean; const sTip: string): BOOL; function LLCLS_Shell_NotifyIconBalloon(dwMessage: DWORD; lpData: PCustomNotifyIconData; UseExtStruct: boolean; InfoFlags: DWORD; const Timeout: UINT; const sInfoTitle: string; const sInfo: string): BOOL; function LLCLS_GetOpenSaveFileName(var OpenFile: TOpenFilename; OpenSave: integer; var OpenStrParam: TOpenStrParam): BOOL; -function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; +function LLCLS_FindFirstNextFile(const sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; function LLCLS_GetCurrentDirectory(): string; function LLCLS_GetFullPathName(const sFileName: string): string; function LLCLS_GetDiskSpace(const sDrive: string; var TotalSpace, FreeSpaceAvailable: int64): BOOL; function LLCLS_FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD; Arguments: Pointer): string; function LLCLS_StringToOem(const sText: string): ansistring; function LLCLS_GetTextSize(hWnd: HWND; const sText: string; FontHandle: THandle; var Size: TSize): BOOL; +function LLCLS_KeysToShiftState(Keys: Word): LLCL_TShiftState; +function LLCLS_KeyDataToShiftState(KeyData: integer): LLCL_TShiftState; function LLCLS_IsAccel(VK: word; const Str: string): BOOL; function LLCLS_CharCodeToChar(const CharCode: word): Char; +function LLCLS_GetTextAPtr(lpText: LPCSTR): string; +function LLCLS_GetTextWPtr(lpText: LPCWSTR): string; function LLCLS_FormUTF8ToString(const S: utf8string): string; function LLCLS_FormStringToString(const S: ansistring): string; +procedure LLCLS_LV_SetColumnWithTitleText(MsgType: Cardinal; hWnd: HWND; iCol: integer; const lvc: LV_COLUMN; const S: string); +function LLCLS_LV_GetColumnTitleText(hWnd: HWND; iCol: integer): string; +procedure LLCLS_LV_SetItemWithText(MsgType: Cardinal; hWnd: HWND; const lvi: LV_ITEM; const S: string); +function LLCLS_LV_GetItemText(hWnd: HWND; iItem: integer; iSubItem: integer): string; +function LLCLS_LV_ImageList_Create(cx: integer; cy: integer; flags: cardinal; cInitial: integer; cGrow: integer): HIMAGELIST; +function LLCLS_LV_ImageList_Destroy(himl: HIMAGELIST): BOOL; +function LLCLS_SH_BrowseForFolder(const BrowseInfo: TBrowseInfo; const sTitle: string; const sRoot: string; var sDirName: string): BOOl; +function LLCLS_INI_ReadString(const FileName, Section, Ident, Default: string): string; +procedure LLCLS_INI_WriteString(const FileName, Section, Ident, Value: string); +procedure LLCLS_INI_Delete(const FileName: string; Section, Ident: PChar); +function LLCLS_CLPB_GetTextFormat(): cardinal; +function LLCLS_CLPB_SetTextPtr(const sText: string; var iLen: cardinal): Pointer; +function LLCLS_CLPB_GetText(lpText: Pointer): string; +{$IFDEF LLCL_OPT_IMGTRANSPARENT} +function LLCLS_CheckAlphaBlend(): boolean; +function LLCLS_AlphaBlend(hdcDest: HDC; xoriginDest, yoriginDest, wDest, hDest: integer; hdcSrc: HDC; xoriginSrc, yoriginSrc, wSrc, hSrc: integer; ftn: BLENDFUNCTION): BOOL; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} {$IFDEF FPC} {$IFDEF UNICODE} @@ -938,11 +1104,15 @@ function LLCLS_UTF8ToSys(const S: utf8string): ansistring; function LLCLS_SysToUTF8(const S: ansistring): utf8string; function LLCLS_UTF8ToWinCP(const S: utf8string): ansistring; function LLCLS_WinCPToUTF8(const S: ansistring): utf8string; +function LLCLS_UTF8LowerCase(const S: utf8string): utf8string; +function LLCLS_UTF8UpperCase(const S: utf8string): utf8string; {$ELSE UNICODE} function LLCLS_UTF8ToSys(const S: string): string; function LLCLS_SysToUTF8(const S: string): string; function LLCLS_UTF8ToWinCP(const S: string): string; function LLCLS_WinCPToUTF8(const S: string): string; +function LLCLS_UTF8LowerCase(const S: string): string; +function LLCLS_UTF8UpperCase(const S: string): string; {$ENDIF UNICODE} {$ENDIF} @@ -964,6 +1134,9 @@ function LLCLS_FFNF_W(lpFileName: PChar; hFindFile: HANDLE; var lpFindFileData: function LLCLS_FFNF_A(lpFileName: PChar; hFindFile: HANDLE; var lpFindFileData: TWin32FindDataA; var OutFileName: string; var ResFunc: HANDLE; var LastOSError: DWORD): boolean; forward; procedure LLCLS_FFNF_AToW(const aWin32FindData: TWin32FindDataA; var wWin32FindData: TWin32FindDataW); forward; procedure LLCLS_FFNF_WToA(const wWin32FindData: TWin32FindDataW; var aWin32FindData: TWin32FindDataA); forward; +{$IFDEF LLCL_FPC_ANSISYS} +function LLCLS_FFNF_AA(lpFileName: PChar; hFindFile: HANDLE; var lpFindFileData: TWin32FindDataA; var OutFileName: string; var ResFunc: HANDLE; var LastOSError: DWORD): boolean; forward; +{$ENDIF} {$IFDEF LLCL_FPC_UNISYS} function LLCLS_FFNF_WW(lpFileName: PUnicodeChar; hFindFile: HANDLE; var lpFindFileData: TWin32FindDataW; var OutFileName: unicodestring; var ResFunc: HANDLE; var LastOSError: DWORD): boolean; forward; {$ENDIF} @@ -978,11 +1151,21 @@ procedure StrLCopyW(var Dest: array of WideChar; const Source: unicodestring; Ma function ValAccelStr(const Str: string): word; forward; +function LLCLS_SH_BrowseForFolder_CB(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): longint; stdcall; forward; +function LLCLS_INI_ForceAnsi(const S: string; Convert: boolean): ansistring; forward; + {$IFDEF LLCL_FPC_UTF8RTL} // (FPC only) procedure CallInit(); forward; var InitDone: boolean = false; -{$ENDIF} +{$ENDIF LLCL_FPC_UTF8RTL} + +{$IFDEF LLCL_OPT_IMGTRANSPARENT} +var HasAlphaBlend: integer = 0; +var PAddrAlphaBlend: function(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest, + nHeightDest: Integer; hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, + nHeightSrc: Integer; blendFunction: BLENDFUNCTION): BOOL; stdcall; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} //------------------------------------------------------------------------------ @@ -1005,9 +1188,9 @@ function LLCL_GetModuleHandle(lpModuleName: PChar): HMODULE; {$IFDEF LLCL_UNICODE_API_W_ONLY} result := 0; {$ELSE} - begin - aStr := StrToTextDispA(lpModuleName); - result := GetModuleHandleA(@aStr[1]); + begin + aStr := StrToTextDispA(lpModuleName); + result := GetModuleHandleA(@aStr[1]); end; {$ENDIF} end; @@ -1173,17 +1356,17 @@ function LLCL_SendMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPA {$ENDIF} end; -function LLCL_PostMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): LRESULT; +function LLCL_PostMessage(hWnd: HWND; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM): BOOL; begin {$IFDEF LLCL_UNICODE_API_W} if UnicodeEnabledOS then - result := longint(PostMessageW(hWnd, Msg, WParam, LParam)) + result := PostMessageW(hWnd, Msg, WParam, LParam) else {$ENDIF} {$IFDEF LLCL_UNICODE_API_W_ONLY} - result := 0; + result := false; {$ELSE} - result := longint(PostMessageA(hWnd, Msg, WParam, LParam)); + result := PostMessageA(hWnd, Msg, WParam, LParam); {$ENDIF} end; @@ -2123,7 +2306,7 @@ function LLCL_LoadResource(hModule: HINST; hResInfo: HRSRC): HGLOBAL; stdcall; result := LoadResource(hModule, hResInfo); end; -function LLCL_LockResource(hResData: HGLOBAL): pointer; stdcall; +function LLCL_LockResource(hResData: HGLOBAL): Pointer; stdcall; begin result := LockResource(hResData); end; @@ -2133,6 +2316,31 @@ function LLCL_FreeResource(hResData: HGLOBAL): BOOL; stdcall; result := FreeResource(hResData); end; +function LLCL_FreeLibrary(hModule: HMODULE): BOOL; stdcall; +begin + result := FreeLibrary(hModule); +end; + +function LLCL_GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; stdcall; +begin + result := GlobalAlloc(uFlags, dwBytes); +end; + +function LLCL_GlobalLock(hMem: HGLOBAL): Pointer; stdcall; +begin + result := GlobalLock(hMem); +end; + +function LLCL_GlobalUnlock(hMem: HGLOBAL): BOOL; stdcall; +begin + result := GlobalUnlock(hMem); +end; + +function LLCL_GlobalFree(hMem: HGLOBAL): HGLOBAL; stdcall; +begin + result := GlobalFree(hMem); +end; + function LLCL_TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; begin result := TranslateMessage(lpMsg); @@ -2373,6 +2581,36 @@ function LLCL_MessageBeep(uType: UINT): BOOL; stdcall; result := MessageBeep(uType); end; +function LLCL_OpenClipboard(hWndNewOwner: HWND): BOOL; stdcall; +begin + result := OpenClipboard(hWndNewOwner); +end; + +function LLCL_EmptyClipboard(): BOOL; stdcall; +begin + result := EmptyClipboard(); +end; + +function LLCL_GetClipboardData(uFormat: UINT): HANDLE; stdcall; +begin + result := GetClipboardData(uFormat); +end; + +function LLCL_SetClipboardData(uFormat: UINT; hMem: HANDLE): HANDLE; stdcall; +begin + result := SetClipboardData(uFormat, hMem); +end; + +function LLCL_IsClipboardFormatAvailable(uFormat: UINT): BOOL; stdcall; +begin + result := IsClipboardFormatAvailable(uFormat); +end; + +function LLCL_CloseClipboard(): BOOL; stdcall; +begin + result := CloseClipboard(); +end; + function LLCL_SetBkMode(DC: HDC; BkMode: Integer): Integer; stdcall; begin result := SetBkMode(DC, BkMode); @@ -2448,6 +2686,31 @@ function LLCL_SetDIBitsToDevice(DC: HDC; DestX, DestY: Integer; Width, Height: D result := SetDIBitsToDevice(DC, DestX, DestY, Width, Height, SrcX, SrcY, nStartScan, NumScans, Bits, BitsInfo, Usage); end; +function LLCL_BitBlt(hdcDest: HDC; nXDest, nYDest, nWidth, nHeight: Integer; hdcSrc: HDC; nXSrc, nYSrc: Integer; dwRop: DWORD): BOOL; stdcall; +begin + result := BitBlt(hdcDest, nXDest, nYDest, nWidth, nHeight, hdcSrc, nXSrc, nYSrc, dwRop); +end; + +function LLCL_CreateCompatibleDC(hDC: HDC): HDC; stdcall; +begin + result := CreateCompatibleDC(hDC); +end; + +function LLCL_DeleteDC(hDC: HDC): BOOL; stdcall; +begin + result := DeleteDC(hDC); +end; + +function LLCL_CreateDIBitmap(hDc: HDC; lpbmih: PBITMAPINFOHEADER; fdwInit: DWORD; lpbInit: pByte; lpbmi: PBITMAPINFO; fuUsage: UINT): HBITMAP; stdcall; +begin + result := CreateDIBitmap(hDc, lpbmih, fdwInit, lpbInit, lpbmi, fuUsage); +end; + +function LLCL_CreateCompatibleBitmap(hDC: HDC; nWidth, nHeight: Integer): HBITMAP; stdcall; +begin + result := CreateCompatibleBitmap(hDC, nWidth, nHeight); +end; + procedure LLCL_InitCommonControls(); stdcall; begin InitCommonControls(); @@ -2469,13 +2732,39 @@ function LLCLSys_CreateFile(lpFileName: PChar; dwDesiredAccess, dwShareMode: DWO LastOSError := LLCL_GetLastError(); end; -function LLCLSys_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; +function LLCLSys_FindFirstNextFile(const sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; // Always TWin32FindData = TWin32FindDataA (no LLCL_EXTWIN_WIDESTRUCT defined) begin - // (Can use same Ansi function as for LLCLS_FindFirstNextFile) - if not LLCLS_FFNF_A(@sFileName[1], hFindFile, lpFindFileData, OutFileName, result, LastOSError) then + // (Can't use same Ansi function as for LLCLS_FindFirstNextFile) + if not LLCLS_FFNF_AA(@sFileName[1], hFindFile, lpFindFileData, OutFileName, result, LastOSError) then exit; end; +// +function LLCLS_FFNF_AA(lpFileName: PChar; hFindFile: HANDLE; var lpFindFileData: TWin32FindDataA; var OutFileName: string; var ResFunc: HANDLE; var LastOSError: DWORD): boolean; +begin + result := false; + LastOSError := 0; + if hFindFile=0 then + begin + ResFunc := FindFirstFileA(lpFileName, lpFindFileData); + if ResFunc=INVALID_HANDLE_VALUE then + begin + LastOSError := LLCL_GetLastError(); + exit; + end; + end + else + begin + ResFunc := HANDLE(FindNextFileA(hFindFile, lpFindFileData)); // (False=0) + if ResFunc=HANDLE(false) then + begin + LastOSError := LLCL_GetLastError(); + exit; + end; + end; + OutFileName := string(lpFindFileData.cFileName); + result := true; +end; function LLCLSys_GetFileAttributes(lpFileName: PChar): DWORD; begin @@ -2580,9 +2869,9 @@ function LLCLSys_LoadLibrary(lpLibFileName: PChar): HMODULE; result := LoadLibraryA(lpLibFileName); end; -function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; begin - result := CompareStringA(Locale, dwCmpFlags, @String1[1], cchCount1, @String2[2], cchCount2); + result := CompareStringA(Locale, dwCmpFlags, @String1[1], length(String1), @String2[1], length(String2)); end; function LLCLSys_CharUpperBuff(const sText: string): string; @@ -2614,7 +2903,7 @@ function LLCLSys_CreateFile(lpFileName: PUnicodeChar; dwDesiredAccess, dwShareMo LastOSError := LLCL_GetLastError(); end; -function LLCLSys_FindFirstNextFile(sFileName: unicodestring; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: unicodestring; var LastOSError: DWORD): HANDLE; +function LLCLSys_FindFirstNextFile(const sFileName: unicodestring; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: unicodestring; var LastOSError: DWORD): HANDLE; // Always TWin32FindData = TWin32FindDataW (LLCL_EXTWIN_WIDESTRUCT defined) begin // (Can't use same Wide function as for LLCLS_FindFirstNextFile) @@ -2744,12 +3033,12 @@ function LLCLSys_LoadLibrary(lpLibFileName: PUnicodeChar): HMODULE; result := LoadLibraryW(lpLibFileName); end; -function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLSys_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; var sString1, sString2: unicodestring; begin sString1 := unicodestring(String1); sString2 := unicodestring(String2); - result := CompareStringW(Locale, dwCmpFlags, @sString1[1], cchCount1, @sString2[1], cchCount2); + result := CompareStringW(Locale, dwCmpFlags, @sString1[1], length(sString1), @sString2[1], length(sString2)); end; function LLCLSys_CharUpperBuff(const sText: string): string; @@ -2789,6 +3078,16 @@ function LLCL_UnlockResource(hResData: THandle): BOOL; stdcall; // Specific functions // +// Free memory and nil its pointer +procedure LLCLS_FreeMemAndNil(var ptr); +var tmp: Pointer; +begin + tmp := Pointer(ptr); + Pointer(ptr) := nil; + if Assigned(tmp) then + FreeMem(tmp); +end; + // Exceptionally, only Ansi version here procedure LLCLS_GetOSVersionA(var aPlatform, aMajorVersion, aMinorVersion, aBuildNumber: integer; var aCSDVersion: string); var OSVersion: TOSVersionInfoA; @@ -2829,7 +3128,7 @@ procedure LLCLS_Init(aPlatForm: integer); // Initialization for Common Controls function LLCLS_InitCommonControl(CC: integer): BOOL; -var PAddrInitCommonControlsEx: function(var ICC: TInitCommonControlsEx): longbool stdcall; +var PAddrInitCommonControlsEx: function(var ICC: TInitCommonControlsEx): longbool; stdcall; var ICC: TInitCommonControlsEx; begin LLCL_InitCommonControls(); @@ -2869,7 +3168,7 @@ function LLCLS_GetModuleFileName(hModule: HINST): string; {$IFDEF LLCL_UNICODE_API_W_ONLY} ; // (result='' already set) {$ELSE} - begin + begin icount := GetModuleFileNameA(hModule, @aBuffer, Length(aBuffer)-1); if icount>0 then begin @@ -3008,7 +3307,7 @@ function LLCLS_SendMessageGetText(hWnd: HWND): string; else {$ENDIF} {$IFDEF LLCL_UNICODE_API_W_ONLY} - result := ''; + result := ''; {$ELSE} begin SetLength(aStr, ilen); @@ -3019,7 +3318,7 @@ function LLCLS_SendMessageGetText(hWnd: HWND): string; end; end; -function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; cchCount1: Integer; String2: string; cchCount2: Integer): Integer; +function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; const String1: string; const String2: string): Integer; {$IFDEF LLCL_UNICODE_API_W} var wString1, wString2: unicodestring; {$ENDIF} @@ -3032,7 +3331,7 @@ function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; c begin wString1 := StrToTextDispW(String1); wString2 := StrToTextDispW(String2); - result := CompareStringW(Locale, dwCmpFlags, @wString1[1], cchCount1, @wString2[1], cchCount2); + result := CompareStringW(Locale, dwCmpFlags, @wString1[1], length(wString1), @wString2[1], length(wString2)); end else {$ENDIF} @@ -3042,7 +3341,7 @@ function LLCLS_CompareString(Locale: LCID; dwCmpFlags: DWORD; String1: string; c begin aString1 := StrToTextDispA(String1); aString2 := StrToTextDispA(String2); - result := CompareStringA(Locale, dwCmpFlags, @aString1[1], cchCount1, @aString2[1], cchCount2); + result := CompareStringA(Locale, dwCmpFlags, @aString1[1], length(aString1), @aString2[1], length(aString2)); end; {$ENDIF} end; @@ -3254,19 +3553,17 @@ function LLCLS_GetOpenSaveFileName(var OpenFile: TOpenFilename; OpenSave: intege pw1 := pwFileNameBuffer; pw2 := pwFileNameBuffer; while pw1<=pwFileNameBuffer+(((MULTI_MAXLEN+1)*2)-(2*2)) do - begin - if pw2^=WideChar(0) then - begin - wFileName := unicodestring(pw1); - OpenStrParam.sFileName := OpenStrParam.sFileName+StrFromTextDispW(wFileName)+'|'; - Inc(OpenStrParam.NbrFileNames); - Inc(pw2); - if (pw2^=WideChar(0)) or ((wOpenFile.Flags and OFN_ALLOWMULTISELECT)=0) then break; - pw1 := pw2; - end - else + if pw2^=WideChar(0) then + begin + wFileName := unicodestring(pw1); + OpenStrParam.sFileName := OpenStrParam.sFileName+StrFromTextDispW(wFileName)+'|'; + Inc(OpenStrParam.NbrFileNames); Inc(pw2); - end; + if (pw2^=WideChar(0)) or ((wOpenFile.Flags and OFN_ALLOWMULTISELECT)=0) then break; + pw1 := pw2; + end + else + Inc(pw2); end; FreeMem(pwFileNameBuffer); end @@ -3301,26 +3598,24 @@ function LLCLS_GetOpenSaveFileName(var OpenFile: TOpenFilename; OpenSave: intege pa1 := paFileNameBuffer; pa2 := paFileNameBuffer; while pa1<=paFileNameBuffer+((MULTI_MAXLEN+1)-2) do - begin - if pa2^=AnsiChar(0) then - begin - aFileName := ansistring(pa1); - OpenStrParam.sFileName := OpenStrParam.sFileName+StrFromTextDispA(aFileName)+'|'; - Inc(OpenStrParam.NbrFileNames); - Inc(pa2); - if (pa2^=AnsiChar(0)) or ((aOpenFile.Flags and OFN_ALLOWMULTISELECT)=0) then break; - pa1 := pa2; - end - else + if pa2^=AnsiChar(0) then + begin + aFileName := ansistring(pa1); + OpenStrParam.sFileName := OpenStrParam.sFileName+StrFromTextDispA(aFileName)+'|'; + Inc(OpenStrParam.NbrFileNames); Inc(pa2); - end; + if (pa2^=AnsiChar(0)) or ((aOpenFile.Flags and OFN_ALLOWMULTISELECT)=0) then break; + pa1 := pa2; + end + else + Inc(pa2); end; FreeMem(paFileNameBuffer); end; {$ENDIF} end; -function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; +function LLCLS_FindFirstNextFile(const sFileName: string; hFindFile: HANDLE; var lpFindFileData: TCustomWin32FindData; var OutFileName: string; var LastOSError: DWORD): HANDLE; {$ifndef LLCL_EXTWIN_WIDESTRUCT} // TWin32FindData = TWin32FindDataA {$IFDEF LLCL_UNICODE_API_W} var wWin32FindData: TWin32FindDataW; @@ -3330,7 +3625,7 @@ function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFin if UnicodeEnabledOS then begin if not LLCLS_FFNF_W(@sFileName[1], hFindFile, wWin32FindData, OutFileName, result, LastOSError) then - exit; + exit; LLCLS_FFNF_WToA(wWin32FindData, lpFindFileData); {$IFDEF LLCL_UNICODE_STR_UTF8} StrLCopyA(lpFindFileData.cFileName, OutFileName, Length(lpFindFileData.cFileName)); // Saves UTF8 string as Ansi string @@ -3349,7 +3644,7 @@ function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFin {$ELSE} begin if not LLCLS_FFNF_A(@sFileName[1], hFindFile, lpFindFileData, OutFileName, result, LastOSError) then - exit; + exit; end; {$ENDIF} end; @@ -3362,7 +3657,7 @@ function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFin if UnicodeEnabledOS then begin if not LLCLS_FFNF_W(@sFileName[1], hFindFile, lpFindFileData, OutFileName, result, LastOSError) then - exit; + exit; end else {$ENDIF} @@ -3377,7 +3672,7 @@ function LLCLS_FindFirstNextFile(sFileName: string; hFindFile: HANDLE; var lpFin {$ELSE} begin if not LLCLS_FFNF_A(@sFileName[1], hFindFile, aWin32FindData, OutFileName, result, LastOSError) then - exit; + exit; LLCLS_FFNF_AToW(aWin32FindData, lpFindFileData); end; {$ENDIF} @@ -3473,11 +3768,9 @@ procedure LLCLS_FFNF_WToA(const wWin32FindData: TWin32FindDataW; var aWin32FindD function LLCLS_GetCurrentDirectory(): string; {$IFDEF LLCL_UNICODE_API_W} var wBuffer: array[0..MAX_PATH+1] of WideChar; // (Including terminating null character, plus one) -var wDirectory: unicodestring; {$ENDIF} {$IFNDEF LLCL_UNICODE_API_W_ONLY} var aBuffer: array[0..MAX_PATH+1] of AnsiChar; // (Including terminating null character, plus one) -var aDirectory: ansistring; {$ENDIF} var icount: integer; begin @@ -3489,8 +3782,7 @@ function LLCLS_GetCurrentDirectory(): string; if icount>0 then begin wBuffer[icount] := WideChar(0); // (may be absent) - wDirectory := unicodestring(wBuffer); - result := StrFromTextDispW(wDirectory); + result := StrFromTextDispW(wBuffer); end; end else @@ -3503,8 +3795,7 @@ function LLCLS_GetCurrentDirectory(): string; if icount>0 then begin aBuffer[icount] := AnsiChar(0); // (may be absent) - aDirectory := ansistring(aBuffer); - result := StrFromTextDispA(aDirectory); + result := StrFromTextDispA(aBuffer); end; end; {$ENDIF} @@ -3532,8 +3823,7 @@ function LLCLS_GetFullPathName(const sFileName: string): string; if icount>0 then begin wBuffer[icount] := WideChar(0); // (may be absent) - wName := unicodestring(wBuffer); - result := StrFromTextDispW(wName); + result := StrFromTextDispW(wBuffer); end; end else @@ -3547,8 +3837,7 @@ function LLCLS_GetFullPathName(const sFileName: string): string; if icount>0 then begin aBuffer[icount] := AnsiChar(0); // (may be absent) - aName := ansistring(aBuffer); - result := StrFromTextDispA(aName); + result := StrFromTextDispA(aBuffer); end; end; {$ENDIF} @@ -3633,7 +3922,7 @@ function LLCLS_FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWO {$IFDEF LLCL_UNICODE_API_W_ONLY} ; // (result='' already set) {$ELSE} - begin + begin icount := FormatMessageA(dwFlags, lpSource, dwMessageId, dwLanguageId, @aBuffer, Length(aBuffer)-1, Arguments); if icount>0 then begin @@ -3679,7 +3968,6 @@ function LLCLS_StringToOem(const sText: string): ansistring; {$ifend} end; - function LLCLS_GetTextSize(hWnd: HWND; const sText: string; FontHandle: THandle; var Size: TSize): BOOL; {$IFDEF LLCL_UNICODE_API_W} var wStr: unicodestring; @@ -3701,19 +3989,37 @@ function LLCLS_GetTextSize(hWnd: HWND; const sText: string; FontHandle: THandle; else {$ENDIF} {$IFDEF LLCL_UNICODE_API_W_ONLY} - begin - result := false; - if CurFontHandle<>0 then // (result=false already set - result := false; // tricky instructions to avoid note) - end; + result := false; {$ELSE} begin aStr := StrToTextDispA(sText); result := GetTextExtentPoint32A(ADC, @aStr[1], Length(aStr), Size); end; - SelectObject(ADC, CurFontHandle); - ReleaseDC(hWnd, ADC); {$ENDIF} + if CurFontHandle<>0 then + SelectObject(ADC, CurFontHandle); + ReleaseDC(hWnd, ADC); +end; + +function LLCLS_KeysToShiftState(Keys: Word): LLCL_TShiftState; +begin + result := []; + if Keys and MK_SHIFT<>0 then Include(result, ssShift); + if Keys and MK_CONTROL<>0 then Include(result, ssCtrl); + if Keys and MK_LBUTTON<>0 then Include(result, ssLeft); + if Keys and MK_RBUTTON<>0 then Include(result, ssRight); + if Keys and MK_MBUTTON<>0 then Include(result, ssMiddle); + if LLCL_GetKeyState(VK_MENU) < 0 then Include(result, ssAlt); +end; + +function LLCLS_KeyDataToShiftState(KeyData: integer): LLCL_TShiftState; +const + AltMask = $20000000; +begin + result := []; + if LLCL_GetKeyState(VK_SHIFT)<0 then Include(result, ssShift); + if LLCL_GetKeyState(VK_CONTROL)<0 then Include(result, ssCtrl); + if KeyData and AltMask<>0 then Include(result, ssAlt); end; function LLCLS_IsAccel(VK: word; const Str: string): BOOL; @@ -3774,6 +4080,20 @@ function LLCLS_CharCodeToChar(const CharCode: word): Char; result := Char(CharCode); end; +function LLCLS_GetTextAPtr(lpText: LPCSTR): string; +var aStr: ansistring; +begin + aStr := ansistring(lpText); + result := StrFromTextDispA(aStr); +end; + +function LLCLS_GetTextWPtr(lpText: LPCWSTR): string; +var wStr: unicodestring; +begin + wStr := widestring(lpText); + result := StrFromTextDispW(wStr); +end; + function LLCLS_FormUTF8ToString(const S: utf8string): string; begin {$IFDEF LLCL_UNICODE_STR_UTF8} @@ -3792,10 +4112,492 @@ function LLCLS_FormStringToString(const S: ansistring): string; {$ELSE} {$IFDEF LLCL_UNICODE_STR_UTF16} result := UTF8Decode(S); {$ELSE} + {$IFDEF FPC} + result := UTF8ToAnsi(S); // Specific Ansi only mode + {$ELSE FPC} result := S; + {$ENDIF FPC} {$ENDIF} {$ENDIF} end; +procedure LLCLS_LV_SetColumnWithTitleText(MsgType: Cardinal; hWnd: HWND; iCol: integer; const lvc: LV_COLUMN; const S: string); +{$IFDEF LLCL_UNICODE_API_W} +var wStr: unicodestring; +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aStr: ansistring; +{$ENDIF} +var Msg: cardinal; +var Tmplvc: LV_COLUMN; +begin + Move(lvc, Tmplvc, SizeOf(Tmplvc)); // Same size +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + case MsgType of + 1: Msg := LVM_INSERTCOLUMNW; + else Msg := LVM_SETCOLUMNW; + end; + wStr := StrToTextDispW(S); + Tmplvc.pszText := @wStr[1]; + SendMessageW(hWnd, Msg, iCol, LPARAM(@Tmplvc)); + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; +{$ELSE} + begin + case MsgType of + 1: Msg := LVM_INSERTCOLUMNA; + else Msg := LVM_SETCOLUMNA; + end; + aStr := StrToTextDispA(S); + Tmplvc.pszText := @aStr[1]; + SendMessageA(hWnd, Msg, iCol, LPARAM(@Tmplvc)); + end; +{$ENDIF} +end; + +function LLCLS_LV_GetColumnTitleText(hWnd: HWND; iCol: integer): string; +{$IFDEF LLCL_UNICODE_API_W} +var wBuffer: array[0..LLCLC_LISTVIEW_MAXCHAR] of WideChar; // (Including terminating null character) +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aBuffer: array[0..LLCLC_LISTVIEW_MAXCHAR] of AnsiChar; // (Including terminating null character) +{$ENDIF} +var lvc: LV_COLUMN; +begin + result := ''; + FillChar(lvc, SizeOf(lvc), 0); + lvc.mask := LVCF_TEXT; + lvc.cchTextMax := LLCLC_LISTVIEW_MAXCHAR; +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + lvc.pszText := @wBuffer; + if Boolean(SendMessageW(hWnd, LVM_GETCOLUMNW, iCol, LPARAM(@lvc))) then + begin + wBuffer[LLCLC_LISTVIEW_MAXCHAR] := WideChar(0); + result := StrFromTextDispW(wBuffer); + end; + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; // (result='' already set) +{$ELSE} + begin + lvc.pszText := @aBuffer; + if Boolean(SendMessageA(hWnd, LVM_GETCOLUMNA, iCol, LPARAM(@lvc))) then + begin + aBuffer[LLCLC_LISTVIEW_MAXCHAR] := AnsiChar(0); + result := StrFromTextDispA(aBuffer); + end; + end; +{$ENDIF} +end; + +function LLCLS_LV_GetItemText(hWnd: HWND; iItem: integer; iSubItem: integer): string; +{$IFDEF LLCL_UNICODE_API_W} +var wBuffer: array[0..LLCLC_LISTVIEW_MAXCHAR] of WideChar; // (Including terminating null character) +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aBuffer: array[0..LLCLC_LISTVIEW_MAXCHAR] of AnsiChar; // (Including terminating null character) +{$ENDIF} +var lvi: LV_ITEM; +begin + result := ''; + FillChar(lvi, SizeOf(lvi), 0); + lvi.mask := LVIF_TEXT; + lvi.iItem := iItem; + lvi.iSubItem := iSubItem; + lvi.cchTextMax := LLCLC_LISTVIEW_MAXCHAR; +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + lvi.pszText := @wBuffer; + if Boolean(SendMessageW(hWnd, LVM_GETITEMW, 0, LPARAM(@lvi))) then + begin + wBuffer[LLCLC_LISTVIEW_MAXCHAR] := WideChar(0); + result := StrFromTextDispW(wBuffer); + end; + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; // (result='' already set) +{$ELSE} + begin + lvi.pszText := @aBuffer; + if Boolean(SendMessageA(hWnd, LVM_GETITEMA, 0, LPARAM(@lvi))) then + begin + aBuffer[LLCLC_LISTVIEW_MAXCHAR] := AnsiChar(0); + result := StrFromTextDispA(aBuffer); + end; + end; +{$ENDIF} +end; + +procedure LLCLS_LV_SetItemWithText(MsgType: Cardinal; hWnd: HWND; const lvi: LV_ITEM; const S: string); +{$IFDEF LLCL_UNICODE_API_W} +var wStr: unicodestring; +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aStr: ansistring; +{$ENDIF} +var Msg: cardinal; +var Tmplvi: LV_ITEM; +begin + Move(lvi, Tmplvi, SizeOf(Tmplvi)); // Same size +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + case MsgType of + 1: Msg := LVM_INSERTITEMW; + else Msg := LVM_SETITEMW; + end; + wStr := StrToTextDispW(S); + Tmplvi.pszText := @wStr[1]; + SendMessageW(hWnd, Msg, 0, LPARAM(@Tmplvi)); + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; +{$ELSE} + begin + case MsgType of + 1: Msg := LVM_INSERTITEMA; + else Msg := LVM_SETITEMA; + end; + aStr := StrToTextDispA(S); + Tmplvi.pszText := @aStr[1]; + SendMessageA(hWnd, Msg, 0, LPARAM(@Tmplvi)); + end; +{$ENDIF} +end; + +function LLCLS_LV_ImageList_Create(cx: integer; cy: integer; flags: cardinal; cInitial: integer; cGrow: integer): HIMAGELIST; +var PAddrImageList_Create: function(cx: integer; cy: integer; flags: cardinal; cInitial: integer; cGrow: integer): HIMAGELIST; stdcall; +begin + result := 0; + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(PAddrImageList_Create){$ELSE}@PAddrImageList_Create{$ENDIF} + := LLCL_GetProcAddress(LLCL_GetModuleHandle(CCOMCTL32), 'ImageList_Create'); + if Assigned(PAddrImageList_Create) then + result := PAddrImageList_Create(cx, cy, flags, cInitial, cGrow); +end; + +function LLCLS_LV_ImageList_Destroy(himl: HIMAGELIST): BOOL; +var PAddrImageList_Destroy: function(himl: HIMAGELIST): BOOL; stdcall; +begin + result := false; + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(PAddrImageList_Destroy){$ELSE}@PAddrImageList_Destroy{$ENDIF} + := LLCL_GetProcAddress(LLCL_GetModuleHandle(CCOMCTL32), 'ImageList_Destroy'); + if Assigned(PAddrImageList_Destroy) then + result := PAddrImageList_Destroy(himl); +end; + +function LLCLS_SH_BrowseForFolder(const BrowseInfo: TBrowseInfo; const sTitle: string; const sRoot: string; var sDirName: string): BOOl; +{$IFDEF LLCL_UNICODE_API_W} +var wBuffer: array[0..MAX_PATH+1] of WideChar; // (Including terminating null character, plus one) +var wTitle, wRoot: unicodestring; +var wBrowseInfo: TBrowseInfoW; +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aBuffer: array[0..MAX_PATH+1] of AnsiChar; // (Including terminating null character, plus one) +var aTitle, aRoot: ansistring; +var aBrowseInfo: TBrowseInfoA; +{$ENDIF} +var pIIDL: PItemIDList; +begin + result := false; +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + Move(BrowseInfo, wBrowseInfo, SizeOf(wBrowseInfo)); // Same size + wTitle := StrToTextDispW(sTitle); + wBrowseInfo.lpszTitle := @wTitle[1]; + wBrowseInfo.pszDisplayName := @wBuffer; + if sRoot<>'' then + begin + wRoot := StrToTextDispW(sRoot); + wBrowseInfo.lParam := LPARAM(PointerToNativeUInt(@wRoot[1])); + end; + wBrowseInfo.lpfn := @LLCLS_SH_BrowseForFolder_CB; + pIIDL := SHBrowseForFolderW(wBrowseInfo); + if pIIDL<>nil then + begin + FillChar(wBuffer, SizeOf(wBuffer), 0); + if SHGetPathFromIDListW(pIIDL, @wBuffer) then + begin + result := true; + wBuffer[MAX_PATH+1] := WideChar(0); + sDirName := StrFromTextDispW(wBuffer); + end; + CoTaskMemFree(pIIDL); + end; + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; // (result=false already set) +{$ELSE} + begin + Move(BrowseInfo, aBrowseInfo, SizeOf(aBrowseInfo)); // Same size + aTitle := StrToTextDispA(sTitle); + aBrowseInfo.lpszTitle := @aTitle[1]; + aBrowseInfo.pszDisplayName := @aBuffer; + if sRoot<>'' then + begin + aRoot := StrToTextDispA(sRoot); + aBrowseInfo.lParam := LPARAM(PointerToNativeUInt(@aRoot[1])); + end; + aBrowseInfo.lpfn := @LLCLS_SH_BrowseForFolder_CB; + pIIDL := SHBrowseForFolderA(aBrowseInfo); + if pIIDL<>nil then + begin + FillChar(aBuffer, SizeOf(aBuffer), 0); + if SHGetPathFromIDListA(pIIDL, @aBuffer) then + begin + result := true; + aBuffer[MAX_PATH+1] := AnsiChar(0); + sDirName := StrFromTextDispA(aBuffer); + end; + CoTaskMemFree(pIIDL); + end; + end; +{$ENDIF} +end; +// Callback function for LLCLS_SH_BrowseForFolder +function LLCLS_SH_BrowseForFolder_CB(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): longint; stdcall; +{$IFDEF LLCL_UNICODE_API_W} +var wBuffer: array[0..MAX_PATH+1] of WideChar; // (Including terminating null character, plus one) +{$ENDIF} +{$IFNDEF LLCL_UNICODE_API_W_ONLY} +var aBuffer: array[0..MAX_PATH+1] of AnsiChar; // (Including terminating null character, plus one) +{$ENDIF} +var InvalidateOK: boolean; +begin + result := 0; + InvalidateOK := false; +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + case uMsg of + BFFM_INITIALIZED: + if lpData<>0 then + SendMessageW(hwnd, BFFM_SETSELECTIONW, Ord(true), lpData); + BFFM_SELCHANGED: + InvalidateOK := (not SHGetPathFromIDListW(PItemIDList(lParam), @wBuffer)); + BFFM_VALIDATEFAILEDW: + begin + InvalidateOK := true; + result := 1; + end; + end; + if InvalidateOK then + SendMessageW(hwnd, BFFM_ENABLEOK, 0, 0); + end + else +{$ENDIF} +{$IFDEF LLCL_UNICODE_API_W_ONLY} + ; +{$ELSE} + begin + case uMsg of + BFFM_INITIALIZED: + if lpData<>0 then + SendMessageA(hwnd, BFFM_SETSELECTIONA, Ord(true), lpData); + BFFM_SELCHANGED: + InvalidateOK := (not SHGetPathFromIDListA(PItemIDList(lParam), @aBuffer)); + BFFM_VALIDATEFAILEDA: + begin + InvalidateOK := true; + result := 1; + end; + end; + if InvalidateOK then + SendMessageA(hwnd, BFFM_ENABLEOK, 0, 0); + end; +{$ENDIF} +end; + +// Note: FPC uses specific code to handle Ini files (i.e. not the Windows APIs) +// Currently, strings are always rawbytestring by default, except for the +// FileName (as it depends of the SysUtils functions) +function LLCLS_INI_ReadString(const FileName, Section, Ident, Default: string): string; +{$IFDEF LLCL_UNICODE_API_W_ONLY} +var wFileName, wSection, wIdent, wDefault: unicodestring; +var wBuffer: array[0..4096] of WideChar; // (Including terminating null character) +{$ELSE} +var aFileName, aSection, aIdent, aDefault: ansistring; +var aBuffer: array[0..4096] of AnsiChar; // (Including terminating null character) +{$ENDIF} +begin + result := Default; +{$IFDEF LLCL_UNICODE_API_W_ONLY} + if UnicodeEnabledOS then + begin + wFileName := unicodestring(FileName); + wSection := unicodestring(Section); + wIdent := unicodestring(Ident); + wDefault := unicodestring(Default); + if GetPrivateProfileStringW(@wSection[1], @wIdent[1], @wDefault[1], @wBuffer, SizeOf(wBuffer), @wFileName[1])>0 then + result := string(unicodestring(wBuffer)); + end; +{$ELSE} + aFileName := LLCLS_INI_ForceAnsi(FileName, true); + aSection := LLCLS_INI_ForceAnsi(Section, false); + aIdent := LLCLS_INI_ForceAnsi(Ident, false); + aDefault := LLCLS_INI_ForceAnsi(Default, false); + if GetPrivateProfileStringA(@aSection[1], @aIdent[1], @aDefault[1], @aBuffer, SizeOf(aBuffer), @aFileName[1])>0 then + result := string(ansistring(aBuffer)); +{$ENDIF} +end; + +procedure LLCLS_INI_WriteString(const FileName, Section, Ident, Value: string); +{$IFDEF LLCL_UNICODE_API_W_ONLY} +var wFileName, wSection, wIdent, wValue: unicodestring; +{$ELSE} +var aFileName, aSection, aIdent, aValue: ansistring; +{$ENDIF} +begin +{$IFDEF LLCL_UNICODE_API_W_ONLY} + if UnicodeEnabledOS then + begin + wFileName := unicodestring(FileName); + wSection := unicodestring(Section); + wIdent := unicodestring(Ident); + wValue := unicodestring(Value); + WritePrivateProfileStringW(@wSection[1], @wIdent[1], @wValue[1], @wFileName[1]); + end; +{$ELSE} + aFileName := LLCLS_INI_ForceAnsi(FileName, true); + aSection := LLCLS_INI_ForceAnsi(Section, false); + aIdent := LLCLS_INI_ForceAnsi(Ident, false); + aValue := LLCLS_INI_ForceAnsi(Value, false); + WritePrivateProfileStringA(@aSection[1], @aIdent[1], @aValue[1], @aFileName[1]); +{$ENDIF} +end; + +procedure LLCLS_INI_Delete(const FileName: string; Section, Ident: PChar); +{$IFDEF LLCL_UNICODE_API_W_ONLY} +var wFileName, wSection, wIdent: unicodestring; +{$ELSE} +var aFileName, aSection, aIdent: ansistring; +{$ENDIF} +begin +{$IFDEF LLCL_UNICODE_API_W_ONLY} + if UnicodeEnabledOS then + begin + wFileName := unicodestring(FileName); + wSection := unicodestring(Section); + if Ident=nil then // Delete Section + WritePrivateProfileStringW(@wSection[1], nil, nil, @wFileName[1]) + else // Delete Key + begin + wIdent := unicodestring(Ident); + WritePrivateProfileStringW(@wSection[1], @wIdent[1], nil, @wFileName[1]); + end; + end; +{$ELSE} + aFileName := LLCLS_INI_ForceAnsi(FileName, true); + aSection := LLCLS_INI_ForceAnsi(Section, false); + if Ident=nil then // Delete Section + WritePrivateProfileStringA(@aSection[1], nil, nil, @aFileName[1]) + else // Delete Key + begin + aIdent := LLCLS_INI_ForceAnsi(string(Ident), false); + WritePrivateProfileStringA(@aSection[1], @aIdent[1], nil, @aFileName[1]); + end; +{$ENDIF} +end; + +function LLCLS_CLPB_GetTextFormat(): cardinal; +begin +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + result := CF_UNICODETEXT + else +{$ENDIF} + result := CF_TEXT; +end; + +// Must be coherent with LLCLS_CLPB_GetTextFormat +function LLCLS_CLPB_SetTextPtr(const sText: string; var iLen: cardinal): Pointer; +{$IFDEF LLCL_UNICODE_API_W} +var wStr: unicodestring; +{$ENDIF} +var aStr: ansistring; +begin +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + begin + wStr := StrToTextDispW(sText); + result := @wStr[1]; + iLen := (length(wStr) + 1) * 2; + end + else +{$ENDIF} + begin + aStr := StrToTextDispA(sText); + result := @aStr[1]; + iLen := length(aStr) + 1; + end; +end; + +// Must be coherent with LLCLS_CLPB_GetTextFormat +function LLCLS_CLPB_GetText(lpText: Pointer): string; +begin +{$IFDEF LLCL_UNICODE_API_W} + if UnicodeEnabledOS then + result := LLCLS_GetTextWPtr(LPCWSTR(lpText)) + else +{$ENDIF} + result := LLCLS_GetTextAPtr(LPCSTR(lpText)); +end; + +{$IFDEF LLCL_OPT_IMGTRANSPARENT} +function LLCLS_CheckAlphaBlend(): boolean; +begin + // CheckWin32Version already done + if HasAlphaBlend=0 then + begin + HasAlphaBlend := 1; + // (Uses GdiAlphaBlend in Gdi32.dll, instead of AlphaBlend + // in Msimg32.dll to avoid to load this dll) + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(PAddrAlphaBlend){$ELSE}@PAddrAlphaBlend{$ENDIF} + := LLCL_GetProcAddress(LLCL_GetModuleHandle(GDI32), 'GdiAlphaBlend'); + if Assigned(PAddrAlphaBlend) then + HasAlphaBlend := 2; + end; + result := (HasAlphaBlend=2); +end; + +function LLCLS_AlphaBlend(hdcDest: HDC; xoriginDest, yoriginDest, wDest, hDest: integer; hdcSrc: HDC; xoriginSrc, yoriginSrc, wSrc, hSrc: integer; ftn: BLENDFUNCTION): BOOL; +begin + // (PAddrAlphaBlend=nil theoretically impossible at this step) + result := PAddrAlphaBlend(hdcDest, xoriginDest, yoriginDest, wDest, hDest, hdcSrc, xoriginSrc, yoriginSrc, wSrc, hSrc, ftn); +end; +{$ENDIF LLCL_OPT_IMGTRANSPARENT} + +function LLCLS_INI_ForceAnsi(const S: string; Convert: boolean): ansistring; +begin +{$IFDEF LLCL_UNICODE_STR_UTF8} + result := S; + {$IFDEF LLCL_FPC_CPSTRING} + SetCodePage(rawbytestring(result), LLCL_GetACP(), Convert); + {$ENDIF} +{$ELSE} {$IFDEF LLCL_UNICODE_STR_UTF16} + result := ansistring(S); +{$ELSE} + result := S; +{$ENDIF} {$ENDIF} + if @result[1]=nil then + result := AnsiChar(#00); +end; + {$IFDEF FPC} // Functions specific to FPC/Lazarus (LazUTF8.pas) @@ -3805,11 +4607,11 @@ function LLCLS_UTF8ToSys(const S: utf8string): ansistring; function LLCLS_UTF8ToSys(const S: string): string; {$ENDIF UNICODE} begin -{$IFDEF LLCL_FPC_UTF8RTL} +{$if Defined(LLCL_FPC_UTF8RTL) or Defined(LLCL_UNICODE_STR_ANSI)} result := S; -{$ELSE} +{$else} result := UTF8ToAnsi(S); -{$ENDIF} +{$ifend} end; {$IFDEF UNICODE} @@ -3818,14 +4620,14 @@ function LLCLS_SysToUTF8(const S: ansistring): utf8string; function LLCLS_SysToUTF8(const S: string): string; {$ENDIF UNICODE} begin -{$IFDEF LLCL_FPC_UTF8RTL} +{$if Defined(LLCL_FPC_UTF8RTL) or Defined(LLCL_UNICODE_STR_ANSI)} result := S; -{$ELSE} +{$else} result := AnsiToUTF8(S); {$IFDEF LLCL_FPC_CPSTRING} SetCodePage(rawbytestring(result), StringCodePage(S), false); {$ENDIF} -{$ENDIF} +{$ifend} end; {$IFDEF UNICODE} @@ -3859,7 +4661,35 @@ function LLCLS_WinCPToUTF8(const S: string): string; SetCodePage(rawbytestring(result), CP_ACP, false); {$ENDIF} end; + +{$IFDEF UNICODE} +function LLCLS_UTF8LowerCase(const S: utf8string): utf8string; +{$ELSE UNICODE} +function LLCLS_UTF8LowerCase(const S: string): string; +{$ENDIF UNICODE} +begin + {$IFDEF LLCL_UNICODE_STR_UTF16} + result := utf8string(LLCLS_CharLowerBuff(unicodestring(S))); + {$ELSE} + result := LLCLS_CharLowerBuff(S); + {$ENDIF} +end; + +{$IFDEF UNICODE} +function LLCLS_UTF8UpperCase(const S: utf8string): utf8string; +{$ELSE UNICODE} +function LLCLS_UTF8UpperCase(const S: string): string; +{$ENDIF UNICODE} +begin + {$IFDEF LLCL_UNICODE_STR_UTF16} + result := utf8string(LLCLS_CharUpperBuff(unicodestring(S))); + {$ELSE} + result := LLCLS_CharUpperBuff(S); + {$ENDIF} +end; + {$ENDIF FPC} + //------------------------------------------------------------------------------ // @@ -3881,6 +4711,8 @@ function StrToTextDispA(const S: string): ansistring; {$ELSE} result := S; {$ENDIF} {$ENDIF} + if @result[1]=nil then + result := AnsiChar(#00); end; // @@ -3909,6 +4741,8 @@ function StrToTextDispW(const S: string): unicodestring; {$ELSE} result := unicodestring(S); {$ENDIF} {$ENDIF} + if @result[1]=nil then + result := UnicodeChar(#00); end; // diff --git a/sources/LLCLOptions.inc b/sources/LLCLOptions.inc index 8654acd..ca0274a 100644 --- a/sources/LLCLOptions.inc +++ b/sources/LLCLOptions.inc @@ -1,17 +1,19 @@ { - Main options: compilation directives + Main options: compilation directives - This file is a part of the Light LCL (LLCL). - - Notes: Except for the Ansi/Unicode APIs options, - - all the following options are defined by default, - - undefining them usually permits to shrink a little bit - the size of the final executable, but with the penality - of having not the concerned functionnality. + This file is a part of the Light LCL (LLCL). } //------------------------------------------------------------------------------ +{ + Section 1: options defined by default. + + Undefining them usually permits to shrink a little bit the size + of the final executable, but with the penality of having not the + concerned functionnality. +} + { LLCL_OPT_TOPFORM - Forms.pas "Top invisible" form above all forms and enhanced multi-forms support @@ -34,14 +36,23 @@ { LLCL_OPT_USEDIALOG - Dialogs.pas - OpenDialog/SaveDialog used in program + OpenDialog/SaveDialog(/SelectDirectoryDialog) classes used in program - Notes: when undefined, this permits to use the ShowMessage function - without a size penality due to the TOpenDialog/TSaveDialog classes. - This option has no effect if the Dialogs units is not used. + Notes: when undefined, this permits to use the ShowMessage and the + SelectDirectory functions without a size penality due to the Dialog classes. + This option has no effect if the Dialogs unit is not used. } {$DEFINE LLCL_OPT_USEDIALOG} +{ LLCL_OPT_USEIMAGE - ExtCtrls.pas + + Image class used in program + + Notes: when undefined, this permits to use the ExtCtrls unit (Timer and + TrayIcon controls) without a size penality due to the Image class. +} +{$DEFINE LLCL_OPT_USEIMAGE} + { LLCL_OPT_EXCEPTIONS - SysUtils.pas Support (limited) for Exceptions @@ -58,14 +69,87 @@ //------------------------------------------------------------------------------ +{ + Section 2: options not defined by default. + + Defining them permits to have the corresponding functionnality + or fix, but with the penality of having an extra size in the + final executable. +} + +{ LLCL_OPT_USESELECTDIRECTORYDIALOG - Dialogs.pas + + SelectDirectoryDialog class used in program + + Notes: when defined, this permits to use the SelectDirectoryDialog + class (use preferably the SelectDirectory function instead). + This option has no effect if the Dialogs unit is not used, + or if the LLCL_OPT_USEDIALOG option is not set. +} +{$IFDEF FPC} +//{$DEFINE LLCL_OPT_USESELECTDIRECTORYDIALOG} +{$ENDIF} + +{ LLCL_OPT_NESTEDGROUPBOXWINXPFIX - Forms.pas, Controls.pas + + Fix for the nested groupboxes issue with Windows XP + + Notes: this concerns only Windows XP (not before and not after), + and only if nested groupboxes are used (font display issue). + When set, this option also implies that UI states (accelerators + and focus rectangles) are visible when the application starts + (which is not the standard for a Windows application). +} +//{$DEFINE LLCL_OPT_NESTEDGROUPBOXWINXPFIX} + +{ LLCL_OPT_PNGSUPPORT - Graphics.pas + LLCL_OPT_PNGSIMPLIFIED - LLCLPng.pas + LLCL_OPT_IMGTRANSPARENT - Graphics.pas + LLCL_OPT_DOUBLEBUFF - Control.pas + + Extended graphical options + + Notes: + - when defined, LLCL_OPT_PNGSUPPORT permits the support of + PNG files/resources in the TBitmap class, + - LLCL_OPT_PNGSIMPLIFIED (requires LLCL_OPT_PNGSUPPORT) allows only the + basic types of PNG files/resources: truecolour 8 bits (colour type = 2), + truecolour + alpha 8 bits (colour type = 6) or indexed colour 1,4,8 bits + (colour type = 3); with no interlaced data. Furthermore, the + transparency chunk data are ignored in this case, + - when defined, LLCL_OPT_IMGTRANSPARENT permits the support of + transparent images/bitmaps (only for Windows 2000 or newer), + - when defined, LLCL_OPT_DOUBLEBUFF permits the support of the double + buffering painting method for Forms (if DoubleBuffered = true), + - for simplification, with LLCL_OPT_EXTENDGRAPHICAL all these options + are defined. However, these options are completely independent and + may be defined individually, + - except for the LLCL_OPT_DOUBLEBUFF option, these options have no + effects if the LLCL_OPT_USEIMAGE option is not defined. +} +//{$DEFINE LLCL_OPT_EXTENDGRAPHICAL} +{$IF DEFINED(LLCL_OPT_EXTENDGRAPHICAL)} + {$DEFINE LLCL_OPT_PNGSUPPORT} + //{$DEFINE LLCL_OPT_PNGSIMPLIFIED} + {$DEFINE LLCL_OPT_IMGTRANSPARENT} + {$DEFINE LLCL_OPT_DOUBLEBUFF} +{$IFEND} + +//------------------------------------------------------------------------------ + +{ + Section 3: options with various possible values +} + { LLCL_OPT_UNICODE_API_A/W/W_ONLY - LLCLOSInt.pas Windows Ansi and/or Unicode/WideString APIs to use Notes: - - LLCL_OPT_UNICODE_API_A: forces to use the Ansi APIs only - - LLCL_OPT_UNICODE_API_W: forces to use both the Ansi and the Unicode APIs + - LLCL_OPT_UNICODE_API_A: forces to use the Ansi APIs only (default for Delphi 7) + - LLCL_OPT_UNICODE_API_W: forces to use both the Ansi and the Unicode APIs (default for FPC/Lazarus) - LLCL_OPT_UNICODE_API_W_ONLY: forces to use the Unicode APIs only + By default, these options are not concerning the Windows API calls in SysUtils for Free Pascal/Lazarus (see LLCL_FPC_SYSRTL in LLCLFPCInc.inc). } @@ -73,3 +157,41 @@ //{$DEFINE LLCL_OPT_UNICODE_API_W} //{$DEFINE LLCL_OPT_UNICODE_API_W_ONLY} +{ LLCL_OPT_GRIDSOPT_1/2/LV/ALL - Grids.pas + + TStringGrid options + + Notes: + - LLCL_OPT_GRIDSOPT_1: TStringGrid compatibility Level 1 (proposed default) + . support for "DefaultRowHeight" property + . support for column sorting + - LLCL_OPT_GRIDSOPT_2: TStringGrid compatibility Level 2 + . options for LLCL_OPT_GRIDSOPT_1 + . support for cells mouse button events + . support for header (i.e. fixed row) mouse messages + . support for first column editing + - LLCL_OPT_GRIDSOPT_LV: ListView compatibility + . right-click selects also a row (like left-click) + . Ctrl+A selects all the rows + - LLCL_OPT_GRIDSOPT_ALL: all options (LLCL_OPT_GRIDSOPT_2 + LLCL_OPT_GRIDSOPT_LV) +} +{$DEFINE LLCL_OPT_GRIDSOPT_1} +//{$DEFINE LLCL_OPT_GRIDSOPT_2} +//{$DEFINE LLCL_OPT_GRIDSOPT_LV} +//{$DEFINE LLCL_OPT_GRIDSOPT_ALL} + +{ LLCL_OPT_USEZLIBDLL/USEZLIBDLLDYN/USEZLIBOBJ - LLCLZlib.pas + + Zlib options + + Notes: + - LLCL_OPT_USEZLIBDLL: use static ZLib DLL (zlib1.dll) + - LLCL_OPT_USEZLIBDLLDYN: use dynamic ZLib DLL (zlib1.dll) - requires LLCL_OPT_USEZLIBDLL + - LLCL_OPT_USEZLIBOBJ: use external (C) object files + + If no such option is defined, pure Pascal functions are used (i.e. PasZlib). +} +//{$DEFINE LLCL_OPT_USEZLIBDLL} +//{$DEFINE LLCL_OPT_USEZLIBDLLDYN} +//{$DEFINE LLCL_OPT_USEZLIBOBJ} + diff --git a/sources/LLCLPng.pas b/sources/LLCLPng.pas new file mode 100644 index 0000000..a02665d --- /dev/null +++ b/sources/LLCLPng.pas @@ -0,0 +1,892 @@ +unit LLCLPng; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * PNG to BMP conversion +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} + +{$I LLCLOptions.inc} // Options + +//------------------------------------------------------------------------------ + +interface + +uses + SysUtils; + +function PNGToBMP(pPNGData: PByteArray; PNGDataSize: cardinal; var pBMPData: PByteArray; var BMPDataSize: cardinal): boolean; + +//------------------------------------------------------------------------------ + +implementation + +uses + LLCLZlib; + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +const + PNG_IDENT: array [0..pred(8)] of byte = ($89,$50,$4E,$47,$0D,$0A,$1A,$0A); + PNG_IHDR: array [0..pred(4)] of byte = ($49,$48,$44,$52); // 'IHDR' + PNG_CHUNKS: array [0..pred(4), 0..pred(4)] of byte = ( + ($49,$44,$41,$54), // 'IDAT' + ($49,$45,$4E,$44), // 'IEND' + ($50,$4C,$54,$45), // 'PLTE' + ($74,$52,$4E,$53)); // 'tRNS' +type + TPNGInfos = record + Width: cardinal; + Height: cardinal; + BitDepth: byte; + ColourType: byte; + InterlaceMethod: byte; + BitsPerPixel: cardinal; + BytesPerPixel: cardinal; + RowSize: cardinal; + NbrPalEntries: cardinal; + Palette: array [0..pred(4*256)] of byte; + {$ifndef LLCL_OPT_PNGSIMPLIFIED} + TranspType: byte; + Transp: array [0..pred(3)] of word; + Adam7StartPos: array [0..pred(7)+1] of cardinal; // (+1 for total length) + Adam7ColsRows: array [0..pred(7), 0..1] of cardinal; + {$endif LLCL_OPT_PNGSIMPLIFIED} + end; + +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +const + ADAM7ColStart: array [0..pred(7)] of cardinal = (0, 4, 0, 2, 0, 1, 0); + ADAM7ColIncrm: array [0..pred(7)] of cardinal = (8, 8, 4, 4, 2, 2, 1); + ADAM7RowStart: array [0..pred(7)] of cardinal = (0, 0, 4, 0, 2, 0, 1); + ADAM7RowIncrm: array [0..pred(7)] of cardinal = (8, 8, 8, 4, 4, 2, 2); +{$endif LLCL_OPT_PNGSIMPLIFIED} + +function PNGtoBMP_LongArrB(const Buffer: array of byte; Offset: cardinal): cardinal; forward; +function PNGtoBMP_WordArrB(const Buffer: array of byte; Offset: cardinal): word; forward; +function PNGtoBMP_SupDiv8(Value: cardinal): cardinal; forward; +function PNGtoBMP_CheckColour(ColourType, BitDepth: byte): boolean; forward; +function PNGToBMP_BitsPerPixel(ColourType, BitDepth: byte): cardinal; forward; +function PNGToBMP_KnownChunk(pChunkIdent: PByteArray): integer; forward; +function PNGtoBMP_ReverseFilter(const PNGI: TPNGInfos; pScanLines: PByteArray; pData: PByteArray): boolean; forward; +procedure PNGtoBMP_RFOneScanLine(NumScanLine, BytesPerPixel, RowSize: cardinal; FilterType: byte; pDataCur, pDataPrev, pScanLine: PByteArray); forward; +function PNGtoBMP_PaethPredictor(a, b, c: byte): byte; forward; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +procedure PNGToBMP_Adam7Values(var PNGI: TPNGInfos); forward; +function PNGtoBMP_ReverseInterFilter(const PNGI: TPNGInfos; pScanLines: PByteArray; pData: PByteArray): boolean; forward; +function PNGtoBMP_ComplPow2(Value, Power2: cardinal): cardinal; forward; +procedure PNGtoBMP_CopyBits(pDataIn, pDataOut: pByteArray; OffBitsIn, OffBitsOut, NbrBits: cardinal); forward; +{$endif LLCL_OPT_PNGSIMPLIFIED} +function PNGtoBMP_CreateBMP(const PNGI: TPNGInfos; pData: PByteArray; var pBMPData: PByteArray; var BMPDataSize: cardinal): boolean; forward; +procedure PNGtoBMP_ArrBLongInv(var Buffer: array of byte; Offset: cardinal; Value: cardinal); forward; +procedure PNGtoBMP_ArrBWordInv(var Buffer: array of byte; Offset: cardinal; Value: word); forward; +procedure PNGtoBMP_SwapRGB(pData: PByteArray; NbrCols: cardinal; ColourType: byte); forward; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +procedure PNGtoBMP_PaletteGrey(pPalette: PByteArray; BitDepth: byte); forward; +procedure PNGtoBMP_16to8(pData: PByteArray; NbrCols: cardinal; ColourType: byte); forward; +procedure PNGtoBMP_TrueToTrueC(pDataIn: PByteArray; pDataOut: PByteArray; const PNGI: TPNGInfos); forward; +procedure PNGtoBMP_GreyToTrueC(pData: PByteArray; NbrCols: cardinal); forward; +procedure PNGtoBMP_PalToTrueC(pData: PByteArray; const PNGI: TPNGInfos); forward; +function PNGtoBMP_LongArrBInv(Const Buffer: array of Byte; Const Offset: cardinal): cardinal; forward; +procedure PNGtoBMP_Pal2To4(pData: PByteArray; RowSize: cardinal); forward; +{$endif LLCL_OPT_PNGSIMPLIFIED} + +//------------------------------------------------------------------------------ + +// Converts PNG file data to BMP file data +function PNGToBMP(pPNGData: PByteArray; PNGDataSize: cardinal; var pBMPData: PByteArray; var BMPDataSize: cardinal): boolean; +var PNGI: TPNGInfos; // PNG image infos +var PNGDataPos: cardinal; +var ChunkSize: cardinal; +var pIDATData: PByteArray; // IDAT chunks data, then PNG image data (after filtering + interlace processing) +var IDATDataSize, IDATDataPos: cardinal; +var pScanLines: PByteArray; // PNG scanlines data (after decompression) +var ScanLinesSize: cardinal; +var IsOK: boolean; +var i: cardinal; +begin + result := false; + pBMPData := nil; + BMPDataSize := 0; + FillChar(PNGI, SizeOf(PNGI), 0); + // Header analysis + if PNGDataSize<33 then exit; + if not CompareMem(@pPNGData^[0], @PNG_IDENT[0], SizeOf(PNG_IDENT)) then exit; + if not CompareMem(@pPNGData^[12], @PNG_IHDR[0], SizeOf(PNG_IHDR)) then exit; + PNGI.Width := PNGtoBMP_LongArrB(pPNGData^, 16); + PNGI.Height := PNGtoBMP_LongArrB(pPNGData^, 20); + if (PNGI.Width=0) or (PNGI.Height=0) then exit; + PNGI.BitDepth := pPNGData^[24]; + PNGI.ColourType := pPNGData^[25]; + if not PNGtoBMP_CheckColour(PNGI.ColourType, PNGI.BitDepth) then exit; + PNGI.BitsPerPixel := PNGToBMP_BitsPerPixel(PNGI.ColourType, PNGI.BitDepth); + PNGI.BytesPerPixel := PNGtoBMP_SupDiv8(PNGI.BitsPerPixel); + PNGI.RowSize := PNGtoBMP_SupDiv8(PNGI.Width * PNGI.BitsPerPixel); + PNGI.InterlaceMethod := pPNGData^[28]; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + if (pPNGData^[26]<>0) or (pPNGData^[27]<>0) or (PNGI.InterlaceMethod>1) then exit; // Compression, filter and interlace methods +{$else LLCL_OPT_PNGSIMPLIFIED} + if (pPNGData^[26]<>0) or (pPNGData^[27]<>0) or (PNGI.InterlaceMethod>0) then exit; // Compression, filter and interlace methods +{$endif LLCL_OPT_PNGSIMPLIFIED} + // Chunk CRC ignored (1): if wanted, add CRC unit in 'uses' + // clause and uncomment the next instruction + // if CRC32(0, @pPNGData^[12], 13 + 4) <> PNGtoBMP_LongArrB(pPNGData^, 12 + 13 + 4) then exit; + IDATDataSize := PNGDataSize - 33; // (enough for all chunks, so enough for IDAT chunks data only too) + GetMem(pIDATData, IDATDataSize); + IDATDataPos := 0; + // Chunks analysis + IsOK := false; + PNGDataPos := 33; + while (PNGDataPos + 12) <= PNGDataSize do + begin + ChunkSize := PNGtoBMP_LongArrB(pPNGData^, PNGDataPos); + // Chunk CRC ignored (2): if wanted, add CRC unit in 'uses' + // clause and uncomment the next instructions + // if (PNGDataPos + ChunkSize + 12 > PNGDataSize) then + // IsOk := false + // else + // isOK := (CRC32(0, @pPNGData^[PNGDataPos + 4], ChunkSize + 4) = PNGtoBMP_LongArrB(pPNGData^, PNGDataPos + ChunkSize + 8)); + // if not ISOK then break; + case PNGToBMP_KnownChunk(@pPNGData^[PNGDataPos + 4]) of + 0: // IDAT + begin + if (IDATDataPos + ChunkSize) > IDATDataSize then break; + Move(pPNGData^[PNGDataPos + 8], pIDATData^[IDATDataPos], ChunkSize); + inc(IDATDataPos, ChunkSize); + end; + 1: // IEND + begin + IsOK := true; + break; + end; + 2: // PLTE + begin + PNGI.NbrPalEntries := ChunkSize div 3; + if PNGI.NbrPalEntries>256 then break; + for i := 0 to pred(PNGI.NbrPalEntries) do + begin + // (RGB <-> BGR swap - BMP bitmap preparation) + PNGI.Palette[(i*4) ] := pPNGData^[(PNGDataPos + 8) + (i*3) + 2]; + PNGI.Palette[(i*4) + 1] := pPNGData^[(PNGDataPos + 8) + (i*3) + 1]; + PNGI.Palette[(i*4) + 2] := pPNGData^[(PNGDataPos + 8) + (i*3) ]; + // (alpha channel = 0 by defaut, for better BMP compatibility) + end; + end; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + 3: // tRNS + begin + case PNGI.ColourType of + 0: // Greyscale + begin + if ChunkSize<>2 then break; + PNGI.Transp[0] := PNGtoBMP_WordArrB(pPNGData^, PNGDataPos + 8); + PNGI.Transp[1] := PNGI.Transp[0]; + PNGI.Transp[2] := PNGI.Transp[0]; + PNGI.TranspType := 1; + end; + 2: // Truecolour + begin + if ChunkSize<>6 then break; + for i := 0 to pred(3) do + // (No RGB <-> BGR swap - not necessary) + PNGI.Transp[i] := PNGtoBMP_WordArrB(pPNGData^, (PNGDataPos + 8) + (i*2)); + PNGI.TranspType := 1; + end; + 3: // Indexed-colour (Palette) + begin + if ChunkSize>PNGI.NbrPalEntries then break; // (May have less) + for i := 0 to pred(PNGI.NbrPalEntries) do + begin + if i4 then + begin + result := false; + break; + end; + inc(curpos); + PNGtoBMP_RFOneScanLine(i, PNGI.BytesPerPixel, PNGI.RowSize, FilterType, @pData^[outpos], @pData^[outprev], @pScanLines^[curpos]); + inc(curpos, PNGI.RowSize); + outprev := outpos; + inc(outpos, PNGI.RowSize); + end; +end; +// Reverses filtering for one scanline +procedure PNGtoBMP_RFOneScanLine(NumScanLine, BytesPerPixel, RowSize: cardinal; FilterType: byte; pDataCur, pDataPrev, pScanLine: PByteArray); +var i: cardinal; +begin + Move(pScanLine^, pDataCur^, RowSize); + case FilterType of + //0: // None (already done) + 1: // Sub + begin + for i := BytesPerPixel to pred(RowSize) do + inc(pDataCur^[i], pDataCur^[ i - BytesPerPixel]); + end; + 2: // Up + begin + if NumScanLine>0 then // (First scanline already done) + for i := 0 to pred(RowSize) do + inc(pDataCur^[i], pDataPrev^[i]); + end; + 3: // Average + begin + if NumScanLine=0 then // First scanline + for i := BytesPerPixel to pred(RowSize) do + inc(pDataCur^[i], pDataCur^[i - BytesPerPixel] div 2) + else + begin + for i := 0 to pred(BytesPerPixel) do + inc(pDataCur^[i], pDataPrev^[i] div 2); + for i := BytesPerPixel to pred(RowSize) do + inc(pDataCur^[i], (pDataCur^[i - BytesPerPixel] + pDataPrev^[i]) div 2); + end; + end; + 4: // Paeth + begin + if NumScanLine=0 then // First scanline + for i := BytesPerPixel to pred(RowSize) do + inc(pDataCur^[i], PNGtoBMP_PaethPredictor(pDataCur^[i - BytesPerPixel], 0, 0)) + else + begin + for i := 0 to pred(BytesPerPixel) do + inc(pDataCur^[i], PNGtoBMP_PaethPredictor(0, pDataPrev^[i], 0)); + for i := BytesPerPixel to pred(RowSize) do + inc(pDataCur^[i], PNGtoBMP_PaethPredictor(pDataCur^[i - BytesPerPixel], pDataPrev^[i], pDataPrev^[i - BytesPerPixel])); + end; + end; + end; +end; +// Computes Paeth predictor for filter type 4 +function PNGtoBMP_PaethPredictor(a, b, c: byte): byte; +var pa, pb, pc: integer; +begin + pa := abs(b - c); + pb := abs(a - c); + pc := abs(integer(a + b - c - c)); + if (pa <= pb) and (pa <= pc) then + result := a + else + if pb <= pc then + result := b + else + result := c; +end; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +// Computes values for Adam7 interlace method +procedure PNGToBMP_Adam7Values(var PNGI: TPNGInfos); +const ADAM7LenParam: array [0..pred(7), 0..pred(4)] of cardinal = + ((7,8,7,8),(3,8,7,8),(3,4,3,8),(1,4,3,4),(1,2,1,4),(0,2,1,2),(0,1,0,2)); +var i: integer; +begin + PNGI.Adam7StartPos[0] := 0; + for i:= 0 to pred(7) do + begin + PNGI.Adam7StartPos[i + 1] := PNGI.Adam7StartPos[i]; + PNGI.Adam7ColsRows[i, 0] := (PNGI.Width + ADAM7ColIncrm[i] - ADAM7ColStart[i] - 1) div ADAM7ColIncrm[i]; + PNGI.Adam7ColsRows[i, 1] := (PNGI.Height + ADAM7RowIncrm[i] - ADAM7RowStart[i] - 1) div ADAM7RowIncrm[i]; + if PNGI.Adam7ColsRows[i, 0]<>0 then + inc(PNGI.Adam7StartPos[i + 1], (1 + PNGtoBMP_SupDiv8(((PNGI.Width + ADAM7LenParam[i, 0]) div ADAM7LenParam[i, 1]) * PNGI.BitsPerPixel)) * ((PNGI.Height + ADAM7LenParam[i, 2]) div ADAM7LenParam[i, 3])); + end; +end; +// Reverses interlacing and filtering (Adam7 interlace method) +function PNGtoBMP_ReverseInterFilter(const PNGI: TPNGInfos; pScanLines: PByteArray; pData: PByteArray): boolean; +var pTMPRowLines, pTMPRowLine1, pTMPRowLine2, pTMPRowSwap: PByteArray; +var curpos, linesize, colout, addout: cardinal; +var FilterType: byte; +var i, j, k: cardinal; +begin + result := true; + GetMem(pTMPRowLines, PNGI.RowSize * 2); // for 2 data lines (current and previous) + pTmpRowLine1 := @pTMPRowLines^[0]; + pTmpRowLine2 := @pTMPRowLines^[PNGI.RowSize]; + addout := 0; + for i:=0 to pred(7) do + if (PNGI.Adam7ColsRows[i, 0]<>0) and (PNGI.Adam7ColsRows[i, 1]<>0) then + begin + curpos := PNGI.Adam7StartPos[i]; + linesize := PNGtoBMP_SupDiv8(PNGI.Adam7ColsRows[i, 0] * PNGI.BitsPerPixel); + for j:=0 to pred(PNGI.Adam7ColsRows[i, 1]) do + begin + FilterType := pScanLines^[curpos]; + if FilterType>4 then + begin + result := false; + break; + end; + inc(curpos); + PNGtoBMP_RFOneScanLine(j, PNGI.BytesPerPixel, linesize, FilterType, pTmpRowLine1, pTmpRowLine2, @pScanLines^[curpos]); + colout := ((ADAM7RowStart[i] + (j * ADAM7RowIncrm[i])) * PNGI.Width) + ADAM7ColStart[i]; + if PNGI.BitsPerPixel<8 then + addout := (colout div PNGI.Width) * PNGtoBMP_ComplPow2(PNGI.Width * PNGI.BitsPerPixel, 8); + for k := 0 to pred(PNGI.Adam7ColsRows[i, 0]) do + begin + if PNGI.BitsPerPixel<8 then + PNGtoBMP_CopyBits(pTmpRowLine1, pData, k * PNGI.BitsPerPixel, addout + (colout * PNGI.BitsPerPixel), PNGI.BitsPerPixel) + else + if PNGI.BitsPerPixel=8 then // (faster for 1 byte) + pData^[colout * PNGI.BytesPerPixel] := pTmpRowLine1^[k * PNGI.BytesPerPixel] + else + Move(pTmpRowLine1^[k * PNGI.BytesPerPixel], pData^[colout * PNGI.BytesPerPixel], PNGI.BytesPerPixel); + inc(colout, ADAM7ColIncrm[i]); + end; + inc(curpos, linesize); + pTMPRowSwap := pTMPRowLine1; + pTMPRowLine1 := pTMPRowLine2; + pTMPRowLine2 := pTMPRowSwap; + end; + end; + FreeMem(pTMPRowLines); +end; +// Complement for a power of 2 +function PNGtoBMP_ComplPow2(Value, Power2: cardinal): cardinal; +begin + result := Value and (Power2 - 1); + if result <>0 then result := Power2 - result; +end; +// Copies bit per bit +procedure PNGtoBMP_CopyBits(pDataIn, pDataOut: pByteArray; OffBitsIn, OffBitsOut, NbrBits: cardinal); +var posIn, posOut: cardinal; +var i: cardinal; +var b: byte; +begin + posIn := OffBitsIn; posOut := OffBitsOut; + for i := 0 to pred(NbrBits) do + begin + b := (pDataIn^[posIn shr 3] shr (7 - (posIn and 7))) and 1; + if b<>0 then // (faster if nul) + pDataOut^[posOut shr 3] := pDataOut^[posOut shr 3] or (b shl (7 - (posOut and 7))); + inc(posIn); inc(posOut); + end; +end; +{$endif LLCL_OPT_PNGSIMPLIFIED} +// Creates BMP +function PNGtoBMP_CreateBMP(const PNGI: TPNGInfos; pData: PByteArray; var pBMPData: PByteArray; var BMPDataSize: cardinal): boolean; +const + BMPHEADER_LEN = 14; + BMPDIBHEADER_LEN = 40; // (BITMAPINFOHEADER) + BMPRESOLUTION_DEFAULT = $0B12; // Default horizontal/vertical physical resolution +var pIn, pOut: PByteArray; +var BaseSize, RowSize, NewRowSize, NewBitsPerPixel, NewNbrPalEntries: cardinal; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +var TransformPal, TranspToProcess: boolean; +{$endif LLCL_OPT_PNGSIMPLIFIED} +var i: cardinal; +begin + result := true; + NewBitsPerPixel := PNGI.BitsPerPixel; + RowSize := PNGI.RowSize; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + if PNGI.BitDepth=16 then // Not supported by BMP + begin + if PNGI.ColourType in [0, 2, 6] then NewBitsPerPixel := PNGToBMP_BitsPerPixel(PNGI.ColourType, 8); // (not for ColourType 4, because (*2/2)=1) + RowSize := PNGtoBMP_SupDiv8(PNGI.Width * NewBitsPerPixel); + end + else + begin + if (PNGI.ColourType in [0, 3]) and (PNGI.BitDepth=2) then NewBitsPerPixel := 4; // See hereafter (2 bits per pixel in palette) + if (PNGI.ColourType=4) and (PNGI.BitDepth=8) then NewBitsPerPixel := 32; // Transformed in truecolour+alpha + end; +{$endif LLCL_OPT_PNGSIMPLIFIED} + NewRowSize := (((PNGI.Width * NewBitsPerPixel) + 31) div 32) * 4; + NewNbrPalEntries := 0; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + TransformPal := false; + TranspToProcess := false; + case PNGI.ColourType of + 0: // Greyscale + begin + NewNbrPalEntries := 1 shl PNGI.BitDepth; + if PNGI.BitDepth=16 then + if PNGI.TranspType=1 then + begin + NewNbrPalEntries := 0; + TranspToProcess := true; + end + else + NewNbrPalEntries := 1 shl 8; // BMP doesn't support 16 bits per pixel in palette + end; + 2: // Truecolour + begin + if PNGI.TranspType=1 then + TranspToProcess := true; + end; + 3: // Indexed-colour (Palette) + begin + NewNbrPalEntries := 1 shl PNGI.BitDepth; + end; + end; + BaseSize := BMPHEADER_LEN + BMPDIBHEADER_LEN; + if NewNbrPalEntries>0 then + begin + if PNGI.BitDepth=2 then NewNbrPalEntries := 1 shl 4; // BMP doesn't support 2 bits per pixel in palette + if PNGI.ColourType=0 then // Greyscale + TransformPal := (PNGI.TranspType=1) + else // Indexed-colour (Palette) + TransformPal := (PNGI.TranspType<>0); + if not TransformPal then + BaseSize := BMPHEADER_LEN + BMPDIBHEADER_LEN + (NewNbrPalEntries * 4); + end; + if TranspToProcess or TransformPal then + begin + NewBitsPerPixel := 32; + NewRowSize := PNGI.Width * 4; + end; +{$else LLCL_OPT_PNGSIMPLIFIED} + if PNGI.ColourType=3 then // Indexed-colour (Palette) + NewNbrPalEntries := 1 shl PNGI.BitDepth; + BaseSize := BMPHEADER_LEN + BMPDIBHEADER_LEN + (NewNbrPalEntries * 4); +{$endif LLCL_OPT_PNGSIMPLIFIED} + BMPDataSize := BaseSize + (NewRowSize * PNGI.Height); + GetMem(pBMPData, BMPDataSize); + FillChar(pBMPData^, BaseSize, 0); + // Header + PNGtoBMP_ArrBWordInv(pBMPData^, 0, $4D42); // 'BM' inversed + PNGtoBMP_ArrBLongInv(pBMPData^, 2, BMPDataSize); + PNGtoBMP_ArrBLongInv(pBMPData^, 10, BaseSize); + // DIB Header + PNGtoBMP_ArrBLongInv(pBMPData^, BMPHEADER_LEN + 00, BMPDIBHEADER_LEN); + PNGtoBMP_ArrBLongInv(pBMPData^, BMPHEADER_LEN + 04, PNGI.Width); + PNGtoBMP_ArrBLongInv(pBMPData^, BMPHEADER_LEN + 08, PNGI.Height); + PNGtoBMP_ArrBWordInv(pBMPData^, BMPHEADER_LEN + 12, 1); // Plane + PNGtoBMP_ArrBWordInv(pBMPData^, BMPHEADER_LEN + 14, NewBitsPerPixel); + PNGtoBMP_ArrBLongInv(pBMPData^, BMPHEADER_LEN + 24, BMPRESOLUTION_DEFAULT); + PNGtoBMP_ArrBLongInv(pBMPData^, BMPHEADER_LEN + 28, BMPRESOLUTION_DEFAULT); + // Palette (if present) + if NewNbrPalEntries>0 then +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + begin + if PNGI.ColourType=0 then // Greyscale + PNGtoBMP_PaletteGrey(@PNGI.Palette, PNGI.BitDepth); + if not TransformPal then + Move(PNGI.Palette, pBMPData^[BMPHEADER_LEN + BMPDIBHEADER_LEN], NewNbrPalEntries * 4); + end; +{$else LLCL_OPT_PNGSIMPLIFIED} + Move(PNGI.Palette, pBMPData^[BMPHEADER_LEN + BMPDIBHEADER_LEN], NewNbrPalEntries * 4); +{$endif LLCL_OPT_PNGSIMPLIFIED} + // Bitmap data + pIn := @pData^[pred(PNGI.Height) * PNGI.RowSize]; + pOut := @pBMPData^[BaseSize]; + for i := 0 to pred(PNGI.Height) do + begin + PNGtoBMP_ArrBLongInv(pOut^, NewRowSize-4, 0); // Clears BMP padded byte(s) +{$ifndef LLCL_OPT_PNGSIMPLIFIED} + if TranspToProcess then // Greyscale 16 bits and truecolour with tRNS chunk + PNGtoBMP_TrueToTrueC(pIn, pOut, PNGI) + else + begin + // Before + if PNGI.BitDepth=16 then // 16 bits per channel (not supported by BMP) + PNGtoBMP_16to8(pIn, PNGI.Width, PNGI.ColourType); + // Data move + Move(pIn^, pOut^, RowSize); // (Not PNGI.rowsize) + // After + if PNGI.ColourType in [2, 6] then // Truecolour, truecolour + alpha + PNGtoBMP_SwapRGB(pOut, PNGI.Width, PNGI.ColourType) + else + if PNGI.ColourType=4 then // Greyscale + alpha + PNGtoBMP_GreyToTrueC(pOut, PNGI.Width) + else + if (PNGI.ColourType in [0, 3]) then // Greyscale (-> indexed colour) and indexed colour with 4 colours + if TransformPal then + PNGtoBMP_PalToTrueC(pOut, PNGI) + else + if PNGI.BitDepth=2 then + PNGtoBMP_Pal2To4(pOut, PNGI.RowSize); + end; +{$else LCL_OPT_PNGSIMPLIFIED} + // Data move + Move(pIn^, pOut^, RowSize); // (Not PNGI.rowsize) + // After + if PNGI.ColourType in [2, 6] then // Truecolour, truecolour + alpha + PNGtoBMP_SwapRGB(pOut, PNGI.Width, PNGI.ColourType); +{$endif LLCL_OPT_PNGSIMPLIFIED} + dec(pByte(pIn), PNGI.RowSize); + inc(pByte(pOut), NewRowSize); + end; +end; +// Long to Bytes inversed +procedure PNGtoBMP_ArrBLongInv(var Buffer: array of byte; Offset: cardinal; Value: cardinal); +begin + PLongword(@Buffer[Offset])^ := Value; +end; +// Word to Bytes inversed +procedure PNGtoBMP_ArrBWordInv(var Buffer: array of byte; Offset: cardinal; Value: word); +begin + PWord(@Buffer[Offset])^ := Value; +end; +// Colour Swap RGB <-> BGR +procedure PNGtoBMP_SwapRGB(pData: PByteArray; NbrCols: cardinal; ColourType: byte); +var pTmpData: PByteArray; +var i, bpc: cardinal; +var b: byte; +begin + pTmpData := pData; + if ColourType=2 then bpc := 3 else bpc := 4; // Truecolour or truecolour+alpha + for i := 0 to pred(NbrCols) do + begin + b := pTmpData^[0]; + pTmpData^[0] := pTmpData^[2]; + pTmpData^[2] := b; + inc(pByte(pTmpData), bpc); + end; +end; +{$ifndef LLCL_OPT_PNGSIMPLIFIED} +// Creates palette for greyscale +procedure PNGtoBMP_PaletteGrey(pPalette: PByteArray; BitDepth: byte); +var bd: cardinal; +var i: cardinal; +var b1, b2: byte; +begin + // Notes: eventual transparency (tRNS chunk) processed in PNGtoBMP_PalToTrueC + // greyscale with BitDepth=16 and tRNS chunk processed in PNGtoBMP_TrueToTrueC + if BitDepth>8 then + bd := 256 // 16 bits -> 8 bits per channel + else + bd := 1 shl BitDepth; + case BitDepth of + 1: b1 := $FF; + 2: b1 := $55; + 4: b1 := $11; + else b1 := $01; + end; + b2 := $00; + for i:=0 to pred(bd) do + begin + PNGtoBMP_ArrBLongInv(pPalette^, i * 4, (b2 shl 16) + (b2 shl 8) + b2); + inc(b2, b1); + end; +end; +// Reduces 16 bits to 8 bits (channels, alpha) +procedure PNGtoBMP_16to8(pData: PByteArray; NbrCols: cardinal; ColourType: byte); +var pIn, pOut: PByteArray; +var i, NbrTimes: cardinal; +begin + // Note: for greyscale and truecolour, if tRNS chunk present, processed in PNGtoBMP_TrueToTrueC + pIn := pData; + pOut := pData; + case ColourType of + 2: NbrTimes := 3; // Truecolour + 4: NbrTimes := 2; // Greyscale + alpha + 6: NbrTimes := 4; // Truecolour + alpha + else NbrTimes := 1; // Greyscale + end; + NbrTimes := NbrTimes * NbrCols; + for i := 0 to pred(NbrTimes) do + begin + pOut^[0] := pIn^[0]; // Only MSB + inc(pByte(pIn), 2); + inc(pByte(pOut)); + end; +end; +// Truecolour (with tRNS chunk) to truecolour + alpha (8 bits) +procedure PNGtoBMP_TrueToTrueC(pDataIn: PByteArray; pDataOut: PByteArray; const PNGI: TPNGInfos); +var pIn, pOut: PByteArray; +var PixelColour: cardinal; +var i: cardinal; +var w1, w2, w3: cardinal; +begin + // Note: includes also greyscale with BitDepth=16 and tRNS chunk + pIn := @pDataIn^[pred(PNGI.Width) * PNGI.BytesPerPixel]; + pOut := @pDataOut^[pred(PNGI.Width) * 4]; + for i := 0 to pred(PNGI.Width) do + begin + if PNGI.ColourType=0 then // Greyscale (only with BitDepth=16 and tRNS chunk) + begin + w1 := PNGtoBMP_WordArrB(pIn^, 0); + w2 := w1; w3 := w1; + dec(pByte(pIn), 2); + end + else // Truecolour (BitDepth=8 or 16) + if PNGI.BitDepth=8 then + begin + w1 := pIn^[2]; + w2 := pIn^[1]; + w3 := pIn^[0]; + dec(pByte(pIn), 3); + end + else + begin + w1 := PNGtoBMP_WordArrB(pIn^, 4); + w2 := PNGtoBMP_WordArrB(pIn^, 2); + w3 := PNGtoBMP_WordArrB(pIn^, 0); + dec(pByte(pIn), 6); + end; + if PNGI.BitDepth=16 then + PixelColour := ((w3 shr 8) shl 16) + ((w2 shr 8) shl 8) + (w1 shr 8) + else + PixelColour := (w3 shl 16) + (w2 shl 8) + w1; + if PNGI.TranspType=1 then + if (w1<>PNGI.Transp[0]) or (w2<>PNGI.Transp[1]) or (w3<>PNGI.Transp[2]) then + PixelColour := PixelColour or $FF000000; + PNGtoBMP_ArrBLongInv(pOut^, 0, PixelColour); + dec(pByte(pOut), 4); + end; +end; +// Greyscale + alpha to truecolour + alpha (8 bits) +procedure PNGtoBMP_GreyToTrueC(pData: PByteArray; NbrCols: cardinal); +var pIn, pOut: PByteArray; +var i: cardinal; +var b: byte; +begin + pIn := @pData^[pred(NbrCols) * 2]; + pOut := @pData^[pred(NbrCols) * 4]; + for i := 0 to pred(NbrCols) do + begin + b := pIn^[0]; + PNGtoBMP_ArrBLongInv(pOut^, 0, (pIn^[1] shl 24) + (b shl 16) + (b shl 8) + b); + dec(pByte(pIn), 2); + dec(pByte(pOut), 4); + end; +end; +// Palette (with tRNS chunk) to truecolour + alpha (8 bits) +procedure PNGtoBMP_PalToTrueC(pData: PByteArray; const PNGI: TPNGInfos); +var pIn, pOut: PByteArray; +var PixelBits, NbrPixels, Mask, PixelIndex: byte; +var PixelColour, ColourTransp: cardinal; +var i, j: cardinal; +begin + // Note: greyscale (-> palette) with BitDepth=16 and tRNS chunk processed in PNGtoBMP_TrueToTrueC + pIn := @pData^[pred(PNGI.RowSize)]; + pOut := @pData^[pred(PNGI.Width) * 4]; + if PNGI.BitDepth<8 then + begin + Mask := Pred(1 shl PNGI.BitDepth); + PixelBits := pIn^[0]; + NbrPixels := 8 div PNGI.BitDepth; + // Skip padding bits, if present + j := PNGtoBMP_ComplPow2(PNGI.Width * PNGI.BitsPerPixel, 8); + if j>0 then + for i:=0 to pred(j div PNGI.BitDepth) do + begin + PixelBits := PixelBits shr PNGI.BitDepth; + dec(NbrPixels); + end; + end + else + begin + Mask := 0; PixelBits := 0; NbrPixels := 0; // (to avoid compilation warning) + end; + if PNGI.ColourType=0 then // Greyscale + ColourTransp := (PNGI.Transp[0] and $FF) + else // Palette + ColourTransp := ((PNGI.Transp[0] and $FF) shl 16) + ((PNGI.Transp[1] and $FF) shl 8) + (PNGI.Transp[2] and $FF); + for i := 0 to pred(PNGI.Width) do + begin + if PNGI.BitDepth<8 then + begin + PixelIndex := PixelBits and Mask; + PixelBits := PixelBits shr PNGI.BitDepth; + dec(NbrPixels); + end + else + PixelIndex := pIn^[0]; + PixelColour := PNGtoBMP_LongArrBInv(PNGI.Palette, PixelIndex * 4); + if PNGI.TranspType=1 then + if ((PNGI.ColourType=0) and (PixelIndex<>ColourTransp)) or ((PNGI.ColourType=3) and (PixelColour<>ColourTransp)) then + PixelColour := PixelColour or $FF000000; + PNGtoBMP_ArrBLongInv(pOut^, 0, PixelColour); + if (PNGI.BitDepth=8) or (NbrPixels=0) then + begin + dec(pByte(pIn), 1); + if PNGI.BitDepth<8 then + begin + PixelBits := pIn^[0]; + NbrPixels := 8 div PNGI.BitDepth; + end; + end; + dec(pByte(pOut), 4); + end; +end; +// Bytes to Long inversed +function PNGtoBMP_LongArrBInv(Const Buffer: array of Byte; Const Offset: cardinal): cardinal; +begin + result := PLongword(@Buffer[Offset])^; +end; +// Palette 2 bits per colour to 4 bits +procedure PNGtoBMP_Pal2To4(pData: PByteArray; RowSize: cardinal); +var pIn, pOut: PByteArray; +var i: cardinal; +var b: byte; +begin + pIn := @pData^[pred(RowSize)]; + pOut := @pData^[pred(RowSize) * 2]; + for i := 0 to pred(RowSize) do + begin + b := pIn^[0]; + PNGtoBMP_ArrBWordInv(pOut^, 0, ((b and $0C) shl 10) + ((b and $03) shl 8) + ((b and $C0) shr 2) + ((b and $30) shr 4)); // (Probably another faster way) + dec(pByte(pIn)); + dec(pByte(pOut), 2); + end; +end; +{$endif LLCL_OPT_PNGSIMPLIFIED} + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. + diff --git a/sources/LLCLZlib.pas b/sources/LLCLZlib.pas new file mode 100644 index 0000000..9463025 --- /dev/null +++ b/sources/LLCLZlib.pas @@ -0,0 +1,464 @@ +unit LLCLZlib; + +{ + LLCL - FPC/Lazarus Light LCL + based upon + LVCL - Very LIGHT VCL + ---------------------------- + + This file is a part of the Light LCL (LLCL). + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + + This Source Code Form is "Incompatible With Secondary Licenses", + as defined by the Mozilla Public License, v. 2.0. + + Copyright (c) 2015-2016 ChrisF + + Based upon the Very LIGHT VCL (LVCL): + Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info + Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + + Version 1.01: + * File creation. + * Zlib interface for the Light LCL implemented +} + +{$IFDEF FPC} + {$define LLCL_FPC_MODESECTION} + {$I LLCLFPCInc.inc} // For mode + {$undef LLCL_FPC_MODESECTION} +{$ENDIF} +{$ifdef FPC_OBJFPC} {$define LLCL_OBJFPC_MODE} {$endif} // Object pascal mode + +{$I LLCLOptions.inc} // Options + +// Zlib option checks +{$if Defined(LLCL_OPT_USEZLIBDLL) and Defined(LLCL_OPT_USEZLIBOBJ)} + {$error Can't have several Zlib options at the same time} +{$ifend} +{$if Defined(LLCL_OPT_USEZLIBDLLDYN) and (not Defined(LLCL_OPT_USEZLIBDLL))} + {$error Can't have the dynamic DLL Zlib option without LLCL_OPT_USEZLIBDLL} +{$ifend} + +//------------------------------------------------------------------------------ + +interface + +// The destination buffer must be large enough to hold the entire compressed/uncompressed data + +function LLCL_compress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +function LLCL_compress2(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal; level: integer): integer; +function LLCL_uncompress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; + +//------------------------------------------------------------------------------ + +implementation + +{$if Defined(LLCL_OPT_USEZLIBDLLDYN)} + uses + LLCLOSInt, + Windows; +{$ifend LLCL_OPT_USEZLIBDLLDYN} + +{$IFDEF FPC} + {$PUSH} {$HINTS OFF} +{$ENDIF} + +{$if Defined(LLCL_OPT_USEZLIBDLL) or Defined(LLCL_OPT_USEZLIBOBJ)} +type + PBytef = PByte; +{$IFDEF FPC} + TAlloc_func = function (opaque: pointer; items, size: cardinal): pointer; cdecl; + TFree_func = procedure (opaque, ptr: pointer); cdecl; +{$ELSE FPC} +{$if Defined(LLCL_OPT_USEZLIBOBJ)} + TAlloc_func = function (opaque: pointer; items, size: cardinal): pointer; + TFree_func = procedure (opaque, ptr: pointer); +{$else LLCL_OPT_USEZLIBOBJ} + TAlloc_func = function (opaque: pointer; items, size: cardinal): pointer; cdecl; + TFree_func = procedure (opaque, ptr: pointer); cdecl; +{$ifend LLCL_OPT_USEZLIBOBJ} +{$ENDIF FPC} + TZStreamRec = packed record + next_in: PBytef; // next input byte + avail_in: cardinal; // number of bytes available at next_in + total_in: cardinal; // total number of input bytes read so far + + next_out: PBytef; // next output byte should be put there + avail_out: cardinal; // remaining free space at next_out + total_out: cardinal; // total number of bytes output so far + + msg: PChar; // last error message, NULL if no error + internal_state: pointer; // not visible by applications + + zalloc: TAlloc_func; // used to allocate the internal state + zfree: TFree_func; // 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: binary or text + adler: cardinal; // adler32 value of the uncompressed data + reserved: cardinal; // reserved for future use + end; + +{$if Defined(LLCL_OPT_USEZLIBOBJ)} // Obj + const + zlib_version: ansistring = '1.2.8'; + Z_FINISH = 4; + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_DATA_ERROR = -3; + Z_BUF_ERROR = -5; + Z_DEFAULT_COMPRESSION = -1; + {$IFNDEF FPC} + z_errmsg: array [0..pred(10)] of string = ( + '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) + '' ); + {$ENDIF NFPC} + {$IFDEF FPC} + {$if Defined(CPU64) or Defined(CPU64BITS)} + {$L ZlibObj\win64\adler32.o} + {$L ZlibObj\win64\crc32.o} + {$L ZlibObj\win64\deflate.o} + {$L ZlibObj\win64\infback.o} + {$L ZlibObj\win64\inffast.o} + {$L ZlibObj\win64\inflate.o} + {$L ZlibObj\win64\inftrees.o} + {$L ZlibObj\win64\match.o} + {$L ZlibObj\win64\trees.o} + {$L ZlibObj\win64\zutil.o} + {$else} + {$L ZlibObj\win32\adler32.o} + {$L ZlibObj\win32\crc32.o} + {$L ZlibObj\win32\deflate.o} + {$L ZlibObj\win32\infback.o} + {$L ZlibObj\win32\inffast.o} + {$L ZlibObj\win32\inflate.o} + {$L ZlibObj\win32\inftrees.o} + {$L ZlibObj\win32\match.o} + {$L ZlibObj\win32\trees.o} + {$L ZlibObj\win32\zutil.o} + {$ifend} + function deflateInit_(var strm: TZStreamRec; level: integer; version: PAnsiChar; stream_size: integer): integer; cdecl; external; + function deflate(var strm: TZStreamRec; flush: integer): integer; cdecl; external; + function deflateEnd(var strm: TZStreamRec): integer; cdecl; external; + function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; stream_size: integer): integer; cdecl; external; + function inflate(var strm: TZStreamRec; flush: integer): integer; cdecl; external; + function inflateEnd(var strm: TZStreamRec): integer; cdecl; external; + // + function zcalloc(opaque: pointer; items, size: cardinal): pointer; cdecl; forward; + procedure zcfree(opaque, ptr: pointer); cdecl; forward; + function _malloc(size: cardinal): pointer; cdecl; [public, alias: '_malloc']; forward; + procedure _free(ptr: pointer); cdecl; [public, alias: '_free']; forward; + {$ELSE FPC} + {$if Defined(CPU64) or Defined(CPU64BITS)} + {$L ZlibObj\win64\deflate.obj} + {$L ZlibObj\win64\inflate.obj} + {$L ZlibObj\win64\inftrees.obj} + {$L ZlibObj\win64\infback.obj} + {$L ZlibObj\win64\inffast.obj} + {$L ZlibObj\win64\trees.obj} + {$L ZlibObj\win64\compress.obj} + {$L ZlibObj\win64\adler32.obj} + {$L ZlibObj\win64\crc32.obj} + {$else} + {$L ZlibObj\win32\deflate.obj} + {$L ZlibObj\win32\inflate.obj} + {$L ZlibObj\win32\inftrees.obj} + {$L ZlibObj\win32\infback.obj} + {$L ZlibObj\win32\inffast.obj} + {$L ZlibObj\win32\trees.obj} + {$L ZlibObj\win32\compress.obj} + {$L ZlibObj\win32\adler32.obj} + {$L ZlibObj\win32\crc32.obj} + {$ifend} + function deflateInit_(var strm: TZStreamRec; level: integer; version: PAnsiChar; stream_size: integer): integer; external; + function deflate(var strm: TZStreamRec; flush: integer): integer; external; + function deflateEnd(var strm: TZStreamRec): integer; external; + function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; stream_size: integer): integer; external; + function inflate(var strm: TZStreamRec; flush: integer): integer; external; + function inflateEnd(var strm: TZStreamRec): integer; external; + // + function zcalloc(opaque: pointer; items, size: cardinal): pointer; forward; + procedure zcfree(opaque, ptr: pointer); forward; + function memset(ptr: pointer; value: byte; num: integer): pointer; cdecl; forward; + procedure memcpy(destination, source: pointer; num: integer); cdecl; forward; + {$if (not Defined(CPU64)) and (not Defined(CPU64BITS))} + procedure _llmod; forward; + {$ifend} + {$ENDIF FPC} +{$else LLCL_OPT_USEZLIBOBJ} // DLL + const + zlib_dll = 'zlib1.dll'; + {$if Defined(LLCL_OPT_USEZLIBDLLDYN)} // Dynamic DLL + Z_ERRNO = -1; + var + ZlibDllHandle: HMODULE = 0; + inflateInit_: function(var strm: TZStreamRec; version: PAnsiChar; stream_size: integer): integer; cdecl; + inflate: function(var strm: TZStreamRec; flush: integer): integer; cdecl; + inflateEnd: function(var strm: TZStreamRec): integer; cdecl; + compress: function(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal): integer; cdecl; + compress2: function(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal; level: integer): integer; cdecl; + uncompress: function(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal): integer; cdecl; + function LLCL_LoadZlib(): boolean; forward; + {$else LLCL_OPT_USEZLIBDLLDYN} // Static DLL + function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; stream_size: integer): integer; cdecl; external zlib_dll; + function inflate(var strm: TZStreamRec; flush: integer): integer; cdecl; external zlib_dll; + function inflateEnd(var strm: TZStreamRec): integer; cdecl; external zlib_dll; + function compress(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal): integer; cdecl external zlib_dll; + function compress2(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal; level: integer): integer; cdecl external zlib_dll; + function uncompress(dest: PBytef; var destLen: cardinal; source: PBytef; sourceLen: cardinal): integer; cdecl external zlib_dll; + {$ifend LLCL_OPT_USEZLIBDLLDYN} +{$ifend LLCL_OPT_USEZLIBOBJ} +{$else LLCL_OPT_USEZLIBDLL or LLCL_OPT_USEZLIBOBJ} // PazZlib +uses + {$IFDEF FPC}PasZlib{$ELSE}SysUtils, gZlib, ZUtil, zCompres, zUnCompr{$ENDIF}; +{$ifend LLCL_OPT_USEZLIBDLL or LLCL_OPT_USEZLIBOBJ} + +//------------------------------------------------------------------------------ + +{$if Defined(LLCL_OPT_USEZLIBDLL) or Defined(LLCL_OPT_USEZLIBOBJ)} + +// Obj + +{$if Defined(LLCL_OPT_USEZLIBOBJ)} +{$IFDEF FPC} +function zcalloc(opaque: pointer; items, size: cardinal): pointer; cdecl; +begin + GetMem(result, items * size); +end; +procedure zcfree(opaque, ptr: pointer); cdecl; +begin + FreeMem(ptr); +end; +// _malloc and _free not used, if zcalloc and zcfree are used +function _malloc(size: cardinal): pointer; cdecl; +begin + GetMem(result, size); +end; +procedure _free(ptr: pointer); cdecl; +begin + FreeMem(ptr); +end; +{$ELSE FPC} +function zcalloc(opaque: pointer; items, size: cardinal): pointer; +begin + GetMem(result, items * size); +end; +procedure zcfree(opaque, ptr: pointer); +begin + FreeMem(ptr); +end; +function memset(ptr: pointer; value: byte; num: integer): pointer; cdecl; +begin + FillChar(ptr^, num, value); + result := ptr; +end; +procedure memcpy(destination, source: pointer; num: integer); cdecl; +begin + Move(source^, destination^, num); +end; +{$if (not Defined(CPU64)) and (not Defined(CPU64BITS))} +procedure _llmod; +asm + jmp System.@_llmod; +end; +{$ifend} +{$ENDIF FPC} + +function LLCL_compress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +begin + result := LLCL_compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION); +end; + +function LLCL_compress2(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal; level: integer): integer; +var ZSR: TZStreamRec; +begin + FillChar(ZSR, SizeOf(ZSR), 0); + ZSR.next_in := PBytef(source); + ZSR.avail_in := sourceLen; + ZSR.next_out := PBytef(dest); + ZSR.avail_out := destLen; + ZSR.zalloc := {$IFDEF LLCL_OBJFPC_MODE}@{$ENDIF}zcalloc; + ZSR.zfree := {$IFDEF LLCL_OBJFPC_MODE}@{$ENDIF}zcfree; + result := deflateInit_(ZSR, level, @zlib_version[1], SizeOf(ZSR)); + if result<>Z_OK then exit; + result := deflate(ZSR, Z_FINISH); + if result<>Z_STREAM_END then + begin + deflateEnd(ZSR); + if (result=Z_OK) then + result := Z_BUF_ERROR; + exit; + end; + destLen := ZSR.total_out; + result := deflateEnd(ZSR); +end; + +function LLCL_uncompress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +var ZSR: TZStreamRec; +begin + FillChar(ZSR, SizeOf(ZSR), 0); + ZSR.next_in := PBytef(source); + ZSR.avail_in := sourceLen; + ZSR.next_out := PBytef(dest); + ZSR.avail_out := destLen; + ZSR.zalloc := {$IFDEF LLCL_OBJFPC_MODE}@{$ENDIF}zcalloc; + ZSR.zfree := {$IFDEF LLCL_OBJFPC_MODE}@{$ENDIF}zcfree; + result := inflateInit_(ZSR, @zlib_version[1], SizeOf(ZSR)); + if result<>Z_OK then exit; + result := inflate(ZSR, Z_FINISH); + if result<>Z_STREAM_END then + begin + inflateEnd(ZSR); + if (result=Z_NEED_DICT) or ((result=Z_BUF_ERROR) and (sourceLen=0)) then + result := Z_DATA_ERROR; + exit; + end; + destLen := ZSR.total_out; + result := inflateEnd(ZSR); +end; + +{$else LLCL_OPT_USEZLIBOBJ} + +// DLL (static or dynamic) + +function LLCL_compress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +begin +{$if Defined(LLCL_OPT_USEZLIBDLLDYN)} + if not LLCL_LoadZlib() then + begin + result := Z_ERRNO; + exit; + end; +{$ifend LLCL_OPT_USEZLIBDLLDYN} + result := compress(PBytef(dest), destLen, PBytef(source), sourceLen); +end; + +function LLCL_compress2(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal; level: integer): integer; +begin +{$if Defined(LLCL_OPT_USEZLIBDLLDYN)} + if not LLCL_LoadZlib() then + begin + result := Z_ERRNO; + exit; + end; +{$ifend LLCL_OPT_USEZLIBDLLDYN} + result := compress2(PBytef(dest), destLen, PBytef(source), sourceLen, level); +end; + +function LLCL_uncompress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +begin +{$if Defined(LLCL_OPT_USEZLIBDLLDYN)} + if not LLCL_LoadZlib() then + begin + result := Z_ERRNO; + exit; + end; +{$ifend LLCL_OPT_USEZLIBDLLDYN} + result := uncompress(PBytef(dest), destLen, PBytef(source), sourceLen); +end; + +{$ifend LLCL_OPT_USEZLIBOBJ} + +{$else LLCL_OPT_USEZLIBDLL or LLCL_OPT_USEZLIBOBJ} + +// PasZlib + +function LLCL_compress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +begin +{$IFDEF FPC} + result := compress(PChar(dest), destLen, PChar(source), sourceLen); +{$ELSE FPC} + result := compress(PBytef(dest), destLen, PByteArray(source)^, sourceLen); +{$ENDIF FPC} +end; + +function LLCL_compress2(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal; level: integer): integer; +begin +{$IFDEF FPC} + result := compress2(PChar(dest), destLen, PChar(source), sourceLen, level); +{$ELSE FPC} + result := compress2(PBytef(dest), destLen, PByteArray(source)^, sourceLen, level); +{$ENDIF FPC} +end; + +function LLCL_uncompress(dest: PByte; var destLen: cardinal; source: PByte; sourceLen: cardinal): integer; +begin +{$IFDEF FPC} + result := uncompress(PChar(dest), destLen, PChar(source), sourceLen); +{$ELSE FPC} + result := uncompress(PBytef(dest), destLen, PByteArray(source)^, sourceLen); +{$ENDIF FPC} +end; + +{$ifend LLCL_OPT_USEZLIBDLL or LLCL_OPT_USEZLIBOBJ} + +//------------------------------------------------------------------------------ + +// Dynamic DLL + +{$if Defined(LLCL_OPT_USEZLIBDLLDYN)} +function LLCL_LoadZlib(): boolean; +begin + result := false; + if ZlibDllHandle=0 then + begin + inflateInit_ := nil; inflate := nil; inflateEnd := nil; + compress := nil; compress2 := nil; uncompress := nil; + ZlibDllHandle := LLCL_LoadLibrary(zlib_dll); + end; + if ZlibDllHandle=0 then exit; + if not Assigned(inflateInit_) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(inflateInit_){$ELSE}@inflateInit_{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'inflateInit_'); + if not Assigned(inflate) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(inflate){$ELSE}@inflate{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'inflate'); + if not Assigned(inflateEnd) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(inflateEnd){$ELSE}@inflateEnd{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'inflateEnd'); + if not Assigned(compress) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(compress){$ELSE}@compress{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'compress'); + if not Assigned(compress) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(compress){$ELSE}@compress{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'compress'); + if not Assigned(compress2) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(compress2){$ELSE}@compress2{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'compress2'); + if not Assigned(uncompress) then + {$IFDEF LLCL_OBJFPC_MODE}FARPROC(uncompress){$ELSE}@uncompress{$ENDIF} + := LLCL_GetProcAddress(ZlibDllHandle, 'uncompress'); + if (not Assigned(inflateInit_)) or (not Assigned(inflate)) or (not Assigned(inflateEnd)) + or (not Assigned(compress)) or (not Assigned(compress2)) or (not Assigned(uncompress)) then + exit; + result := true; +end; + +initialization + +finalization + if ZlibDllHandle<>0 then + begin + LLCL_FreeLibrary(ZlibDllHandle); + ZlibDllHandle := 0; + end; +{$ifend LLCL_OPT_USEZLIBDLLDYN} + +{$IFDEF FPC} + {$POP} +{$ENDIF} + +end. diff --git a/sources/LMessages.pp b/sources/LMessages.pp index 3f5e859..06ed0e3 100644 --- a/sources/LMessages.pp +++ b/sources/LMessages.pp @@ -12,15 +12,17 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * TWMMove, TWMNotify, TWMSysCommand added Version 1.00: * File creation. @@ -179,6 +181,20 @@ TWMMouse = record TWMRButtonDblClk = TWMMouse; TWMMouseMove = TWMMouse; + TWMMove = record + Msg: cardinal; + MsgFiller: TDWordFiller; + Unused: WPARAM; + case integer of + 0: ( + XPos: smallint; + YPos: smallint; ); + 1: ( + Pos: TSmallPoint; + LParamFiller: TDWordFiller; + Result: LRESULT; ); + end; + TWMNCHitTest = record Msg: cardinal; MsgFiller: TDWordFiller; @@ -193,6 +209,15 @@ TWMNCHitTest = record Result: LRESULT; ); end; + TWMNotify = record + Msg: cardinal; + MsgFiller: TDWordFiller; + IDCtrl: longint; + WParamFiller: TDWordFiller; + NMHdr: PNMHdr; + Result: LRESULT; + end; + TWMPaint = record Msg: cardinal; MsgFiller: TDWordFiller; @@ -232,6 +257,17 @@ TWMSize = record Result: LRESULT; end; + TWMSysCommand = record + Msg: cardinal; + MsgFiller: TDWordFiller; + case CmdType: WPARAM of + SC_HOTKEY: (ActivateWindow: HWND); + SC_KEYMENU: (Key: word); + SC_CLOSE, SC_HSCROLL, SC_MAXIMIZE, SC_MINIMIZE, SC_MOUSEMENU, SC_MOVE, + SC_NEXTWINDOW, SC_PREVWINDOW, SC_RESTORE, SC_SCREENSAVE, SC_SIZE, SC_TASKLIST, SC_VSCROLL: + (XPos: smallint; YPos: smallint; LParamFiller: TDWordFiller; Result: LRESULT; ); + end; + TWMTimer = record Msg: cardinal; MsgFiller: TDWordFiller; diff --git a/sources/LazFileUtils.pas b/sources/LazFileUtils.pas index 4b4990f..09e59ea 100644 --- a/sources/LazFileUtils.pas +++ b/sources/LazFileUtils.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. * UTF8 file functions (equivalent of SysUtils ones) diff --git a/sources/LazUTF8.pas b/sources/LazUTF8.pas index 4c96024..c1987ae 100644 --- a/sources/LazUTF8.pas +++ b/sources/LazUTF8.pas @@ -12,15 +12,17 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * UTF8CompareStr, UTF8CompareText, UTF8LowerCase and UTF8UpperCase added Version 1.00: * File creation. * Some UTF8 functions (not present in LazFileUtils) @@ -48,11 +50,21 @@ function UTF8ToSys(const S: utf8string): ansistring; function SysToUTF8(const S: ansistring): utf8string; function UTF8ToWinCP(const S: utf8string): ansistring; function WinCPToUTF8(const S: ansistring): utf8string; +function UTF8CompareStr(const S1, S2: utf8string): integer; +function UTF8CompareText(const S1, S2: utf8string): integer; +// Note: ALanguage is ignored in UTF8LowerCase and UTF8UpperCase +function UTF8LowerCase(const AInStr: utf8string; ALanguage: utf8string=''): utf8string; +function UTF8UpperCase(const AInStr: utf8string; ALanguage: utf8string=''): utf8string; {$ELSE UNICODE} function UTF8ToSys(const S: string): string; function SysToUTF8(const S: string): string; function UTF8ToWinCP(const S: string): string; function WinCPToUTF8(const S: string): string; +function UTF8CompareStr(const S1, S2: string): integer; +function UTF8CompareText(const S1, S2: string): integer; +// Note: ALanguage is ignored in UTF8LowerCase and UTF8UpperCase +function UTF8LowerCase(const AInStr: string; ALanguage: string=''): string; +function UTF8UpperCase(const AInStr: string; ALanguage: string=''): string; {$ENDIF UNICODE} //------------------------------------------------------------------------------ @@ -110,6 +122,57 @@ function WinCPToUTF8(const S: string): string; result := LLCLS_WinCPToUTF8(S); end; +{$IFDEF UNICODE} +function UTF8CompareStr(const S1, S2: utf8string): integer; +{$ELSE UNICODE} +function UTF8CompareStr(const S1, S2: string): integer; +{$ENDIF UNICODE} +var count, count1, count2: integer; +begin + count1 := length(S1); + count2 := length(S2); + if count1 > count2 then + count := count2 + else + count := count1; + result := CompareByte(pointer(@s1[1])^, pointer(@s2[1])^, count); + if result=0 then + if count1 > count2 then + result := 1 // Doesn't return count1 - count 2 + else + if count1 < count2 then + result := -1; // Like CompareStr in SysUTils +end; + +{$IFDEF UNICODE} +function UTF8CompareText(const S1, S2: utf8string): integer; +{$ELSE UNICODE} +function UTF8CompareText(const S1, S2: string): integer; +{$ENDIF UNICODE} +begin + result := UTF8CompareStr(UTF8UpperCase(S1), UTF8UpperCase(S2)); +end; + +{$IFDEF UNICODE} +function UTF8LowerCase(const AInStr: utf8string; ALanguage: utf8string=''): utf8string; +{$ELSE UNICODE} +function UTF8LowerCase(const AInStr: string; ALanguage: string=''): string; +{$ENDIF UNICODE} +begin + // (Language ignored) + result := LLCLS_UTF8LowerCase(AInStr); +end; + +{$IFDEF UNICODE} +function UTF8UpperCase(const AInStr: utf8string; ALanguage: utf8string=''): utf8string; +{$ELSE UNICODE} +function UTF8UpperCase(const AInStr: string; ALanguage: string=''): string; +{$ENDIF UNICODE} +begin + // (Language ignored) + result := LLCLS_UTF8UpperCase(AInStr); +end; + //------------------------------------------------------------------------------ {$IFDEF FPC} diff --git a/sources/LazUTF8Classes.pas b/sources/LazUTF8Classes.pas index a2f43b5..239af8d 100644 --- a/sources/LazUTF8Classes.pas +++ b/sources/LazUTF8Classes.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. * TFileStreamUTF8 class (simplified) diff --git a/sources/Menus.pas b/sources/Menus.pas index 2ed5865..c8dab9b 100644 --- a/sources/Menus.pas +++ b/sources/Menus.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. * TMenuItem, TMenu, TMainMenu and TPopupMenu implemented diff --git a/sources/StdCtrls.pas b/sources/StdCtrls.pas index 458fdb3..f0c5c10 100644 --- a/sources/StdCtrls.pas +++ b/sources/StdCtrls.pas @@ -12,15 +12,26 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * Modification: background color support + * TWinControl: notifications for child controls modified + * TEdit, TMemo, TStaticText, TLabel, TCheckBox, TRadioButton: 'Alignment' property moved to TVisualControl in Control.pas (not standard) + * TEdit (Delphi), TCheckBox (FPC): 'InitialAlignment' property removed + * TComboBox, TListBox: 'Sorted' property now accessible (design time only) + * TComboBox: 'Style' property now accessible (design time only) + * TEdit: 'PasswordChar' property now accessible (design time only) + * TMemo, TLabel: 'WordWrap' property now accessible (design time only) + * TMemo: 'ScrollBars' property now accessible (design time only) + * TStaticText: 'BorderStyle' property now accessible (design time only) Version 1.00: * TStaticText implemented * TMemo: ScrollBars and WordWrap (design time only), WantReturns and WantTabs added @@ -97,10 +108,9 @@ interface Classes, Controls; type -{$ifdef LLCL_OPT_STDLABEL} +{$ifdef LLCL_OPT_STDLABEL} TLabel = class(TGraphicControl) private - fAlignment: TAlignment; fWordWrap: boolean; procedure PaintText(AddFlags: cardinal; var R: TRect); protected @@ -112,6 +122,7 @@ TLabel = class(TGraphicControl) procedure UpdateTextSize(); public constructor Create(AOwner: TComponent); override; + property WordWrap: boolean read fWordWrap write fWordWrap; // Run-time modification ignored; write present only for dynamical control creation purpose end; {$endif} @@ -121,7 +132,7 @@ TButton = class(TWinControl) fCancel: boolean; protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; procedure AdjustTextSize(var Size: TSize); override; @@ -135,26 +146,25 @@ TEdit = class(TWinControl) private fPassWordChar: char; fReadOnly: boolean; - fAlignment: TAlignment; fCreateFlags: cardinal; fOnChangeOK: boolean; EOnChange: TNotifyEvent; procedure SetReadOnly(Value: boolean); protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; function GetText(): string; procedure SetText(const Value: string); - procedure ComponentNotif(var Msg: TMessage); override; + function ComponentNotif(var Msg: TMessage): boolean; override; function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; public constructor Create(AOwner: TComponent); override; procedure SelectAll; property Text: string read GetText write SetText; + property PassWordChar: char read fPassWordChar write fPassWordChar; // Run-time modification ignored; write present only for dynamical control creation purpose property ReadOnly: boolean read fReadOnly write SetReadOnly; - property InitialAlignment: TAlignment read fAlignment write fAlignment; // (For Delphi) property OnChange: TNotifyEvent read EOnChange write EOnChange; end; @@ -184,7 +194,7 @@ TMemo = class(TEdit) fWantReturns: boolean; fWantTabs: boolean; procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; function SubProperty(const SubPropName: string): TPersistent; override; function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; @@ -192,6 +202,8 @@ TMemo = class(TEdit) constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; + property ScrollBars: TScrollStyle read fScrollBars write fScrollBars; // Run-time modification ignored; write present only for dynamical control creation purpose + property WordWrap: boolean read fWordWrap write fWordWrap; // Run-time modification ignored; write present only for dynamical control creation purpose property Lines: TMemoLines read fLines; property WantReturns: boolean read fWantReturns write fWantReturns; property WantTabs: boolean read fWantTabs write fWantTabs; @@ -203,7 +215,6 @@ TCheckBox = class(TWinControl) private fState: TCheckBoxState; fAllowGrayed: boolean; - fAlignment: TAlignment; // default = taRightJustify (taCenter not possible) fCreateFlags: cardinal; procedure SetChecked(const Value: boolean); function GetChecked(): boolean; @@ -212,21 +223,20 @@ TCheckBox = class(TWinControl) function GetState(): TCheckBoxState; protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; - procedure ComponentNotif(var Msg: TMessage); override; + function ComponentNotif(var Msg: TMessage): boolean; override; procedure AdjustTextSize(var Size: TSize); override; public constructor Create(AOwner: TComponent); override; property Checked: boolean read GetChecked write SetChecked; property State: TCheckBoxState read GetState write SetState; property AllowGrayed: boolean read fAllowGrayed write SetAllowGrayed; - property InitialAlignment: TAlignment read fAlignment write fAlignment; // (For FPC) end; TRadioButton = class(TCheckBox) //should be vice versa protected - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; function GetSpecTabStop(): boolean; override; public @@ -236,7 +246,7 @@ TRadioButton = class(TCheckBox) //should be vice versa TGroupBox = class(TWinControl) protected procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; function GetSpecTabStop(): boolean; override; procedure AdjustTextSize(var Size: TSize); override; public @@ -279,7 +289,7 @@ TCustomBox = class(TWinControl) function GetCount(): integer; virtual; procedure SetItemIndex(Value: integer); virtual; procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; function SubProperty(const SubPropName: string): TPersistent; override; public @@ -290,6 +300,7 @@ TCustomBox = class(TWinControl) property ItemCount: integer read GetCount; property ItemIndex: integer read fItemIndex write SetItemIndex; property ItemStrings: TStrings read GetItems write SetItems; + property Sorted: boolean read fSorted write fSorted; // Run-time modification ignored; write present only for dynamical control creation purpose end; TComboBoxStyle = @@ -312,16 +323,17 @@ TComboBox = class(TCustomBox) protected procedure ReadProperty(const PropName: string; Reader: TReader); override; procedure CreateHandle; override; - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; function GetText(): string; procedure SetText(const Value: string); function ColorForSubCont(SubContMsg: integer; SubConthWnd: THandle): boolean; override; - procedure ComponentNotif(var Msg: TMessage); override; + function ComponentNotif(var Msg: TMessage): boolean; override; function SpecialKeyProcess(var CharCode: Word): TKeyProcess; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SelectAll; + property Style: TComboBoxStyle read fStyle write fStyle; // Run-time modification ignored; write present only for dynamical control creation purpose property Text: string read GetText write SetText; property DroppedDown: boolean read GetDroppedDown write SetDroppedDown; property OnChange: TNotifyEvent read EOnChange write EOnChange; @@ -329,8 +341,8 @@ TComboBox = class(TCustomBox) TListBox = class(TCustomBox) protected - procedure CreateParams(var Params : TCreateParams); override; - procedure ComponentNotif(var Msg: TMessage); override; + procedure CreateParams(var Params: TCreateParams); override; + function ComponentNotif(var Msg: TMessage): boolean; override; public constructor Create(AOwner: TComponent); override; end; @@ -341,16 +353,16 @@ TListBox = class(TCustomBox) TStaticText = class(TWinControl) private fBorderStyle: TStaticBorderStyle; - fAlignment: TAlignment; protected - procedure CreateParams(var Params : TCreateParams); override; + procedure CreateParams(var Params: TCreateParams); override; procedure ReadProperty(const PropName: string; Reader: TReader); override; procedure AdjustTextSize(var Size: TSize); override; public constructor Create(AOwner: TComponent); override; + property BorderStyle: TStaticBorderStyle read fBorderStyle write fBorderStyle; // Run-time modification ignored; write present only for dynamical control creation purpose end; -{$ifndef LLCL_OPT_STDLABEL} +{$ifndef LLCL_OPT_STDLABEL} TLabel = class(TStaticText); {$endif} @@ -389,7 +401,7 @@ function LMessages_Dummy(const Msg: TLMCommand): boolean; { TButton } -constructor TButton.Create(AOwner:TComponent); +constructor TButton.Create(AOwner: TComponent); begin inherited; ATType := ATTButton; @@ -405,7 +417,7 @@ procedure TButton.CreateHandle; TPCustomForm(ParentForm).HandleDefButton := Handle; end; -procedure TButton.CreateParams(var Params : TCreateParams); +procedure TButton.CreateParams(var Params: TCreateParams); begin inherited; with Params do @@ -443,7 +455,7 @@ procedure TButton.AdjustTextSize(var Size: TSize); { TEdit } -constructor TEdit.Create(AOwner:TComponent); +constructor TEdit.Create(AOwner: TComponent); begin inherited; ATType := ATTEdit; @@ -459,7 +471,7 @@ procedure TEdit.CreateHandle; SetReadOnly(fReadOnly); end; -procedure TEdit.CreateParams(var Params : TCreateParams); +procedure TEdit.CreateParams(var Params: TCreateParams); const EAlignStyle: array[TAlignment] of cardinal =(ES_LEFT , ES_RIGHT, ES_CENTER); begin inherited; @@ -468,7 +480,7 @@ procedure TEdit.CreateParams(var Params : TCreateParams); if fPassWordChar='*' then fCreateFlags := fCreateFlags or ES_PASSWORD; end; - fCreateFlags := fCreateFlags or EAlignStyle[fAlignment]; + fCreateFlags := fCreateFlags or EAlignStyle[Alignment]; with Params do begin Style := Style or fCreateFlags; @@ -478,9 +490,9 @@ procedure TEdit.CreateParams(var Params : TCreateParams); end; // WM_COMMAND message coming from form -procedure TEdit.ComponentNotif(var Msg: TMessage); +function TEdit.ComponentNotif(var Msg: TMessage): boolean; begin - inherited; + result := inherited ComponentNotif(Msg); case TWMCommand(Msg).NotifyCode of EN_CHANGE: if fOnChangeOK and Assigned(EOnChange) then @@ -513,8 +525,8 @@ function TEdit.GetText(): string; end; procedure TEdit.ReadProperty(const PropName: string; Reader: TReader); -const Properties: array[0..3] of PChar = ( - 'OnChange', 'PasswordChar', 'ReadOnly', 'Alignment'); +const Properties: array[0..2] of PChar = ( + 'OnChange', 'PasswordChar', 'ReadOnly'); var Tmp: string; begin case StringIndex(PropName, Properties) of @@ -525,7 +537,6 @@ procedure TEdit.ReadProperty(const PropName: string; Reader: TReader); fPassWordChar := Tmp[1]; end; 2 : fReadOnly := Reader.BooleanProperty; - 3 : Reader.IdentProperty(fAlignment, TypeInfo(TAlignment)); else inherited; end; end; @@ -623,7 +634,7 @@ procedure TMemo.CreateHandle; SetText(fLines.Strings.Text); end; -procedure TMemo.CreateParams(var Params : TCreateParams); +procedure TMemo.CreateParams(var Params: TCreateParams); begin fCreateFlags := ES_MULTILINE or ES_WANTRETURN; case fScrollBars of @@ -672,11 +683,11 @@ destructor TMemo.Destroy; { TCheckBox } -constructor TCheckBox.Create(AOwner:TComponent); +constructor TCheckBox.Create(AOwner: TComponent); begin inherited; ATType := ATTCheckBox; - fAlignment := taRightJustify; + Alignment := taRightJustify; // default = taRightJustify (taCenter not possible) AutoSize := true; end; @@ -690,10 +701,10 @@ procedure TCheckBox.CreateHandle; CBAlignStyle: array[TAlignment] of cardinal = (BS_LEFTTEXT, 0, 0); CBGrayStyle: array[boolean] of cardinal = (BS_AUTOCHECKBOX, BS_AUTO3STATE); -procedure TCheckBox.CreateParams(var Params : TCreateParams); +procedure TCheckBox.CreateParams(var Params: TCreateParams); begin if fCreateFlags=0 then - fCreateFlags := CBGrayStyle[fAllowGrayed] or CBAlignStyle[fAlignment]; + fCreateFlags := CBGrayStyle[fAllowGrayed] or CBAlignStyle[Alignment]; inherited; with Params do begin @@ -713,8 +724,8 @@ function TCheckBox.GetState(): TCheckBoxState; end; procedure TCheckBox.ReadProperty(const PropName: string; Reader: TReader); -const Properties: array[0..3] of PChar = ( - 'Checked', 'Alignment', 'State', 'AllowGrayed'); +const Properties: array[0..2] of PChar = ( + 'Checked', 'State', 'AllowGrayed'); var b: boolean; begin case StringIndex(PropName, Properties) of @@ -723,20 +734,18 @@ procedure TCheckBox.ReadProperty(const PropName: string; Reader: TReader); if fState<>cbGrayed then fState := TCheckBoxState(b); end; - 1 : Reader.IdentProperty(fAlignment, TypeInfo(TAlignment)); - 2 : Reader.IdentProperty(fState, TypeInfo(TCheckBoxState)); - 3 : fAllowGrayed := Reader.BooleanProperty; + 1 : Reader.IdentProperty(fState, TypeInfo(TCheckBoxState)); + 2 : fAllowGrayed := Reader.BooleanProperty; else inherited; end; end; // Used internally to force check/uncheck (Null Msg) -procedure TCheckBox.ComponentNotif(var Msg: TMessage); +function TCheckBox.ComponentNotif(var Msg: TMessage): boolean; begin + result := inherited ComponentNotif(Msg); if Msg.Msg=0 then - Checked := (not Checked) - else - inherited; + Checked := (not Checked); end; procedure TCheckBox.AdjustTextSize(var Size: TSize); @@ -776,7 +785,7 @@ procedure TCheckBox.SetAllowGrayed(Value: boolean); { TRadioButton } -constructor TRadioButton.Create(AOwner:TComponent); +constructor TRadioButton.Create(AOwner: TComponent); begin inherited; ATType := ATTRadioButton; @@ -784,9 +793,9 @@ constructor TRadioButton.Create(AOwner:TComponent); AutoSize := true; end; -procedure TRadioButton.CreateParams(var Params : TCreateParams); +procedure TRadioButton.CreateParams(var Params: TCreateParams); begin - fCreateFlags := BS_RADIOBUTTON or CBAlignStyle[fAlignment]; + fCreateFlags := BS_RADIOBUTTON or CBAlignStyle[Alignment]; inherited; end; @@ -807,7 +816,7 @@ function TRadioButton.GetSpecTabStop(): boolean; { TGroupBox } -constructor TGroupBox.Create(AOwner:TComponent); +constructor TGroupBox.Create(AOwner: TComponent); begin inherited; ATType := ATTGroupBox; @@ -821,13 +830,12 @@ procedure TGroupBox.CreateHandle; CreateAllHandles; end; -procedure TGroupBox.CreateParams(var Params : TCreateParams); +procedure TGroupBox.CreateParams(var Params: TCreateParams); begin inherited; with Params do begin Style := Style or BS_GROUPBOX; - ExStyle := WS_EX_CONTROLPARENT; WinClassName := BUTTON_CTRLCLASS; end; end; @@ -842,7 +850,7 @@ procedure TGroupBox.AdjustTextSize(var Size: TSize); Inc(Size.cx, 19); Inc(Size.cy, 4); end; -{$ifdef LLCL_OPT_STDLABEL} +{$ifdef LLCL_OPT_STDLABEL} { TLabel } constructor TLabel.Create(AOwner: TComponent); @@ -854,11 +862,10 @@ constructor TLabel.Create(AOwner: TComponent); end; procedure TLabel.ReadProperty(const PropName: string; Reader: TReader); -const Properties: array[0..1] of PChar = ('Alignment', 'WordWrap'); +const Properties: array[0..0] of PChar = ('WordWrap'); begin case StringIndex(PropName, Properties) of - 0 : Reader.IdentProperty(fAlignment, TypeInfo(TAlignment)); - 1 : fWordWrap := Reader.BooleanProperty; + 0 : fWordWrap := Reader.BooleanProperty; else inherited; end; end; @@ -875,7 +882,7 @@ procedure TLabel.PaintText(AddFlags: cardinal; var R: TRect); const LAlignStyle: array[TAlignment] of cardinal =(DT_LEFT , DT_RIGHT, DT_CENTER); var fFlags: cardinal; begin - fFlags := DT_EXPANDTABS or LAlignStyle[fAlignment]; + fFlags := DT_EXPANDTABS or LAlignStyle[Alignment]; if fWordWrap then fFlags := fFlags or DT_WORDBREAK; with TPCanvas(Canvas) do begin @@ -954,9 +961,10 @@ procedure TBoxStrings.Clear; var s: string; begin fStrings.Clear; - s := ''; // (to avoid compilation warning) if fbox.ATType=ATTComboBox then - s := LLCLS_SendMessageGetText(fBox.Handle); + s := LLCLS_SendMessageGetText(fBox.Handle) + else + s := ''; // (to avoid compilation warning) LLCL_SendMessage(fBox.Handle, cardinal(fBox.fResetMsg), 0, 0); // LLCLS_SendMessageSetText not used here if fbox.ATType=ATTComboBox then LLCLS_SendMessageSetText(fBox.Handle, WM_SETTEXT, s); @@ -1006,7 +1014,7 @@ procedure TCustomBox.CreateHandle; SetItemIndex(fItemIndex); end; -procedure TCustomBox.CreateParams(var Params : TCreateParams); +procedure TCustomBox.CreateParams(var Params: TCreateParams); begin inherited; with Params do @@ -1174,7 +1182,7 @@ procedure TComboBox.CreateHandle; end; end; -procedure TComboBox.CreateParams(var Params : TCreateParams); +procedure TComboBox.CreateParams(var Params: TCreateParams); //TComboBoxStyle = (csDropDown, csSimple, csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable); const ComboBoxStyleFlag: array[TComboBoxStyle] of cardinal = (CBS_DROPDOWN, CBS_SIMPLE, CBS_DROPDOWNLIST, CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE); @@ -1229,8 +1237,12 @@ function TComboBox.IsListDroppedDown(): boolean; // For Edit sub control function TCombobox.ColorForSubCont(SubContMsg: integer; SubConthWnd: THandle): boolean; begin +{$IFDEF FPC} + result := ((SubContMsg=WM_CTLCOLOREDIT) and (SubConthWnd=fhWndItem)); // Only edit box +{$ELSE FPC} result := ((SubContMsg=WM_CTLCOLOREDIT) and (SubConthWnd=fhWndItem)) or ((SubContMsg=WM_CTLCOLORLISTBOX) and (SubConthWnd=fhWndList)); +{$ENDIF FPC} end; function TComboBox.GetText(): string; @@ -1270,9 +1282,9 @@ function TComboBox.SpecialKeyProcess(var CharCode: Word): TKeyProcess; end; // WM_COMMAND message coming from form -procedure TComboBox.ComponentNotif(var Msg: TMessage); +function TComboBox.ComponentNotif(var Msg: TMessage): boolean; begin - inherited; + result := inherited ComponentNotif(Msg); case TWMCommand(Msg).NotifyCode of CBN_SELCHANGE, CBN_EDITCHANGE: begin @@ -1304,7 +1316,7 @@ constructor TListBox.Create(AOwner: TComponent); ATType := ATTListBox; end; -procedure TListBox.CreateParams(var Params : TCreateParams); +procedure TListBox.CreateParams(var Params: TCreateParams); begin fCreateFlags := WS_VSCROLL or LBS_HASSTRINGS or LBS_NOINTEGRALHEIGHT or LBS_NOTIFY; fAddLineMsg := LB_ADDSTRING; @@ -1318,9 +1330,9 @@ procedure TListBox.CreateParams(var Params : TCreateParams); end; // WM_COMMAND message coming from form -procedure TListBox.ComponentNotif(var Msg: TMessage); +function TListBox.ComponentNotif(var Msg: TMessage): boolean; begin - inherited; + result := inherited ComponentNotif(Msg); case TWMCommand(Msg).NotifyCode of LBN_SELCHANGE: fItemIndex := LLCL_SendMessage(Handle, cardinal(fGetIndexMsg), 0, 0); @@ -1329,7 +1341,7 @@ procedure TListBox.ComponentNotif(var Msg: TMessage); { TStaticText } -constructor TStaticText.Create(AOwner:TComponent); +constructor TStaticText.Create(AOwner: TComponent); begin inherited; ATType := ATTStaticText; @@ -1340,16 +1352,16 @@ constructor TStaticText.Create(AOwner:TComponent); {$ENDIF} end; -procedure TStaticText.CreateParams(var Params : TCreateParams); +procedure TStaticText.CreateParams(var Params: TCreateParams); var stStyle: cardinal; begin inherited; case fBorderStyle of - sbsSingle : stStyle := WS_BORDER; - sbsSunKen : stStyle := SS_SUNKEN; - else stStyle := 0; + sbsSingle: stStyle := WS_BORDER; + sbsSunKen: stStyle := SS_SUNKEN; + else stStyle := 0; end; - case fAlignment of + case Alignment of taRightJustify: stStyle := stStyle or SS_RIGHT; taCenter: stStyle := stStyle or SS_CENTER; end; @@ -1361,12 +1373,11 @@ procedure TStaticText.CreateParams(var Params : TCreateParams); end; procedure TStaticText.ReadProperty(const PropName: string; Reader: TReader); -const Properties: array[0..1] of PChar = ( - 'BorderStyle', 'Alignment'); +const Properties: array[0..0] of PChar = ( + 'BorderStyle'); begin case StringIndex(PropName, Properties) of 0 : Reader.IdentProperty(fBorderStyle, TypeInfo(TStaticBorderStyle)); - 1 : Reader.IdentProperty(fAlignment, TypeInfo(TAlignment)); else inherited; end; end; diff --git a/sources/SysUtils.pas b/sources/SysUtils.pas index ad9810d..79e9378 100644 --- a/sources/SysUtils.pas +++ b/sources/SysUtils.pas @@ -12,19 +12,23 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: + * Some (irrelevant) Kylix code removed + * StrToInt64/StrToInt64Def/TryStrToInt64 added + * TryStrToDate/TryStrToTime added Version 1.00: - * FPC/Lazarus part doesn't use any asm code - * CheckWin32Version added - * Warning: Kylix compatibility broken + * FPC/Lazarus part doesn't use any asm code + * CheckWin32Version added + * Warning: Kylix compatibility broken } // Original notes from LVCL @@ -283,6 +287,9 @@ function IntToHex(Value: int64; Digits: integer): string; overload; function StrToInt(const S: string): integer; function StrToIntDef(const S: string; Default: integer): integer; function TryStrToInt(const S: string; out Value: integer): boolean; +function StrToInt64(const S: string): int64; +function StrToInt64Def(const S: string; Default: int64): int64; +function TryStrToInt64(const S: string; out Value: int64): boolean; function GUIDToString(const GUID: TGUID): string; {$if (not Defined(FPC)) or (not Defined(UNICODE))} // Delphi, or FPC/Lazarus non Unicode @@ -365,6 +372,8 @@ function TrySystemTimeToDateTime(const SystemTime: TSystemTime; out DateTime: T function DateTimeToStr(const DateTime: TDateTime): string; function DateToStr(const DateTime: TDateTime): string; function TimeToStr(const DateTime: TDateTime): string; +function TryStrToDate(const S: string; out Value: TDateTime): boolean; +function TryStrToTime(const S: string; out Value: TDateTime): boolean; function TryStrToDateTime(const S: string; out Value: TDateTime): boolean; function FileCreate(const FileName: {$IFDEF LLCL_FPC_UNISYS}unicodestring{$ELSE}string{$ENDIF}): THandle; {$IFDEF LLCL_FPC_UNISYS}overload;{$ENDIF} @@ -491,6 +500,9 @@ implementation const HexChars: array[0..15] of Char = '0123456789ABCDEF'; + SYSLLCL_TIME_SEP = ':'; + SYSLLCL_DATE_SEP = '/'; + SYSLLCL_DATETIME_SEP = ' '; {$IFNDEF FPC} // our customs SysUtils.pas (normal and LVCL) contains the same array @@ -529,7 +541,7 @@ procedure FindSearchRecUniToRaw(const F: TUnicodeSearchRec; var FF: TRawByteSear {$ifdef LLCL_OPT_EXCEPTIONS} {$IFDEF FPC} procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: pointer; FrameCount: longint; Frames: PPointer); forward; -procedure ErrorHandler(ErrorCode: integer; ErrorAddr, Frame : pointer); forward; +procedure ErrorHandler(ErrorCode: integer; ErrorAddr, Frame: pointer); forward; procedure AssertErrorHandler(const aMessage, aFilename: shortstring; aLineNumber: longint; aErrorAddr: pointer); forward; {$ELSE FPC} procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: pointer); far; forward; @@ -625,7 +637,7 @@ function Format(const sFormat: string; const Args: array of const): string; end; end; -function IntToStr(Value : integer): string; +function IntToStr(Value: integer): string; {$if Defined(UNICODE) or Defined(FPC)} begin Str(Value, result); @@ -1014,6 +1026,24 @@ function TryStrToInt(const S: string; out Value: integer): boolean; result := (E=0); end; +function StrToInt64(const S: string): int64; +begin + result := StrToInt64Def(S, 0); +end; + +function StrToInt64Def(const S: string; Default: int64): int64; +begin + if not TryStrToInt64(S, result) then + result := Default; +end; + +function TryStrToInt64(const S: string; out Value: int64): boolean; +var E: integer; +begin + Val(S, Value, E); + result := (E=0); +end; + function GUIDToString(const GUID: TGUID): string; procedure Write(P: PChar; B: PByteArray); var i: integer; @@ -2037,41 +2067,33 @@ function AnsiDequotedStr(const S: string; AQuote: Char): string; function AnsiCompareText(const S1, S2: string): integer; begin // (LVCL uses also SORT_STRINGSORT) result := {$IFDEF LLCL_FPC_SYSRTL}LLCLSys_CompareString{$ELSE}LLCLS_CompareString{$ENDIF} - (LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, length(S1), S2, length(S2)) - 2; + (LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, S2) - 2; end; function AnsiSameText(const S1, S2: string): boolean; begin - result := (AnsiCompareText(S1, S2)=0); + result := (AnsiCompareText(S1, S2)=0); end; function AnsiCompareStr(const S1, S2: string): integer; begin // (LVCL uses also SORT_STRINGSORT) result := {$IFDEF LLCL_FPC_SYSRTL}LLCLSys_CompareString{$ELSE}LLCLS_CompareString{$ENDIF} - (LOCALE_USER_DEFAULT, 0, S1, length(S1), S2, length(S2)) - 2; + (LOCALE_USER_DEFAULT, 0, S1, S2) - 2; end; function AnsiSameStr(const S1, S2: string): boolean; begin - result := (AnsiCompareStr(S1, S2)=0); + result := (AnsiCompareStr(S1, S2)=0); end; function AnsiUpperCase(const S: string): string; begin -{$ifdef MSWindows} result := {$IFDEF LLCL_FPC_SYSRTL}LLCLSys_CharUpperBuff{$ELSE}LLCLS_CharUpperBuff{$ENDIF}(S); -{$else} - result := WideUpperCase(S); -{$endif} end; function AnsiLowerCase(const S: string): string; begin -{$ifdef MSWindows} result := {$IFDEF LLCL_FPC_SYSRTL}LLCLSys_CharLowerBuff{$ELSE}LLCLS_CharLowerBuff{$ENDIF}(S); -{$else} - result := WideLowerCase(S); -{$endif} end; function WideCompareText(const S1, S2: widestring): integer; @@ -2081,7 +2103,7 @@ function WideCompareText(const S1, S2: widestring): integer; function WideSameText(const S1, S2: widestring): boolean; begin // (LVCL uses also SORT_STRINGSORT) - result := (WideCompareText(S1, S2)=0); + result := (WideCompareText(S1, S2)=0); end; function WideCompareStr(const S1, S2: widestring): integer; @@ -2091,36 +2113,24 @@ function WideCompareStr(const S1, S2: widestring): integer; function WideSameStr(const S1, S2: widestring): boolean; begin - result := (WideCompareStr(S1, S2)=0); + result := (WideCompareStr(S1, S2)=0); end; function WideUpperCase(const S: widestring): widestring; -{$ifdef MSWindows} var Len: cardinal; begin Len := length(S); SetString(result, PWideChar(S), Len); if Len > 0 then LLCL_CharUpperBuffW(pointer(result), Len); end; -{$else} -begin - result := WideUpperCase(S); -end; -{$endif} function WideLowerCase(const S: widestring): widestring; -{$ifdef MSWindows} var Len: cardinal; begin Len := length(S); SetString(result, PWideChar(S), Len); if Len > 0 then LLCL_CharLowerBuffW(pointer(result), Len); end; -{$else} -begin - result := WideLowerCase(S); -end; -{$endif} procedure DecodeDate({$IFDEF FPC}{$ELSE}const {$ENDIF}DateTime: TDateTime; var Year, Month, Day: word); var J: integer; @@ -2366,7 +2376,7 @@ function SysAddDatePlusTime(const BaseDate: TDateTime; const PlusTime: TDateTim if BaseDate>=0 then result := BaseDate + PlusTime else - result := BaseDate + PlusTime; + result := BaseDate - PlusTime; end; function SysCurrDT(WithDate, WithTime: boolean): TDateTime; @@ -2417,15 +2427,15 @@ function SysDTToStr(const DateTime: TDateTime; WithDate, WithTime: boolean): st result := ''; if WithDate then begin - DecodeDate(DateTime, Y,M,D); - result := result+Format('%.4d',[Y])+'/'+Format('%.2d',[M])+'/'+Format('%.2d',[D]); + DecodeDate(DateTime, Y, M, D); + result := result + Format('%.4d', [Y]) + SYSLLCL_DATE_SEP + Format('%.2d', [M]) + SYSLLCL_DATE_SEP + Format('%.2d', [D]); end; if WithDate and WithTime then - result := result+' '; + result := result + SYSLLCL_DATETIME_SEP; if WithTime then begin - DecodeTime(DateTime, H,MI,S,MS); - result := result+Format('%.2d',[H])+':'+Format('%.2d',[MI])+':'+Format('%.2d',[S]); + DecodeTime(DateTime, H, MI, S, MS); + result := result + Format('%.2d', [H]) + SYSLLCL_TIME_SEP + Format('%.2d', [MI]) + SYSLLCL_TIME_SEP + Format('%.2d', [S]); end; end; @@ -2481,26 +2491,45 @@ function TimeToStr(const DateTime: TDateTime): string; end; // Only for 'YYYY/MM/DD hh:mm:ss' (see Date/Time To Str functions) -function TryStrToDateTime(const S: string; out Value: TDateTime): boolean; -var Y,M,D, H,MI,SS: cardinal; + +function TryStrToDate(const S: string; out Value: TDateTime): boolean; +var Y, M, D: cardinal; begin - if length(S)<>19 then - begin - result := false; - exit; - end; + result := false; + if length(S)<>10 then exit; Y := ord(S[1])*1000+ord(S[2])*100+ord(S[3])*10+ord(S[4])-(48+480+4800+48000); M := ord(S[6])*10+ord(S[7])-(48+480); D := ord(S[9])*10+ord(S[10])-(48+480); - H := ord(S[12])*10+ord(S[13])-(48+480); - MI := ord(S[15])*10+ord(S[16])-(48+480); - SS := ord(S[18])*10+ord(S[19])-(48+480); - result := (Y<=2100) and (Y>=1980) and (M in [1..12]) and (D<=MonthDays[true][M]) and - (D<>0) and (H<=23) and (MI<=59) and (SS<=59); + // (Reduced checks on year) + result := (Y<=3000) and (Y>=1) and (M in [1..12]) and (D<=MonthDays[true][M]) and (D<>0); + if result then + Value := EncodeDate(Y, M, D); +end; + +function TryStrToTime(const S: string; out Value: TDateTime): boolean; +var HH, MM, SS: cardinal; +begin + result := false; + if length(S)<>8 then exit; + HH := ord(S[1])*10+ord(S[2])-(48+480); + MM := ord(S[4])*10+ord(S[5])-(48+480); + SS := ord(S[7])*10+ord(S[8])-(48+480); + result := (HH<=23) and (MM<=59) and (SS<=59); + if result then + Value := EncodeTime(HH, MM, SS, 0); +end; + +function TryStrToDateTime(const S: string; out Value: TDateTime): boolean; +var TimeValue: TDateTime; +begin + result := false; + if length(S)<>19 then exit; + result := TryStrToDate(Copy(S, 1, 10), Value); if result then begin - Value := EncodeDate(Y, M, D); - Value := SysAddDatePlusTime(Value, EncodeTime(H, MI, SS, 0)); + result := TryStrToTime(Copy(S, 12, 8), TimeValue); + if result then + SysAddDatePlusTime(Value, TimeValue); end; end; @@ -3571,7 +3600,7 @@ procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: pointer); far; end; {$IFDEF FPC} -procedure ErrorHandler(ErrorCode: integer; ErrorAddr, Frame : pointer); +procedure ErrorHandler(ErrorCode: integer; ErrorAddr, Frame: pointer); {$ELSE FPC} procedure ErrorHandler(ErrorCode: integer; ErrorAddr: pointer); {$ENDIF FPC} diff --git a/sources/Variants.pas b/sources/Variants.pas index 1982ba8..0957b59 100644 --- a/sources/Variants.pas +++ b/sources/Variants.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: Notes: diff --git a/sources/XPMan.pas b/sources/XPMan.pas index eb563b6..b03d588 100644 --- a/sources/XPMan.pas +++ b/sources/XPMan.pas @@ -12,15 +12,16 @@ License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at http://mozilla.org/MPL/2.0/. - This Source Code Form is “Incompatible With Secondary Licenses”, + This Source Code Form is "Incompatible With Secondary Licenses", as defined by the Mozilla Public License, v. 2.0. - Copyright (c) 2015 ChrisF + Copyright (c) 2015-2016 ChrisF Based upon the Very LIGHT VCL (LVCL): Copyright (c) 2008 Arnaud Bouchez - http://bouchez.info Portions Copyright (c) 2001 Paul Toth - http://tothpaul.free.fr + Version 1.01: Version 1.00: * File creation. * TXPManifest implemented