From 194923c172167eb3fc33807ec8009b255f86337e Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 09:10:06 +0000 Subject: Plugin is not adapted until someone can compile it and tell others how to do the same git-svn-id: http://svn.miranda-ng.org/main/trunk@1809 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- plugins/Chess4Net/lib/PNGImage/obj/adler32.obj | Bin 977 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/compress.obj | Bin 502 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/crc32.obj | Bin 10586 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/deflate.obj | Bin 8769 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/gzio.obj | Bin 5124 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/infback.obj | Bin 6913 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/inffast.obj | Bin 1568 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/inflate.obj | Bin 10546 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/inftrees.obj | Bin 1681 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/trees.obj | Bin 10932 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/uncompr.obj | Bin 440 -> 0 bytes plugins/Chess4Net/lib/PNGImage/obj/zutil.obj | Bin 747 -> 0 bytes plugins/Chess4Net/lib/PNGImage/pngextra.pas | 353 -- plugins/Chess4Net/lib/PNGImage/pngimage.pas | 5824 -------------------- plugins/Chess4Net/lib/PNGImage/pnglang.pas | 355 -- plugins/Chess4Net/lib/PNGImage/zlibpas.pas | 156 - .../TntUnicodeControls/Source/ActiveIMM_TLB.pas | 1374 ----- .../lib/TntUnicodeControls/Source/TntActnList.pas | 835 --- .../lib/TntUnicodeControls/Source/TntAxCtrls.pas | 191 - .../lib/TntUnicodeControls/Source/TntBandActn.pas | 92 - .../lib/TntUnicodeControls/Source/TntButtons.pas | 982 ---- .../lib/TntUnicodeControls/Source/TntCheckLst.pas | 184 - .../lib/TntUnicodeControls/Source/TntClasses.pas | 1780 ------ .../lib/TntUnicodeControls/Source/TntClipBrd.pas | 86 - .../lib/TntUnicodeControls/Source/TntComCtrls.pas | 5058 ----------------- .../lib/TntUnicodeControls/Source/TntCompilers.inc | 356 -- .../lib/TntUnicodeControls/Source/TntControls.pas | 1099 ---- .../lib/TntUnicodeControls/Source/TntDB.pas | 900 --- .../lib/TntUnicodeControls/Source/TntDBActns.pas | 594 -- .../TntUnicodeControls/Source/TntDBClientActns.pas | 197 - .../lib/TntUnicodeControls/Source/TntDBCtrls.pas | 2195 -------- .../lib/TntUnicodeControls/Source/TntDBGrids.pas | 1175 ---- .../lib/TntUnicodeControls/Source/TntDBLogDlg.dfm | 108 - .../lib/TntUnicodeControls/Source/TntDBLogDlg.pas | 133 - .../lib/TntUnicodeControls/Source/TntDialogs.pas | 981 ---- .../lib/TntUnicodeControls/Source/TntExtActns.pas | 1400 ----- .../lib/TntUnicodeControls/Source/TntExtCtrls.pas | 1062 ---- .../lib/TntUnicodeControls/Source/TntExtDlgs.pas | 317 -- .../lib/TntUnicodeControls/Source/TntFileCtrl.pas | 118 - .../Source/TntFormatStrUtils.pas | 503 -- .../lib/TntUnicodeControls/Source/TntForms.pas | 873 --- .../lib/TntUnicodeControls/Source/TntGraphics.pas | 142 - .../lib/TntUnicodeControls/Source/TntGrids.pas | 675 --- .../lib/TntUnicodeControls/Source/TntIniFiles.pas | 1011 ---- .../TntUnicodeControls/Source/TntIniFilesEx.pas | 205 - .../lib/TntUnicodeControls/Source/TntListActns.pas | 207 - .../lib/TntUnicodeControls/Source/TntMenus.pas | 1146 ---- .../lib/TntUnicodeControls/Source/TntRegistry.pas | 148 - .../lib/TntUnicodeControls/Source/TntStdActns.pas | 1922 ------- .../lib/TntUnicodeControls/Source/TntStdCtrls.pas | 3215 ----------- .../lib/TntUnicodeControls/Source/TntSysUtils.pas | 1699 ------ .../lib/TntUnicodeControls/Source/TntSystem.pas | 1384 ----- .../TntUnicodeControls/Source/TntWideStrUtils.pas | 451 -- .../TntUnicodeControls/Source/TntWideStrings.pas | 831 --- .../lib/TntUnicodeControls/Source/TntWindows.pas | 1452 ----- plugins/Chess4Net/lib/XIE/XIE.pas | 333 -- 56 files changed, 44102 deletions(-) delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/adler32.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/compress.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/crc32.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/deflate.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/gzio.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/infback.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/inffast.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/inflate.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/inftrees.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/trees.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/uncompr.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/obj/zutil.obj delete mode 100644 plugins/Chess4Net/lib/PNGImage/pngextra.pas delete mode 100644 plugins/Chess4Net/lib/PNGImage/pngimage.pas delete mode 100644 plugins/Chess4Net/lib/PNGImage/pnglang.pas delete mode 100644 plugins/Chess4Net/lib/PNGImage/zlibpas.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas delete mode 100644 plugins/Chess4Net/lib/XIE/XIE.pas (limited to 'plugins/Chess4Net/lib') diff --git a/plugins/Chess4Net/lib/PNGImage/obj/adler32.obj b/plugins/Chess4Net/lib/PNGImage/obj/adler32.obj deleted file mode 100644 index 84d2850efa..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/adler32.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/compress.obj b/plugins/Chess4Net/lib/PNGImage/obj/compress.obj deleted file mode 100644 index 90cf74f1e4..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/compress.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/crc32.obj b/plugins/Chess4Net/lib/PNGImage/obj/crc32.obj deleted file mode 100644 index ea14153d31..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/crc32.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/deflate.obj b/plugins/Chess4Net/lib/PNGImage/obj/deflate.obj deleted file mode 100644 index 3ffc8bcae9..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/deflate.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/gzio.obj b/plugins/Chess4Net/lib/PNGImage/obj/gzio.obj deleted file mode 100644 index ff94037b1e..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/gzio.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/infback.obj b/plugins/Chess4Net/lib/PNGImage/obj/infback.obj deleted file mode 100644 index 2114f10ad5..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/infback.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/inffast.obj b/plugins/Chess4Net/lib/PNGImage/obj/inffast.obj deleted file mode 100644 index c8f5b1f5e5..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/inffast.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/inflate.obj b/plugins/Chess4Net/lib/PNGImage/obj/inflate.obj deleted file mode 100644 index 4c53c01a93..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/inflate.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/inftrees.obj b/plugins/Chess4Net/lib/PNGImage/obj/inftrees.obj deleted file mode 100644 index c37455e249..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/inftrees.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/trees.obj b/plugins/Chess4Net/lib/PNGImage/obj/trees.obj deleted file mode 100644 index 98a6110b3f..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/trees.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/uncompr.obj b/plugins/Chess4Net/lib/PNGImage/obj/uncompr.obj deleted file mode 100644 index 12cd70b661..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/uncompr.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/obj/zutil.obj b/plugins/Chess4Net/lib/PNGImage/obj/zutil.obj deleted file mode 100644 index 9395409f01..0000000000 Binary files a/plugins/Chess4Net/lib/PNGImage/obj/zutil.obj and /dev/null differ diff --git a/plugins/Chess4Net/lib/PNGImage/pngextra.pas b/plugins/Chess4Net/lib/PNGImage/pngextra.pas deleted file mode 100644 index c219e7e22e..0000000000 --- a/plugins/Chess4Net/lib/PNGImage/pngextra.pas +++ /dev/null @@ -1,353 +0,0 @@ -unit pngextra; - -interface - -uses - Windows, Graphics, Messages, SysUtils, Classes, Controls, pngimage, Buttons, - ExtCtrls; - -type - TPNGButtonStyle = (pbsDefault, pbsFlat, pbsNoFrame); - TPNGButtonLayout = (pbsImageAbove, pbsImageBellow, pbsImageLeft, - pbsImageRight); - TPNGButtonState = (pbsNormal, pbsDown, pbsDisabled); - - TPNGButton = class(TGraphicControl) - private - {Holds the property values} - fButtonStyle: TPNGButtonStyle; - fMouseOverControl: Boolean; - FCaption: String; - FButtonLayout: TPNGButtonLayout; - FButtonState: TPNGButtonState; - FImageDown: TPNGObject; - fImageNormal: TPNGObject; - fImageDisabled: TPNGObject; - fImageOver: TPNGObject; - fOnMouseEnter, fOnMouseExit: TNotifyEvent; - {Procedures for setting the property values} - procedure SetButtonStyle(const Value: TPNGButtonStyle); - procedure SetCaption(const Value: String); - procedure SetButtonLayout(const Value: TPNGButtonLayout); - procedure SetButtonState(const Value: TPNGButtonState); - procedure SetImageNormal(const Value: TPNGObject); - procedure SetImageDown(const Value: TPNGObject); - procedure SetImageOver(const Value: TPNGObject); - published - {Published properties} - property Font; - property Visible; - property ButtonLayout: TPNGButtonLayout read FButtonLayout write SetButtonLayout; - property Caption: String read FCaption write SetCaption; - property ImageNormal: TPNGObject read fImageNormal write SetImageNormal; - property ImageDown: TPNGObject read FImageDown write SetImageDown; - property ImageOver: TPNGObject read FImageOver write SetImageOver; - property ButtonStyle: TPNGButtonStyle read fButtonStyle - write SetButtonStyle; - property Enabled; - property ParentShowHint; - property ShowHint; - {Default events} - property OnMouseDown; - property OnClick; - property OnMouseUp; - property OnMouseMove; - property OnDblClick; - property OnMouseEnter: TNotifyEvent read fOnMouseEnter write fOnMouseEnter; - property OnMouseExit: TNotifyEvent read fOnMouseExit write fOnMouseExit; - public - {Public properties} - property ButtonState: TPNGButtonState read FButtonState write SetButtonState; - protected - {Being painted} - procedure Paint; override; - {Clicked} - procedure Click; override; - {Mouse pressed} - procedure MouseDown(Button: TMouseButton; Shift: TShiftState; - X, Y: Integer); override; - procedure MouseUp(Button: TMouseButton; Shift: TShiftState; - X, Y: Integer); override; - procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; - {Mouse entering or leaving} - procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; - procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; - {Being enabled or disabled} - procedure CMEnabledChanged(var Message: TMessage); - message CM_ENABLEDCHANGED; - public - {Returns if the mouse is over the control} - property IsMouseOver: Boolean read fMouseOverControl; - {Constructor and destructor} - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - end; - -procedure Register; -procedure MakeImageHalfTransparent(Source, Dest: TPNGObject); - -implementation - -procedure Register; -begin - RegisterComponents('Samples', [TPNGButton]); -end; - -procedure MakeImageHalfTransparent(Source, Dest: TPNGObject); -var - i, j: Integer; -begin - Dest.Assign(Source); - Dest.CreateAlpha; - if (Dest.Header.ColorType <> COLOR_PALETTE) then - for j := 0 to Source.Height - 1 do - for i := 0 to Source.Width - 1 do - Dest.AlphaScanline[j]^[i] := Dest.AlphaScanline[j]^[i] div 3; -end; - -{TPNGButton implementation} - -{Being created} -constructor TPNGButton.Create(AOwner: TComponent); -begin - {Calls ancestor} - inherited Create(AOwner); - {Creates the TPNGObjects} - fImageNormal := TPNGObject.Create; - fImageDown := TPNGObject.Create; - fImageDisabled := TPNGObject.Create; - fImageOver := TPNGObject.Create; - {Initial properties} - ControlStyle := ControlStyle + [csCaptureMouse]; - SetBounds(Left, Top, 23, 23); - fMouseOverControl := False; - fButtonLayout := pbsImageAbove; - fButtonState := pbsNormal -end; - -destructor TPNGButton.Destroy; -begin - {Frees the TPNGObject} - fImageNormal.Free; - fImageDown.Free; - fImageDisabled.Free; - fImageOver.Free; - - {Calls ancestor} - inherited Destroy; -end; - -{Being enabled or disabled} -procedure TPNGButton.CMEnabledChanged(var Message: TMessage); -begin - if not Enabled then MakeImageHalfTransparent(fImageNormal, fImageDisabled); - if Enabled then ButtonState := pbsNormal else ButtonState := pbsDisabled -end; - -{Returns the largest number} -function Max(A, B: Integer): Integer; -begin - if A > B then Result := A else Result := B -end; - -{Button being painted} -procedure TPNGButton.Paint; -const - Slide: Array[false..true] of Integer = (0, 2); -var - Area: TRect; - TextSize, ImageSize: TSize; - TextPos, ImagePos: TPoint; - Image: TPNGObject; - Pushed: Boolean; -begin - {Prepares the canvas} - Canvas.Font.Assign(Font); - - {Determines if the button is pushed} - Pushed := (ButtonState = pbsDown) and IsMouseOver; - - {Determines the image to use} - if (Pushed) and not fImageDown.Empty then - Image := fImageDown - else if IsMouseOver and not fImageOver.Empty and Enabled then - Image := fImageOver - else if (ButtonState = pbsDisabled) and not fImageDisabled.Empty then - Image := fImageDisabled - else - Image := fImageNormal; - - {Get the elements size} - ImageSize.cx := Image.Width; - ImageSize.cy := Image.Height; - Area := ClientRect; - if Caption <> '' then - begin - TextSize := Canvas.TextExtent(Caption); - ImageSize.cy := ImageSize.Cy + 4; - end else FillChar(TextSize, SizeOf(TextSize), #0); - - {Set the elements position} - ImagePos.X := (Width - ImageSize.cx) div 2 + Slide[Pushed]; - TextPos.X := (Width - TextSize.cx) div 2 + Slide[Pushed]; - TextPos.Y := (Height - TextSize.cy) div 2; - ImagePos.Y := (Height - ImageSize.cy) div 2; - case ButtonLayout of - pbsImageAbove: begin - ImagePos.Y := (Height - ImageSize.cy - TextSize.cy) div 2; - TextPos.Y := ImagePos.Y + ImageSize.cy; - end; - pbsImageBellow: begin - TextPos.Y := (Height - ImageSize.cy - TextSize.cy) div 2; - ImagePos.Y := TextPos.Y + TextSize.cy; - end; - pbsImageLeft: begin - ImagePos.X := (Width - ImageSize.cx - TextSize.cx) div 2; - TextPos.X := ImagePos.X + ImageSize.cx + 5; - end; - pbsImageRight: begin - TextPos.X := (Width - ImageSize.cx - TextSize.cx) div 2;; - ImagePos.X := TextPos.X + TextSize.cx + 5; - end - end; - ImagePos.Y := ImagePos.Y + Slide[Pushed]; - TextPos.Y := TextPos.Y + Slide[Pushed]; - - {Draws the border} - if ButtonStyle = pbsFlat then - begin - if ButtonState <> pbsDisabled then - if (Pushed) then - Frame3D(Canvas, Area, clBtnShadow, clBtnHighlight, 1) - else if IsMouseOver or (ButtonState = pbsDown) then - Frame3D(Canvas, Area, clBtnHighlight, clBtnShadow, 1) - end - else if ButtonStyle = pbsDefault then - DrawButtonFace(Canvas, Area, 1, bsNew, TRUE, Pushed, FALSE); - - {Draws the elements} - Canvas.Brush.Style := bsClear; - Canvas.Draw(ImagePos.X, ImagePos.Y, Image); - if ButtonState = pbsDisabled then Canvas.Font.Color := clGrayText; - Canvas.TextRect(Area, TextPos.X, TextPos.Y, Caption) -end; - -{Changing the button Layout property} -procedure TPNGButton.SetButtonLayout(const Value: TPNGButtonLayout); -begin - FButtonLayout := Value; - Repaint -end; - -{Changing the button state property} -procedure TPNGButton.SetButtonState(const Value: TPNGButtonState); -begin - FButtonState := Value; - Repaint -end; - -{Changing the button style property} -procedure TPNGButton.SetButtonStyle(const Value: TPNGButtonStyle); -begin - fButtonStyle := Value; - Repaint -end; - -{Changing the caption property} -procedure TPNGButton.SetCaption(const Value: String); -begin - FCaption := Value; - Repaint -end; - -{Changing the image property} -procedure TPNGButton.SetImageNormal(const Value: TPNGObject); -begin - fImageNormal.Assign(Value); - MakeImageHalfTransparent(fImageNormal, fImageDisabled); - Repaint -end; - -{Setting the down image} -procedure TPNGButton.SetImageDown(const Value: TPNGObject); -begin - FImageDown.Assign(Value); - Repaint -end; - -{Setting the over image} -procedure TPNGButton.SetImageOver(const Value: TPNGObject); -begin - fImageOver.Assign(Value); - Repaint -end; - -{Mouse pressed} -procedure TPNGButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, - Y: Integer); -begin - {Changes the state and repaints} - if (ButtonState = pbsNormal) and (Button = mbLeft) then - ButtonState := pbsDown; - {Calls ancestor} - inherited -end; - -{Being clicked} -procedure TPNGButton.Click; -begin - if ButtonState = pbsDown then ButtonState := pbsNormal; - inherited Click; -end; - -{Mouse released} -procedure TPNGButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, - Y: Integer); -begin - {Changes the state and repaints} - if ButtonState = pbsDown then ButtonState := pbsNormal; - {Calls ancestor} - inherited -end; - -{Mouse moving over the control} -procedure TPNGButton.MouseMove(Shift: TShiftState; X, Y: Integer); -begin - {In case cursor is over the button} - if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) and - (fMouseOverControl = False) and (ButtonState <> pbsDown) then - begin - fMouseOverControl := True; - Repaint; - end; - - {Calls ancestor} - inherited; - -end; - -{Mouse is now over the control} -procedure TPNGButton.CMMouseEnter(var Message: TMessage); -begin - if Enabled then - begin - if Assigned(fOnMouseEnter) then fOnMouseEnter(Self); - fMouseOverControl := True; - Repaint - end -end; - -{Mouse has left the control} -procedure TPNGButton.CMMouseLeave(var Message: TMessage); -begin - if Enabled then - begin - if Assigned(fOnMouseExit) then FOnMouseExit(Self); - fMouseOverControl := False; - Repaint - end -end; - - - -end. diff --git a/plugins/Chess4Net/lib/PNGImage/pngimage.pas b/plugins/Chess4Net/lib/PNGImage/pngimage.pas deleted file mode 100644 index 320891d4d3..0000000000 --- a/plugins/Chess4Net/lib/PNGImage/pngimage.pas +++ /dev/null @@ -1,5824 +0,0 @@ -{Portable Network Graphics Delphi 1.564 (31 July 2006) } - -{This is a full, open sourced implementation of png in Delphi } -{It has native support for most of png features including the } -{partial transparency, gamma and more. } -{For the latest version, please be sure to check my website } -{http://pngdelphi.sourceforge.net } -{Gustavo Huffenbacher Daud (gustavo.daud@terra.com.br) } - - -{ - Version 1.564 - 2006-07-25 BUG 1 - There was one GDI Palette object leak - when assigning from other PNG (fixed) - BUG 2 - Loosing color information when assigning png - to bmp on lower screen depth system - BUG 3 - There was a bug in TStream.GetSize - (fixed thanks to Vladimir Panteleev) - IMPROVE 1 - When assigning png to bmp now alpha information - is drawn (simulated into a white background) - - Version 1.563 - 2006-07-25 BUG 1 - There was a memory bug in the main component - destructor (fixed thanks to Steven L Brenner) - BUG 2 - The packages name contained spaces which was - causing some strange bugs in Delphi - (fixed thanks to Martijn Saly) - BUG 3 - Lots of fixes when handling palettes - (bugs implemented in the last version) - Fixed thanks to Gabriel Corneanu!!! - BUG 4 - CreateAlpha was raising an error because it did - not resized the palette chunk it created; - Fixed thanks to Miha Sokolov - IMPROVE 1 - Renamed the pngzlib.pas unit to zlibpas.pas - as a tentative to all libraries use the same - shared zlib implementation and to avoid including - two or three times the same P-Code. - (Gabriel Corneanu idea) - - - - Version 1.561 - 2006-05-17 BUG 1 - There was a bug in the method that draws semi - transparent images (a memory leak). fixed. - - Version 1.56 - 2006-05-09 - IMPROVE 1 - Delphi standard TCanvas support is now implemented - IMPROVE 2 - The PNG files may now be resized and created from - scratch using CreateBlank, Resize, Width and Height - BUG 1 - Fixed some bugs on handling tRNS transparencies - BUG 2 - Fixed bugs related to palette handling - - Version 1.535 - 2006-04-21 - IMPROVE 1 - Now the library uses the latest ZLIB release (1.2.3) - (thanks to: Roberto Della Pasqua - http://www.dellapasqua.com/delphizlib/) - - Version 1.53 - 2006-04-14 - - BUG 1 - Remove transparency was not working for - RGB Alpha and Grayscale alpha. fixed - BUG 2 - There was a bug were compressed text chunks no keyword - name could not be read - IMPROVE 1 - Add classes and methods to work with the pHYs chunk - (including TPNGObject.DrawUsingPixelInformation) - IMPROVE 3 - Included a property Version to return the library - version - IMPROVE 4 - New polish translation (thanks to Piotr Domanski) - IMPROVE 5 - Now packages for delphi 5, 6, 7, 2005 and 2006 - - Also Martijn Saly (thany) made some improvements in the library: - IMPROVE 1 - SetPixel now works with grayscale - IMPROVE 2 - Palette property now can be written using a - windows handle - Thanks !! - - Version 1.5 - 2005-06-29 - Fixed a lot of bugs using tips from mails that I´ve - being receiving for some time - BUG 1 - Loosing palette when assigning to TBitmap. fixed - BUG 2 - SetPixels and GetPixels worked only with - parameters in range 0..255. fixed - BUG 3 - Force type address off using directive - BUG 4 - TChunkzTXt contained an error - BUG 5 - MaxIdatSize was not working correctly (fixed thanks - to Gabriel Corneanu - BUG 6 - Corrected german translation (thanks to Mael Horz) - And the following improvements: - IMPROVE 1 - Create ImageHandleValue properties as public in - TChunkIHDR to get access to this handle - IMPROVE 2 - Using SetStretchBltMode to improve stretch quality - IMPROVE 3 - Scale is now working for alpha transparent images - IMPROVE 4 - GammaTable propery is now public to support an - article in the help file - - Version 1.4361 - 2003-03-04 - Fixed important bug for simple transparency when using - RGB, Grayscale color modes - - Version 1.436 - 2003-03-04 - * NEW * Property Pixels for direct access to pixels - * IMPROVED * Palette property (TPngObject) (read only) - Slovenian traslation for the component (Miha Petelin) - Help file update (scanline article/png->jpg example) - - Version 1.435 - 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt) - * NEW * New compiler flags to store the extra 8 bits - from 16 bits samples (when saving it is ignored), the - extra data may be acessed using ExtraScanline property - * Fixed * a bug on tIMe chunk - French translation included (Thanks to IBE Software) - Bugs fixed - - Version 1.432 - 2002-08-24 - * NEW * A new method, CreateAlpha will transform the - current image into partial transparency. - Help file updated with a new article on how to handle - partial transparency. - - Version 1.431 - 2002-08-14 - Fixed and tested to work on: - C++ Builder 3 - C++ Builder 5 - Delphi 3 - There was an error when setting TransparentColor, fixed - New method, RemoveTransparency to remove image - BIT TRANSPARENCY - - Version 1.43 - 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3 - Implements mostly some things that were missing, - a few tweaks and fixes. - - Version 1.428 - 2002-07-24 - More minor fixes (thanks to Ian Boyd) - Bit transparency fixes - * NEW * Finally support to bit transparency - (palette / rgb / grayscale -> all) - - Version 1.427 - 2002-07-19 - Lots of bugs and leaks fixed - * NEW * method to easy adding text comments, AddtEXt - * NEW * property for setting bit transparency, - TransparentColor - - Version 1.426 - 2002-07-18 - Clipboard finally fixed and working - Changed UseDelphi trigger to UseDelphi - * NEW * Support for bit transparency bitmaps - when assigning from/to TBitmap objects - Altough it does not support drawing transparent - parts of bit transparency pngs (only partial) - it is closer than ever - - Version 1.425 - 2002-07-01 - Clipboard methods implemented - Lots of bugs fixed - - Version 1.424 - 2002-05-16 - Scanline and AlphaScanline are now working correctly. - New methods for handling the clipboard - - Version 1.423 - 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is - also supported using the tRNS chunk (for palette and - grayscaling). - New bug fixes (Peter Haas). - - Version 1.422 - 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips. - New translation for German (Peter Haas). - - Version 1.421 - 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security - fixes. - LoadFromResourceID and LoadFromResourceName added and - help file updated for that. - The resources strings are now located in pnglang.pas. - New translation for Brazilian Portuguese. - Bugs fixed. - - IMPORTANT: As always I´m looking for bugs on the library. If - anyone has found one, please send me an email and - I will fix asap. Thanks for all the help and ideas - I'm receiving so far.} - -{My email is : gustavo.daud@terra.com.br} -{Website link : http://pngdelphi.sourceforge.net} -{Gustavo Huffenbacher Daud} - -unit pngimage; - -interface - -{Triggers avaliable (edit the fields bellow)} -{$TYPEDADDRESS OFF} - -{$DEFINE UseDelphi} //Disable fat vcl units(perfect for small apps) -{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk -{$DEFINE CheckCRC} //Enables CRC checking -{$DEFINE RegisterGraphic} //Registers TPNGObject to use with TPicture -{$DEFINE PartialTransparentDraw} //Draws partial transparent images -{$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample -{$RANGECHECKS OFF} {$J+} - - - -uses - Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF}, - zlibpas, pnglang; - -const - LibraryVersion = '1.564'; - -{$IFNDEF UseDelphi} - const - soFromBeginning = 0; - soFromCurrent = 1; - soFromEnd = 2; -{$ENDIF} - -const - {ZLIB constants} - ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)', - 'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)', - 'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)', - 'need dictionary (2)'); - Z_NO_FLUSH = 0; - Z_FINISH = 4; - Z_STREAM_END = 1; - - {Avaliable PNG filters for mode 0} - FILTER_NONE = 0; - FILTER_SUB = 1; - FILTER_UP = 2; - FILTER_AVERAGE = 3; - FILTER_PAETH = 4; - - {Avaliable color modes for PNG} - COLOR_GRAYSCALE = 0; - COLOR_RGB = 2; - COLOR_PALETTE = 3; - COLOR_GRAYSCALEALPHA = 4; - COLOR_RGBALPHA = 6; - - -type - {$IFNDEF UseDelphi} - {Custom exception handler} - Exception = class(TObject) - constructor Create(Msg: String); - end; - ExceptClass = class of Exception; - TColor = ColorRef; - {$ENDIF} - - {Error types} - EPNGOutMemory = class(Exception); - EPngError = class(Exception); - EPngUnexpectedEnd = class(Exception); - EPngInvalidCRC = class(Exception); - EPngInvalidIHDR = class(Exception); - EPNGMissingMultipleIDAT = class(Exception); - EPNGZLIBError = class(Exception); - EPNGInvalidPalette = class(Exception); - EPNGInvalidFileHeader = class(Exception); - EPNGIHDRNotFirst = class(Exception); - EPNGNotExists = class(Exception); - EPNGSizeExceeds = class(Exception); - EPNGMissingPalette = class(Exception); - EPNGUnknownCriticalChunk = class(Exception); - EPNGUnknownCompression = class(Exception); - EPNGUnknownInterlace = class(Exception); - EPNGNoImageData = class(Exception); - EPNGCouldNotLoadResource = class(Exception); - EPNGCannotChangeTransparent = class(Exception); - EPNGHeaderNotPresent = class(Exception); - EPNGInvalidNewSize = class(Exception); - EPNGInvalidSpec = class(Exception); - -type - {Direct access to pixels using R,G,B} - TRGBLine = array[word] of TRGBTriple; - pRGBLine = ^TRGBLine; - - {Same as TBitmapInfo but with allocated space for} - {palette entries} - TMAXBITMAPINFO = packed record - bmiHeader: TBitmapInfoHeader; - bmiColors: packed array[0..255] of TRGBQuad; - end; - - {Transparency mode for pngs} - TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial); - {Pointer to a cardinal type} - pCardinal = ^Cardinal; - {Access to a rgb pixel} - pRGBPixel = ^TRGBPixel; - TRGBPixel = packed record - B, G, R: Byte; - end; - - {Pointer to an array of bytes type} - TByteArray = Array[Word] of Byte; - pByteArray = ^TByteArray; - - {Forward} - TPNGObject = class; - pPointerArray = ^TPointerArray; - TPointerArray = Array[Word] of Pointer; - - {Contains a list of objects} - TPNGPointerList = class - private - fOwner: TPNGObject; - fCount : Cardinal; - fMemory: pPointerArray; - function GetItem(Index: Cardinal): Pointer; - procedure SetItem(Index: Cardinal; const Value: Pointer); - protected - {Removes an item} - function Remove(Value: Pointer): Pointer; virtual; - {Inserts an item} - procedure Insert(Value: Pointer; Position: Cardinal); - {Add a new item} - procedure Add(Value: Pointer); - {Returns an item} - property Item[Index: Cardinal]: Pointer read GetItem write SetItem; - {Set the size of the list} - procedure SetSize(const Size: Cardinal); - {Returns owner} - property Owner: TPNGObject read fOwner; - public - {Returns number of items} - property Count: Cardinal read fCount write SetSize; - {Object being either created or destroyed} - constructor Create(AOwner: TPNGObject); - destructor Destroy; override; - end; - - {Forward declaration} - TChunk = class; - TChunkClass = class of TChunk; - - {Same as TPNGPointerList but providing typecasted values} - TPNGList = class(TPNGPointerList) - private - {Used with property Item} - function GetItem(Index: Cardinal): TChunk; - public - {Finds the first item with this class} - function FindChunk(ChunkClass: TChunkClass): TChunk; - {Removes an item} - procedure RemoveChunk(Chunk: TChunk); overload; - {Add a new chunk using the class from the parameter} - function Add(ChunkClass: TChunkClass): TChunk; - {Returns pointer to the first chunk of class} - function ItemFromClass(ChunkClass: TChunkClass): TChunk; - {Returns a chunk item from the list} - property Item[Index: Cardinal]: TChunk read GetItem; - end; - - {$IFNDEF UseDelphi} - {The STREAMs bellow are only needed in case delphi provided ones is not} - {avaliable (UseDelphi trigger not set)} - {Object becomes handles} - TCanvas = THandle; - TBitmap = HBitmap; - {Trick to work} - TPersistent = TObject; - - {Base class for all streams} - TStream = class - protected - {Returning/setting size} - function GetSize: Longint; virtual; - procedure SetSize(const Value: Longint); virtual; abstract; - {Returns/set position} - function GetPosition: Longint; virtual; - procedure SetPosition(const Value: Longint); virtual; - public - {Returns/sets current position} - property Position: Longint read GetPosition write SetPosition; - {Property returns/sets size} - property Size: Longint read GetSize write SetSize; - {Allows reading/writing data} - function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract; - function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract; - {Copies from another Stream} - function CopyFrom(Source: TStream; - Count: Cardinal): Cardinal; virtual; - {Seeks a stream position} - function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract; - end; - - {File stream modes} - TFileStreamMode = (fsmRead, fsmWrite, fsmCreate); - TFileStreamModeSet = set of TFileStreamMode; - - {File stream for reading from files} - TFileStream = class(TStream) - private - {Opened mode} - Filemode: TFileStreamModeSet; - {Handle} - fHandle: THandle; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Seeks a file position} - function Seek(Offset: Longint; Origin: Word): Longint; override; - {Reads/writes data from/to the file} - function Read(var Buffer; Count: Longint): Cardinal; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - {Stream being created and destroy} - constructor Create(Filename: String; Mode: TFileStreamModeSet); - destructor Destroy; override; - end; - - {Stream for reading from resources} - TResourceStream = class(TStream) - constructor Create(Instance: HInst; const ResName: String; ResType:PChar); - private - {Variables for reading} - Size: Integer; - Memory: Pointer; - Position: Integer; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Stream processing} - function Read(var Buffer; Count: Integer): Cardinal; override; - function Seek(Offset: Integer; Origin: Word): Longint; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - end; - {$ENDIF} - - {Forward} - TChunkIHDR = class; - TChunkpHYs = class; - {Interlace method} - TInterlaceMethod = (imNone, imAdam7); - {Compression level type} - TCompressionLevel = 0..9; - {Filters type} - TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth); - TFilters = set of TFilter; - - {Png implementation object} - TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} - protected - {Inverse gamma table values} - InverseGamma: Array[Byte] of Byte; - procedure InitializeGamma; - private - {Canvas} - {$IFDEF UseDelphi}fCanvas: TCanvas;{$ENDIF} - {Filters to test to encode} - fFilters: TFilters; - {Compression level for ZLIB} - fCompressionLevel: TCompressionLevel; - {Maximum size for IDAT chunks} - fMaxIdatSize: Integer; - {Returns if image is interlaced} - fInterlaceMethod: TInterlaceMethod; - {Chunks object} - fChunkList: TPngList; - {Clear all chunks in the list} - procedure ClearChunks; - {Returns if header is present} - function HeaderPresent: Boolean; - procedure GetPixelInfo(var LineSize, Offset: Cardinal); - {Returns linesize and byte offset for pixels} - procedure SetMaxIdatSize(const Value: Integer); - function GetAlphaScanline(const LineIndex: Integer): pByteArray; - function GetScanline(const LineIndex: Integer): Pointer; - {$IFDEF Store16bits} - function GetExtraScanline(const LineIndex: Integer): Pointer; - {$ENDIF} - function GetPixelInformation: TChunkpHYs; - function GetTransparencyMode: TPNGTransparencyMode; - function GetTransparentColor: TColor; - procedure SetTransparentColor(const Value: TColor); - {Returns the version} - function GetLibraryVersion: String; - protected - {Being created} - BeingCreated: Boolean; - {Returns / set the image palette} - function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} - procedure SetPalette(Value: HPALETTE); {$IFDEF UseDelphi}override;{$ENDIF} - procedure DoSetPalette(Value: HPALETTE; const UpdateColors: Boolean); - {Returns/sets image width and height} - function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF} - function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from another TPNGObject} - procedure AssignPNG(Source: TPNGObject); - {Returns if the image is empty} - function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} - {Used with property Header} - function GetHeader: TChunkIHDR; - {Draws using partial transparency} - procedure DrawPartialTrans(DC: HDC; Rect: TRect); - {$IFDEF UseDelphi} - {Returns if the image is transparent} - function GetTransparent: Boolean; override; - {$ENDIF} - {Returns a pixel} - function GetPixels(const X, Y: Integer): TColor; virtual; - procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual; - public - {Gamma table array} - GammaTable: Array[Byte] of Byte; - {Resizes the PNG image} - procedure Resize(const CX, CY: Integer); - {Generates alpha information} - procedure CreateAlpha; - {Removes the image transparency} - procedure RemoveTransparency; - {Transparent color} - property TransparentColor: TColor read GetTransparentColor write - SetTransparentColor; - {Add text chunk, TChunkTEXT, TChunkzTXT} - procedure AddtEXt(const Keyword, Text: String); - procedure AddzTXt(const Keyword, Text: String); - {$IFDEF UseDelphi} - {Saves to clipboard format (thanks to Antoine Pottern)} - procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; - var APalette: HPalette); override; - procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; - APalette: HPalette); override; - {$ENDIF} - {Calling errors} - procedure RaiseError(ExceptionClass: ExceptClass; Text: String); - {Returns a scanline from png} - property Scanline[const Index: Integer]: Pointer read GetScanline; - {$IFDEF Store16bits} - property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline; - {$ENDIF} - {Used to return pixel information} - function HasPixelInformation: Boolean; - property PixelInformation: TChunkpHYs read GetPixelInformation; - property AlphaScanline[const Index: Integer]: pByteArray read - GetAlphaScanline; - procedure DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); - - {Canvas} - {$IFDEF UseDelphi}property Canvas: TCanvas read fCanvas;{$ENDIF} - {Returns pointer to the header} - property Header: TChunkIHDR read GetHeader; - {Returns the transparency mode used by this png} - property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode; - {Assigns from another object} - procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns to another object} - procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from a windows bitmap handle} - procedure AssignHandle(Handle: HBitmap; Transparent: Boolean; - TransparentColor: ColorRef); - {Draws the image into a canvas} - procedure Draw(ACanvas: TCanvas; const Rect: TRect); - {$IFDEF UseDelphi}override;{$ENDIF} - {Width and height properties} - property Width: Integer read GetWidth; - property Height: Integer read GetHeight; - {Returns if the image is interlaced} - property InterlaceMethod: TInterlaceMethod read fInterlaceMethod - write fInterlaceMethod; - {Filters to test to encode} - property Filters: TFilters read fFilters write fFilters; - {Maximum size for IDAT chunks, default and minimum is 65536} - property MaxIdatSize: Integer read fMaxIdatSize write SetMaxIdatSize; - {Property to return if the image is empty or not} - property Empty: Boolean read GetEmpty; - {Compression level} - property CompressionLevel: TCompressionLevel read fCompressionLevel - write fCompressionLevel; - {Access to the chunk list} - property Chunks: TPngList read fChunkList; - {Object being created and destroyed} - constructor Create; {$IFDEF UseDelphi}override;{$ENDIF} - constructor CreateBlank(ColorType, Bitdepth: Cardinal; cx, cy: Integer); - destructor Destroy; override; - {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF} - {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF} - procedure LoadFromStream(Stream: TStream); - {$IFDEF UseDelphi}override;{$ENDIF} - procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} - {Loading the image from resources} - procedure LoadFromResourceName(Instance: HInst; const Name: String); - procedure LoadFromResourceID(Instance: HInst; ResID: Integer); - {Access to the png pixels} - property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels; - {Palette property} - {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette write - SetPalette;{$ENDIF} - {Returns the version} - property Version: String read GetLibraryVersion; - end; - - {Chunk name object} - TChunkName = Array[0..3] of Char; - - {Global chunk object} - TChunk = class - private - {Contains data} - fData: Pointer; - fDataSize: Cardinal; - {Stores owner} - fOwner: TPngObject; - {Stores the chunk name} - fName: TChunkName; - {Returns pointer to the TChunkIHDR} - function GetHeader: TChunkIHDR; - {Used with property index} - function GetIndex: Integer; - {Should return chunk class/name} - class function GetName: String; virtual; - {Returns the chunk name} - function GetChunkName: String; - public - {Returns index from list} - property Index: Integer read GetIndex; - {Returns pointer to the TChunkIHDR} - property Header: TChunkIHDR read GetHeader; - {Resize the data} - procedure ResizeData(const NewSize: Cardinal); - {Returns data and size} - property Data: Pointer read fData; - property DataSize: Cardinal read fDataSize; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); virtual; - {Returns owner} - property Owner: TPngObject read fOwner; - {Being destroyed/created} - constructor Create(Owner: TPngObject); virtual; - destructor Destroy; override; - {Returns chunk class/name} - property Name: String read GetChunkName; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; virtual; - {Saves the chunk to a stream} - function SaveData(Stream: TStream): Boolean; - function SaveToStream(Stream: TStream): Boolean; virtual; - end; - - {Chunk classes} - TChunkIEND = class(TChunk); {End chunk} - - {IHDR data} - pIHDRData = ^TIHDRData; - TIHDRData = packed record - Width, Height: Cardinal; - BitDepth, - ColorType, - CompressionMethod, - FilterMethod, - InterlaceMethod: Byte; - end; - - {Information header chunk} - TChunkIHDR = class(TChunk) - private - {Current image} - ImageHandle: HBitmap; - ImageDC: HDC; - ImagePalette: HPalette; - {Output windows bitmap} - HasPalette: Boolean; - BitmapInfo: TMaxBitmapInfo; - {Stores the image bytes} - {$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF} - ImageData: pointer; - ImageAlpha: Pointer; - - {Contains all the ihdr data} - IHDRData: TIHDRData; - protected - BytesPerRow: Integer; - {Creates a grayscale palette} - function CreateGrayscalePalette(Bitdepth: Integer): HPalette; - {Copies the palette to the Device Independent bitmap header} - procedure PaletteToDIB(Palette: HPalette); - {Resizes the image data to fill the color type, bit depth, } - {width and height parameters} - procedure PrepareImageData; - {Release allocated ImageData memory} - procedure FreeImageData; - public - {Access to ImageHandle} - property ImageHandleValue: HBitmap read ImageHandle; - {Properties} - property Width: Cardinal read IHDRData.Width write IHDRData.Width; - property Height: Cardinal read IHDRData.Height write IHDRData.Height; - property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth; - property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType; - property CompressionMethod: Byte read IHDRData.CompressionMethod - write IHDRData.CompressionMethod; - property FilterMethod: Byte read IHDRData.FilterMethod - write IHDRData.FilterMethod; - property InterlaceMethod: Byte read IHDRData.InterlaceMethod - write IHDRData.InterlaceMethod; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Destructor/constructor} - constructor Create(Owner: TPngObject); override; - destructor Destroy; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {pHYs chunk} - pUnitType = ^TUnitType; - TUnitType = (utUnknown, utMeter); - TChunkpHYs = class(TChunk) - private - fPPUnitX, fPPUnitY: Cardinal; - fUnit: TUnitType; - public - {Returns the properties} - property PPUnitX: Cardinal read fPPUnitX write fPPUnitX; - property PPUnitY: Cardinal read fPPUnitY write fPPUnitY; - property UnitType: TUnitType read fUnit write fUnit; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Gamma chunk} - TChunkgAMA = class(TChunk) - private - {Returns/sets the value for the gamma chunk} - function GetValue: Cardinal; - procedure SetValue(const Value: Cardinal); - public - {Returns/sets gamma value} - property Gamma: Cardinal read GetValue write SetValue; - {Loading the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Being created} - constructor Create(Owner: TPngObject); override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {ZLIB Decompression extra information} - TZStreamRec2 = packed record - {From ZLIB} - ZLIB: TZStreamRec; - {Additional info} - Data: Pointer; - fStream : TStream; - end; - - {Palette chunk} - TChunkPLTE = class(TChunk) - protected - {Number of items in the palette} - fCount: Integer; - private - {Contains the palette handle} - function GetPaletteItem(Index: Byte): TRGBQuad; - public - {Returns the color for each item in the palette} - property Item[Index: Byte]: TRGBQuad read GetPaletteItem; - {Returns the number of items in the palette} - property Count: Integer read fCount; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Transparency information} - TChunktRNS = class(TChunk) - private - fBitTransparency: Boolean; - function GetTransparentColor: ColorRef; - {Returns the transparent color} - procedure SetTransparentColor(const Value: ColorRef); - public - {Palette values for transparency} - PaletteValues: Array[Byte] of Byte; - {Returns if it uses bit transparency} - property BitTransparency: Boolean read fBitTransparency; - {Returns the transparent color} - property TransparentColor: ColorRef read GetTransparentColor write - SetTransparentColor; - {Loads/saves the chunk from/to a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Actual image information} - TChunkIDAT = class(TChunk) - private - {Holds another pointer to the TChunkIHDR} - Header: TChunkIHDR; - {Stores temporary image width and height} - ImageWidth, ImageHeight: Integer; - {Size in bytes of each line and offset} - Row_Bytes, Offset : Cardinal; - {Contains data for the lines} - Encode_Buffer: Array[0..5] of pByteArray; - Row_Buffer: Array[Boolean] of pByteArray; - {Variable to invert the Row_Buffer used} - RowUsed: Boolean; - {Ending position for the current IDAT chunk} - EndPos: Integer; - {Filter the current line} - procedure FilterRow; - {Filter to encode and returns the best filter} - function FilterToEncode: Byte; - {Reads ZLIB compressed data} - function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer; - {Compress and writes IDAT data} - procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - const Length: Cardinal); - procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2); - {Prepares the palette} - procedure PreparePalette; - protected - {Decode interlaced image} - procedure DecodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); - {Decode non interlaced imaged} - procedure DecodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; - var crcfile: Cardinal); - protected - {Encode non interlaced images} - procedure EncodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2); - {Encode interlaced images} - procedure EncodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2); - protected - {Memory copy methods to decode} - procedure CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - protected - {Memory copy methods to encode} - procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - public - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - - {Image last modification chunk} - TChunktIME = class(TChunk) - private - {Holds the variables} - fYear: Word; - fMonth, fDay, fHour, fMinute, fSecond: Byte; - public - {Returns/sets variables} - property Year: Word read fYear write fYear; - property Month: Byte read fMonth write fMonth; - property Day: Byte read fDay write fDay; - property Hour: Byte read fHour write fHour; - property Minute: Byte read fMinute write fMinute; - property Second: Byte read fSecond write fSecond; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Textual data} - TChunktEXt = class(TChunk) - private - fKeyword, fText: String; - public - {Keyword and text} - property Keyword: String read fKeyword write fKeyword; - property Text: String read fText write fText; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {zTXT chunk} - TChunkzTXt = class(TChunktEXt) - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - -{Here we test if it's c++ builder or delphi version 3 or less} -{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF} - - -{Registers a new chunk class} -procedure RegisterChunk(ChunkClass: TChunkClass); -{Calculates crc} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; - -implementation - -var - ChunkClasses: TPngPointerList; - {Table of CRCs of all 8-bit messages} - crc_table: Array[0..255] of Cardinal; - {Flag: has the table been computed? Initially false} - crc_table_computed: Boolean; - -{Draw transparent image using transparent color} -procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer; - var srcHeader: TBitmapInfoHeader; - srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF); -var - cColor: COLORREF; - bmAndBack, bmAndObject, bmAndMem: HBITMAP; - bmBackOld, bmObjectOld, bmMemOld: HBITMAP; - hdcMem, hdcBack, hdcObject, hdcTemp: HDC; - ptSize, orgSize: TPOINT; - OldBitmap, DrawBitmap: HBITMAP; -begin - hdcTemp := CreateCompatibleDC(dc); - {Select the bitmap} - DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^, - DIB_RGB_COLORS); - OldBitmap := SelectObject(hdcTemp, DrawBitmap); - - {Get sizes} - OrgSize.x := abs(srcHeader.biWidth); - OrgSize.y := abs(srcHeader.biHeight); - ptSize.x := Rect.Right - Rect.Left; // Get width of bitmap - ptSize.y := Rect.Bottom - Rect.Top; // Get height of bitmap - - {Create some DCs to hold temporary data} - hdcBack := CreateCompatibleDC(dc); - hdcObject := CreateCompatibleDC(dc); - hdcMem := CreateCompatibleDC(dc); - - // Create a bitmap for each DC. DCs are required for a number of - // GDI functions. - - // Monochrome DCs - bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - - bmAndMem := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y); - - // Each DC must select a bitmap object to store pixel data. - bmBackOld := SelectObject(hdcBack, bmAndBack); - bmObjectOld := SelectObject(hdcObject, bmAndObject); - bmMemOld := SelectObject(hdcMem, bmAndMem); - - // Set the background color of the source DC to the color. - // contained in the parts of the bitmap that should be transparent - cColor := SetBkColor(hdcTemp, cTransparentColor); - - // Create the object mask for the bitmap by performing a BitBlt - // from the source bitmap to a monochrome bitmap. - StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - orgSize.x, orgSize.y, SRCCOPY); - - // Set the background color of the source DC back to the original - // color. - SetBkColor(hdcTemp, cColor); - - // Create the inverse of the object mask. - BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, - NOTSRCCOPY); - - // Copy the background of the main DC to the destination. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top, - SRCCOPY); - - // Mask out the places where the bitmap will be placed. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND); - - // Mask out the transparent colored pixels on the bitmap. -// BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); - StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0, - PtSize.x, PtSize.y, SRCAND); - - // XOR the bitmap with the background on the destination DC. - StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - OrgSize.x, OrgSize.y, SRCPAINT); - - // Copy the destination to the screen. - BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0, - SRCCOPY); - - // Delete the memory bitmaps. - DeleteObject(SelectObject(hdcBack, bmBackOld)); - DeleteObject(SelectObject(hdcObject, bmObjectOld)); - DeleteObject(SelectObject(hdcMem, bmMemOld)); - DeleteObject(SelectObject(hdcTemp, OldBitmap)); - - // Delete the memory DCs. - DeleteDC(hdcMem); - DeleteDC(hdcBack); - DeleteDC(hdcObject); - DeleteDC(hdcTemp); -end; - -{Make the table for a fast CRC.} -procedure make_crc_table; -var - c: Cardinal; - n, k: Integer; -begin - - {fill the crc table} - for n := 0 to 255 do - begin - c := Cardinal(n); - for k := 0 to 7 do - begin - if Boolean(c and 1) then - c := $edb88320 xor (c shr 1) - else - c := c shr 1; - end; - crc_table[n] := c; - end; - - {The table has already being computated} - crc_table_computed := true; -end; - -{Update a running CRC with the bytes buf[0..len-1]--the CRC - should be initialized to all 1's, and the transmitted value - is the 1's complement of the final running CRC (see the - crc() routine below)).} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -var - c: Cardinal; - n: Integer; -begin - c := crc; - - {Create the crc table in case it has not being computed yet} - if not crc_table_computed then make_crc_table; - - {Update} - for n := 0 to len - 1 do - c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8); - - {Returns} - Result := c; -end; - -{$IFNDEF UseDelphi} - function FileExists(Filename: String): Boolean; - var - FindFile: THandle; - FindData: TWin32FindData; - begin - FindFile := FindFirstFile(PChar(Filename), FindData); - Result := FindFile <> INVALID_HANDLE_VALUE; - if Result then Windows.FindClose(FindFile); - end; - - -{$ENDIF} - -{$IFNDEF UseDelphi} - {Exception implementation} - constructor Exception.Create(Msg: String); - begin - end; -{$ENDIF} - -{Calculates the paeth predictor} -function PaethPredictor(a, b, c: Byte): Byte; -var - pa, pb, pc: Integer; -begin - { a = left, b = above, c = upper left } - pa := abs(b - c); { distances to a, b, c } - pb := abs(a - c); - pc := abs(a + b - c * 2); - - { return nearest of a, b, c, breaking ties in order a, b, c } - if (pa <= pb) and (pa <= pc) then - Result := a - else - if pb <= pc then - Result := b - else - Result := c; -end; - -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; -asm - bswap eax -end; -function ByteSwap16(inp:word): word; -asm - bswap eax - shr eax, 16 -end; - -{Calculates number of bytes for the number of pixels using the} -{color mode in the paramenter} -function BytesForPixels(const Pixels: Integer; const ColorType, - BitDepth: Byte): Integer; -begin - case ColorType of - {Palette and grayscale contains a single value, for palette} - {an value of size 2^bitdepth pointing to the palette index} - {and grayscale the value from 0 to 2^bitdepth with color intesity} - COLOR_GRAYSCALE, COLOR_PALETTE: - Result := (Pixels * BitDepth + 7) div 8; - {RGB contains 3 values R, G, B with size 2^bitdepth each} - COLOR_RGB: - Result := (Pixels * BitDepth * 3) div 8; - {Contains one value followed by alpha value booth size 2^bitdepth} - COLOR_GRAYSCALEALPHA: - Result := (Pixels * BitDepth * 2) div 8; - {Contains four values size 2^bitdepth, Red, Green, Blue and alpha} - COLOR_RGBALPHA: - Result := (Pixels * BitDepth * 4) div 8; - else - Result := 0; - end {case ColorType} -end; - -type - pChunkClassInfo = ^TChunkClassInfo; - TChunkClassInfo = record - ClassName: TChunkClass; - end; - -{Register a chunk type} -procedure RegisterChunk(ChunkClass: TChunkClass); -var - NewClass: pChunkClassInfo; -begin - {In case the list object has not being created yet} - if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil); - - {Add this new class} - new(NewClass); - NewClass^.ClassName := ChunkClass; - ChunkClasses.Add(NewClass); -end; - -{Free chunk class list} -procedure FreeChunkClassList; -var - i: Integer; -begin - if (ChunkClasses <> nil) then - begin - FOR i := 0 TO ChunkClasses.Count - 1 do - Dispose(pChunkClassInfo(ChunkClasses.Item[i])); - ChunkClasses.Free; - end; -end; - -{Registering of common chunk classes} -procedure RegisterCommonChunks; -begin - {Important chunks} - RegisterChunk(TChunkIEND); - RegisterChunk(TChunkIHDR); - RegisterChunk(TChunkIDAT); - RegisterChunk(TChunkPLTE); - RegisterChunk(TChunkgAMA); - RegisterChunk(TChunktRNS); - - {Not so important chunks} - RegisterChunk(TChunkpHYs); - RegisterChunk(TChunktIME); - RegisterChunk(TChunktEXt); - RegisterChunk(TChunkzTXt); -end; - -{Creates a new chunk of this class} -function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk; -var - i : Integer; - NewChunk: TChunkClass; -begin - {Looks for this chunk} - NewChunk := TChunk; {In case there is no registered class for this} - - {Looks for this class in all registered chunks} - if Assigned(ChunkClasses) then - FOR i := 0 TO ChunkClasses.Count - 1 DO - begin - if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then - begin - NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName; - break; - end; - end; - - {Returns chunk class} - Result := NewChunk.Create(Owner); - Result.fName := Name; -end; - -{ZLIB support} - -const - ZLIBAllocate = High(Word); - -{Initializes ZLIB for decompression} -function ZLIBInitInflate(Stream: TStream): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result do - begin - GetMem(Data, ZLIBAllocate); - fStream := Stream; - end; - - {Init decompression} - InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec)); -end; - -{Initializes ZLIB for compression} -function ZLIBInitDeflate(Stream: TStream; - Level: TCompressionlevel; Size: Cardinal): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result, ZLIB do - begin - GetMem(Data, Size); - fStream := Stream; - next_out := Data; - avail_out := Size; - end; - - {Inits compression} - deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec)); -end; - -{Terminates ZLIB for compression} -procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - DeflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Terminates ZLIB for decompression} -procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - InflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Decompresses ZLIB into a memory address} -function DecompressZLIB(const Input: Pointer; InputSize: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - InflateRet: Integer; -begin - with StreamRec do - begin - {Initializes} - Result := True; - OutputSize := 0; - - {Prepares the data to decompress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - InflateInit_(StreamRec, zlib_version, SIZEOF(TZStreamRec)); - next_in := Input; - avail_in := InputSize; - - {Decodes data} - repeat - {In case it needs an output buffer} - if (avail_out = 0) then - begin - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if (avail_out = 0)}; - - {Decompress and put in output} - InflateRet := inflate(StreamRec, 0); - if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then - begin - {Reallocates output buffer} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - {Copies the new data} - CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), - @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if InflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - InflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - until InflateRet = Z_STREAM_END; - - {Terminates decompression} - InflateEnd(StreamRec); - end {with StreamRec} - -end; - -{Compresses ZLIB into a memory address} -function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - DeflateRet: Integer; -begin - with StreamRec do - begin - Result := True; {By default returns TRUE as everything might have gone ok} - OutputSize := 0; {Initialize} - {Prepares the data to compress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - DeflateInit_(StreamRec, CompressionLevel,zlib_version, SIZEOF(TZStreamRec)); - - next_in := Input; - avail_in := InputSize; - - while avail_in > 0 do - begin - {When it needs new buffer to stores the compressed data} - if avail_out = 0 then - begin - {Restore buffer} - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if avail_out = 0}; - - {Compresses} - DeflateRet := deflate(StreamRec, Z_FINISH); - - if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then - begin - {Updates the output memory} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - - {Copies the new data} - CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), - @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if DeflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - DeflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - - end {while avail_in > 0}; - - {Finishes compressing} - DeflateEnd(StreamRec); - end {with StreamRec} - -end; - -{TPngPointerList implementation} - -{Object being created} -constructor TPngPointerList.Create(AOwner: TPNGObject); -begin - inherited Create; {Let ancestor work} - {Holds owner} - fOwner := AOwner; - {Memory pointer not being used yet} - fMemory := nil; - {No items yet} - fCount := 0; -end; - -{Removes value from the list} -function TPngPointerList.Remove(Value: Pointer): Pointer; -var - I, Position: Integer; -begin - {Gets item position} - Position := -1; - FOR I := 0 TO Count - 1 DO - if Value = Item[I] then Position := I; - {In case a match was found} - if Position >= 0 then - begin - Result := Item[Position]; {Returns pointer} - {Remove item and move memory} - Dec(fCount); - if Position < Integer(FCount) then - System.Move(fMemory^[Position + 1], fMemory^[Position], - (Integer(fCount) - Position) * SizeOf(Pointer)); - end {if Position >= 0} else Result := nil -end; - -{Add a new value in the list} -procedure TPngPointerList.Add(Value: Pointer); -begin - Count := Count + 1; - Item[Count - 1] := Value; -end; - - -{Object being destroyed} -destructor TPngPointerList.Destroy; -begin - {Release memory if needed} - if fMemory <> nil then - FreeMem(fMemory, fCount * sizeof(Pointer)); - - {Free things} - inherited Destroy; -end; - -{Returns one item from the list} -function TPngPointerList.GetItem(Index: Cardinal): Pointer; -begin - if (Index <= Count - 1) then - Result := fMemory[Index] - else - {In case it's out of bounds} - Result := nil; -end; - -{Inserts a new item in the list} -procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal); -begin - if (Position < Count) or (Count = 0) then - begin - {Increase item count} - SetSize(Count + 1); - {Move other pointers} - if Position < Count then - System.Move(fMemory^[Position], fMemory^[Position + 1], - (Count - Position - 1) * SizeOf(Pointer)); - {Sets item} - Item[Position] := Value; - end; -end; - -{Sets one item from the list} -procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer); -begin - {If index is in bounds, set value} - if (Index <= Count - 1) then - fMemory[Index] := Value -end; - -{This method resizes the list} -procedure TPngPointerList.SetSize(const Size: Cardinal); -begin - {Sets the size} - if (fMemory = nil) and (Size > 0) then - GetMem(fMemory, Size * SIZEOF(Pointer)) - else - if Size > 0 then {Only realloc if the new size is greater than 0} - ReallocMem(fMemory, Size * SIZEOF(Pointer)) - else - {In case user is resize to 0 items} - begin - FreeMem(fMemory); - fMemory := nil; - end; - {Update count} - fCount := Size; -end; - -{TPNGList implementation} - -{Finds the first chunk of this class} -function TPNGList.FindChunk(ChunkClass: TChunkClass): TChunk; -var - i: Integer; -begin - Result := nil; - for i := 0 to Count - 1 do - if Item[i] is ChunkClass then - begin - Result := Item[i]; - Break - end -end; - - -{Removes an item} -procedure TPNGList.RemoveChunk(Chunk: TChunk); -begin - Remove(Chunk); - Chunk.Free -end; - -{Add a new item} -function TPNGList.Add(ChunkClass: TChunkClass): TChunk; -var - IHDR: TChunkIHDR; - IEND: TChunkIEND; - - IDAT: TChunkIDAT; - PLTE: TChunkPLTE; -begin - Result := nil; {Default result} - {Adding these is not allowed} - if ((ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or - (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND)) and not - (Owner.BeingCreated) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {Two of these is not allowed} - else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or - ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) or - ((ChunkClass = TChunkpHYs) and (ItemFromClass(TChunkpHYs) <> nil)) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {There must have an IEND and IHDR chunk} - else if ((ItemFromClass(TChunkIEND) = nil) or - (ItemFromClass(TChunkIHDR) = nil)) and not Owner.BeingCreated then - fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText) - else - begin - {Get common chunks} - IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR; - IEND := ItemFromClass(TChunkIEND) as TChunkIEND; - {Create new chunk} - Result := ChunkClass.Create(Owner); - {Add to the list} - if (ChunkClass = TChunkgAMA) or (ChunkClass = TChunkpHYs) or - (ChunkClass = TChunkPLTE) then - Insert(Result, IHDR.Index + 1) - {Header and end} - else if (ChunkClass = TChunkIEND) then - Insert(Result, Count) - else if (ChunkClass = TChunkIHDR) then - Insert(Result, 0) - {Transparency chunk (fix by Ian Boyd)} - else if (ChunkClass = TChunktRNS) then - begin - {Transparecy chunk must be after PLTE; before IDAT} - IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT; - PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE; - - if Assigned(PLTE) then - Insert(Result, PLTE.Index + 1) - else if Assigned(IDAT) then - Insert(Result, IDAT.Index) - else - Insert(Result, IHDR.Index + 1) - end - else {All other chunks} - Insert(Result, IEND.Index); - end {if} -end; - -{Returns item from the list} -function TPNGList.GetItem(Index: Cardinal): TChunk; -begin - Result := inherited GetItem(Index); -end; - -{Returns first item from the list using the class from parameter} -function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk; -var - i: Integer; -begin - Result := nil; {Initial result} - FOR i := 0 TO Count - 1 DO - {Test if this item has the same class} - if Item[i] is ChunkClass then - begin - {Returns this item and exit} - Result := Item[i]; - break; - end {if} -end; - -{$IFNDEF UseDelphi} - - {TStream implementation} - - {Copies all from another stream} - function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal; - const - MaxBytes = $f000; - var - Buffer: PChar; - BufSize, N: Cardinal; - begin - {If count is zero, copy everything from Source} - if Count = 0 then - begin - Source.Seek(0, soFromBeginning); - Count := Source.Size; - end; - - Result := Count; {Returns the number of bytes readed} - {Allocates memory} - if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count; - GetMem(Buffer, BufSize); - - {Copy memory} - while Count > 0 do - begin - if Count > BufSize then N := BufSize else N := Count; - Source.Read(Buffer^, N); - Write(Buffer^, N); - dec(Count, N); - end; - - {Deallocates memory} - FreeMem(Buffer, BufSize); - end; - -{Set current stream position} -procedure TStream.SetPosition(const Value: Longint); -begin - Seek(Value, soFromBeginning); -end; - -{Returns position} -function TStream.GetPosition: Longint; -begin - Result := Seek(0, soFromCurrent); -end; - - {Returns stream size} -function TStream.GetSize: Longint; - var - Pos: Cardinal; - begin - Pos := Seek(0, soFromCurrent); - Result := Seek(0, soFromEnd); - Seek(Pos, soFromBeginning); - end; - - {TFileStream implementation} - - {Filestream object being created} - constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet); - {Makes file mode} - function OpenMode: DWORD; - begin - Result := 0; - if fsmRead in Mode then Result := GENERIC_READ; - if (fsmWrite in Mode) or (fsmCreate in Mode) then - Result := Result OR GENERIC_WRITE; - end; - const - IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS); - begin - {Call ancestor} - inherited Create; - - {Create handle} - fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or - FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0); - {Store mode} - FileMode := Mode; - end; - - {Filestream object being destroyed} - destructor TFileStream.Destroy; - begin - {Terminates file and close} - if FileMode = [fsmWrite] then - SetEndOfFile(fHandle); - CloseHandle(fHandle); - - {Call ancestor} - inherited Destroy; - end; - - {Writes data to the file} - function TFileStream.Write(const Buffer; Count: Longint): Cardinal; - begin - if not WriteFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Reads data from the file} - function TFileStream.Read(var Buffer; Count: Longint): Cardinal; - begin - if not ReadFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Seeks the file position} - function TFileStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - Result := SetFilePointer(fHandle, Offset, nil, Origin); - end; - - {Sets the size of the file} - procedure TFileStream.SetSize(const Value: Longint); - begin - Seek(Value, soFromBeginning); - SetEndOfFile(fHandle); - end; - - {TResourceStream implementation} - - {Creates the resource stream} - constructor TResourceStream.Create(Instance: HInst; const ResName: String; - ResType: PChar); - var - ResID: HRSRC; - ResGlobal: HGlobal; - begin - {Obtains the resource ID} - ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA); - if ResID = 0 then raise EPNGError.Create(''); - {Obtains memory and size} - ResGlobal := LoadResource(hInstance, ResID); - Size := SizeOfResource(hInstance, ResID); - Memory := LockResource(ResGlobal); - if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create(''); - end; - - - {Setting resource stream size is not supported} - procedure TResourceStream.SetSize(const Value: Integer); - begin - end; - - {Writing into a resource stream is not supported} - function TResourceStream.Write(const Buffer; Count: Integer): Cardinal; - begin - Result := 0; - end; - - {Reads data from the stream} - function TResourceStream.Read(var Buffer; Count: Integer): Cardinal; - begin - //Returns data - CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count); - //Update position - inc(Position, Count); - //Returns - Result := Count; - end; - - {Seeks data} - function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - {Move depending on the origin} - case Origin of - soFromBeginning: Position := Offset; - soFromCurrent: inc(Position, Offset); - soFromEnd: Position := Size + Offset; - end; - - {Returns the current position} - Result := Position; - end; - -{$ENDIF} - -{TChunk implementation} - -{Resizes the data} -procedure TChunk.ResizeData(const NewSize: Cardinal); -begin - fDataSize := NewSize; - ReallocMem(fData, NewSize + 1); -end; - -{Returns index from list} -function TChunk.GetIndex: Integer; -var - i: Integer; -begin - Result := -1; {Avoiding warnings} - {Searches in the list} - FOR i := 0 TO Owner.Chunks.Count - 1 DO - if Owner.Chunks.Item[i] = Self then - begin - {Found match} - Result := i; - exit; - end {for i} -end; - -{Returns pointer to the TChunkIHDR} -function TChunk.GetHeader: TChunkIHDR; -begin - Result := Owner.Chunks.Item[0] as TChunkIHDR; -end; - -{Assigns from another TChunk} -procedure TChunk.Assign(Source: TChunk); -begin - {Copy properties} - fName := Source.fName; - {Set data size and realloc} - ResizeData(Source.fDataSize); - - {Copy data (if there's any)} - if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize); -end; - -{Chunk being created} -constructor TChunk.Create(Owner: TPngObject); -var - ChunkName: String; -begin - {Ancestor create} - inherited Create; - - {If it's a registered class, set the chunk name based on the class} - {name. For instance, if the class name is TChunkgAMA, the GAMA part} - {will become the chunk name} - ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); - if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4); - - {Initialize data holder} - GetMem(fData, 1); - fDataSize := 0; - {Record owner} - fOwner := Owner; -end; - -{Chunk being destroyed} -destructor TChunk.Destroy; -begin - {Free data holder} - FreeMem(fData, fDataSize + 1); - {Let ancestor destroy} - inherited Destroy; -end; - -{Returns the chunk name 1} -function TChunk.GetChunkName: String; -begin - Result := fName -end; - -{Returns the chunk name 2} -class function TChunk.GetName: String; -begin - {For avoid writing GetName for each TChunk descendent, by default for} - {classes which don't declare GetName, it will look for the class name} - {to extract the chunk kind. Example, if the class name is TChunkIEND } - {this method extracts and returns IEND} - Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); -end; - -{Saves the data to the stream} -function TChunk.SaveData(Stream: TStream): Boolean; -var - ChunkSize, ChunkCRC: Cardinal; -begin - {First, write the size for the following data in the chunk} - ChunkSize := ByteSwap(DataSize); - Stream.Write(ChunkSize, 4); - {The chunk name} - Stream.Write(fName, 4); - {If there is data for the chunk, write it} - if DataSize > 0 then Stream.Write(Data^, DataSize); - {Calculates and write CRC} - ChunkCRC := update_crc($ffffffff, @fName[0], 4); - ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff); - Stream.Write(ChunkCRC, 4); - - {Returns that everything went ok} - Result := TRUE; -end; - -{Saves the chunk to the stream} -function TChunk.SaveToStream(Stream: TStream): Boolean; -begin - Result := SaveData(Stream) -end; - - -{Loads the chunk from a stream} -function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - CheckCRC: Cardinal; - {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF} -begin - {Copies data from source} - ResizeData(Size); - if Size > 0 then Stream.Read(fData^, Size); - {Reads CRC} - Stream.Read(CheckCRC, 4); - CheckCrc := ByteSwap(CheckCRC); - - {Check if crc readed is valid} - {$IFDEF CheckCRC} - RightCRC := update_crc($ffffffff, @ChunkName[0], 4); - RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff; - Result := RightCRC = CheckCrc; - - {Handle CRC error} - if not Result then - begin - {In case it coult not load chunk} - Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText); - exit; - end - {$ELSE}Result := TRUE; {$ENDIF} - -end; - -{TChunktIME implementation} - -{Chunk being loaded from a stream} -function TChunktIME.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Let ancestor load the data} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size <> 7) then exit; {Size must be 7} - - {Reads data} - fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^); - fMonth := pByte(Longint(Data) + 2)^; - fDay := pByte(Longint(Data) + 3)^; - fHour := pByte(Longint(Data) + 4)^; - fMinute := pByte(Longint(Data) + 5)^; - fSecond := pByte(Longint(Data) + 6)^; -end; - -{Assigns from another TChunk} -procedure TChunktIME.Assign(Source: TChunk); -begin - fYear := TChunktIME(Source).fYear; - fMonth := TChunktIME(Source).fMonth; - fDay := TChunktIME(Source).fDay; - fHour := TChunktIME(Source).fHour; - fMinute := TChunktIME(Source).fMinute; - fSecond := TChunktIME(Source).fSecond; -end; - -{Saving the chunk to a stream} -function TChunktIME.SaveToStream(Stream: TStream): Boolean; -begin - {Update data} - ResizeData(7); {Make sure the size is 7} - pWord(Data)^ := ByteSwap16(Year); - pByte(Longint(Data) + 2)^ := Month; - pByte(Longint(Data) + 3)^ := Day; - pByte(Longint(Data) + 4)^ := Hour; - pByte(Longint(Data) + 5)^ := Minute; - pByte(Longint(Data) + 6)^ := Second; - - {Let inherited save data} - Result := inherited SaveToStream(Stream); -end; - -{TChunkztXt implementation} - -{Loading the chunk from a stream} -function TChunkzTXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -var - ErrorOutput: String; - CompressionMethod: Byte; - Output: Pointer; - OutputSize: Integer; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 4) then exit; - fKeyword := PChar(Data); {Get keyword and compression method bellow} - if Longint(fKeyword) = 0 then - CompressionMethod := pByte(Data)^ - else - CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^; - fText := ''; - - {In case the compression is 0 (only one accepted by specs), reads it} - if CompressionMethod = 0 then - begin - Output := nil; - if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2), - Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then - begin - SetLength(fText, OutputSize); - CopyMemory(@fText[1], Output, OutputSize); - end {if DecompressZLIB(...}; - FreeMem(Output); - end {if CompressionMethod = 0} - -end; - -{Saving the chunk to a stream} -function TChunkztXt.SaveToStream(Stream: TStream): Boolean; -var - Output: Pointer; - OutputSize: Integer; - ErrorOutput: String; -begin - Output := nil; {Initializes output} - if fText = '' then fText := ' '; - - {Compresses the data} - if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output, - OutputSize, ErrorOutput) then - begin - {Size is length from keyword, plus a null character to divide} - {plus the compression method, plus the length of the text (zlib compressed)} - ResizeData(Length(fKeyword) + 2 + OutputSize); - - Fillchar(Data^, DataSize, #0); - {Copies the keyword data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - {Compression method 0 (inflate/deflate)} - pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0; - if OutputSize > 0 then - CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize); - - {Let ancestor calculate crc and save} - Result := SaveData(Stream); - end {if CompressZLIB(...} else Result := False; - - {Frees output} - if Output <> nil then FreeMem(Output) -end; - -{TChunktEXt implementation} - -{Assigns from another text chunk} -procedure TChunktEXt.Assign(Source: TChunk); -begin - fKeyword := TChunktEXt(Source).fKeyword; - fText := TChunktEXt(Source).fText; -end; - -{Loading the chunk from a stream} -function TChunktEXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 3) then exit; - {Get text} - fKeyword := PChar(Data); - SetLength(fText, Size - Length(fKeyword) - 1); - CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1), - Length(fText)); -end; - -{Saving the chunk to a stream} -function TChunktEXt.SaveToStream(Stream: TStream): Boolean; -begin - {Size is length from keyword, plus a null character to divide} - {plus the length of the text} - ResizeData(Length(fKeyword) + 1 + Length(fText)); - Fillchar(Data^, DataSize, #0); - {Copy data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - if Text <> '' then - CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1], - Length(Text)); - {Let ancestor calculate crc and save} - Result := inherited SaveToStream(Stream); -end; - - -{TChunkIHDR implementation} - -{Chunk being created} -constructor TChunkIHDR.Create(Owner: TPngObject); -begin - {Prepare pointers} - ImageHandle := 0; - ImagePalette := 0; - ImageDC := 0; - - {Call inherited} - inherited Create(Owner); -end; - -{Chunk being destroyed} -destructor TChunkIHDR.Destroy; -begin - {Free memory} - FreeImageData(); - - {Calls TChunk destroy} - inherited Destroy; -end; - -{Copies the palette} -procedure CopyPalette(Source: HPALETTE; Destination: HPALETTE); -var - PaletteSize: Integer; - Entries: Array[Byte] of TPaletteEntry; -begin - PaletteSize := 0; - if GetObject(Source, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; - if PaletteSize = 0 then Exit; - ResizePalette(Destination, PaletteSize); - GetPaletteEntries(Source, 0, PaletteSize, Entries); - SetPaletteEntries(Destination, 0, PaletteSize, Entries); -end; - -{Assigns from another IHDR chunk} -procedure TChunkIHDR.Assign(Source: TChunk); -begin - {Copy the IHDR data} - if Source is TChunkIHDR then - begin - {Copy IHDR values} - IHDRData := TChunkIHDR(Source).IHDRData; - - {Prepare to hold data by filling BitmapInfo structure and} - {resizing ImageData and ImageAlpha memory allocations} - PrepareImageData(); - - {Copy image data} - CopyMemory(ImageData, TChunkIHDR(Source).ImageData, - BytesPerRow * Integer(Height)); - CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha, - Integer(Width) * Integer(Height)); - - {Copy palette colors} - BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors; - {Copy palette also} - CopyPalette(TChunkIHDR(Source).ImagePalette, ImagePalette); - end - else - Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); -end; - -{Release allocated image data} -procedure TChunkIHDR.FreeImageData; -begin - {Free old image data} - if ImageHandle <> 0 then DeleteObject(ImageHandle); - if ImageDC <> 0 then DeleteDC(ImageDC); - if ImageAlpha <> nil then FreeMem(ImageAlpha); - if ImagePalette <> 0 then DeleteObject(ImagePalette); - {$IFDEF Store16bits} - if ExtraImageData <> nil then FreeMem(ExtraImageData); - {$ENDIF} - ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil; - ImagePalette := 0; ExtraImageData := nil; -end; - -{Chunk being loaded from a stream} -function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -begin - {Let TChunk load it} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result then Exit; - - {Now check values} - {Note: It's recommended by png specification to make sure that the size} - {must be 13 bytes to be valid, but some images with 14 bytes were found} - {which could be loaded by internet explorer and other tools} - if (fDataSize < SIZEOF(TIHdrData)) then - begin - {Ihdr must always have at least 13 bytes} - Result := False; - Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText); - exit; - end; - - {Everything ok, reads IHDR} - IHDRData := pIHDRData(fData)^; - IHDRData.Width := ByteSwap(IHDRData.Width); - IHDRData.Height := ByteSwap(IHDRData.Height); - - {The width and height must not be larger than 65535 pixels} - if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then - begin - Result := False; - Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText); - exit; - end {if IHDRData.Width > High(Word)}; - {Compression method must be 0 (inflate/deflate)} - if (IHDRData.CompressionMethod <> 0) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText); - exit; - end; - {Interlace must be either 0 (none) or 7 (adam7)} - if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText); - exit; - end; - - {Updates owner properties} - Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod); - - {Prepares data to hold image} - PrepareImageData(); -end; - -{Saving the IHDR chunk to a stream} -function TChunkIHDR.SaveToStream(Stream: TStream): Boolean; -begin - {Ignore 2 bits images} - if BitDepth = 2 then BitDepth := 4; - - {It needs to do is update the data with the IHDR data} - {structure containing the write values} - ResizeData(SizeOf(TIHDRData)); - pIHDRData(fData)^ := IHDRData; - {..byteswap 4 byte types} - pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width); - pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height); - {..update interlace method} - pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod); - {..and then let the ancestor SaveToStream do the hard work} - Result := inherited SaveToStream(Stream); -end; - -{Creates a grayscale palette} -function TChunkIHDR.CreateGrayscalePalette(Bitdepth: Integer): HPalette; -var - j: Integer; - palEntries: TMaxLogPalette; -begin - {Prepares and fills the strucutre} - if Bitdepth = 16 then Bitdepth := 8; - fillchar(palEntries, sizeof(palEntries), 0); - palEntries.palVersion := $300; - palEntries.palNumEntries := 1 shl Bitdepth; - {Fill it with grayscale colors} - for j := 0 to palEntries.palNumEntries - 1 do - begin - palEntries.palPalEntry[j].peRed := - fOwner.GammaTable[MulDiv(j, 255, palEntries.palNumEntries - 1)]; - palEntries.palPalEntry[j].peGreen := palEntries.palPalEntry[j].peRed; - palEntries.palPalEntry[j].peBlue := palEntries.palPalEntry[j].peRed; - end; - {Creates and returns the palette} - Result := CreatePalette(pLogPalette(@palEntries)^); -end; - -{Copies the palette to the Device Independent bitmap header} -procedure TChunkIHDR.PaletteToDIB(Palette: HPalette); -var - j: Integer; - palEntries: TMaxLogPalette; -begin - {Copy colors} - Fillchar(palEntries, sizeof(palEntries), #0); - BitmapInfo.bmiHeader.biClrUsed := GetPaletteEntries(Palette, 0, 256, palEntries.palPalEntry[0]); - for j := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do - begin - BitmapInfo.bmiColors[j].rgbBlue := palEntries.palPalEntry[j].peBlue; - BitmapInfo.bmiColors[j].rgbRed := palEntries.palPalEntry[j].peRed; - BitmapInfo.bmiColors[j].rgbGreen := palEntries.palPalEntry[j].peGreen; - end; -end; - -{Resizes the image data to fill the color type, bit depth, } -{width and height parameters} -procedure TChunkIHDR.PrepareImageData(); - {Set the bitmap info} - procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean); - begin - - {Copy if the bitmap contain palette entries} - HasPalette := Palette; - {Fill the strucutre} - with BitmapInfo.bmiHeader do - begin - biSize := sizeof(TBitmapInfoHeader); - biHeight := Height; - biWidth := Width; - biPlanes := 1; - biBitCount := BitDepth; - biCompression := BI_RGB; - end {with BitmapInfo.bmiHeader} - end; -begin - {Prepare bitmap info header} - Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0); - {Release old image data} - FreeImageData(); - - {Obtain number of bits for each pixel} - case ColorType of - COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA: - case BitDepth of - {These are supported by windows} - 1, 4, 8: SetInfo(BitDepth, TRUE); - {2 bits for each pixel is not supported by windows bitmap} - 2 : SetInfo(4, TRUE); - {Also 16 bits (2 bytes) for each pixel is not supported} - {and should be transormed into a 8 bit grayscale} - 16 : SetInfo(8, TRUE); - end; - {Only 1 byte (8 bits) is supported} - COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE); - end {case ColorType}; - {Number of bytes for each scanline} - BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31) - and not 31) div 8; - - {Build array for alpha information, if necessary} - if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - GetMem(ImageAlpha, Integer(Width) * Integer(Height)); - FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0); - end; - - {Build array for extra byte information} - {$IFDEF Store16bits} - if (BitDepth = 16) then - begin - GetMem(ExtraImageData, BytesPerRow * Integer(Height)); - FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0); - end; - {$ENDIF} - - {Creates the image to hold the data, CreateDIBSection does a better} - {work in allocating necessary memory} - ImageDC := CreateCompatibleDC(0); - {$IFDEF UseDelphi}Self.Owner.Canvas.Handle := ImageDC;{$ENDIF} - - {In case it is a palette image, create the palette} - if HasPalette then - begin - {Create a standard palette} - if ColorType = COLOR_PALETTE then - ImagePalette := CreateHalfTonePalette(ImageDC) - else - ImagePalette := CreateGrayscalePalette(Bitdepth); - ResizePalette(ImagePalette, 1 shl BitmapInfo.bmiHeader.biBitCount); - BitmapInfo.bmiHeader.biClrUsed := 1 shl BitmapInfo.bmiHeader.biBitCount; - SelectPalette(ImageDC, ImagePalette, False); - RealizePalette(ImageDC); - PaletteTODIB(ImagePalette); - end; - - {Create the device independent bitmap} - ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^, - DIB_RGB_COLORS, ImageData, 0, 0); - SelectObject(ImageDC, ImageHandle); - - {Build array and allocate bytes for each row} - fillchar(ImageData^, BytesPerRow * Integer(Height), 0); -end; - -{TChunktRNS implementation} - -{$IFNDEF UseDelphi} -function CompareMem(P1, P2: pByte; const Size: Integer): Boolean; -var i: Integer; -begin - Result := True; - for i := 1 to Size do - begin - if P1^ <> P2^ then Result := False; - inc(P1); inc(P2); - end {for i} -end; -{$ENDIF} - -{Sets the transpararent color} -procedure TChunktRNS.SetTransparentColor(const Value: ColorRef); -var - i: Byte; - LookColor: TRGBQuad; -begin - {Clears the palette values} - Fillchar(PaletteValues, SizeOf(PaletteValues), #0); - {Sets that it uses bit transparency} - fBitTransparency := True; - - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - begin - Self.ResizeData(2); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - end; - COLOR_RGB: - begin - Self.ResizeData(6); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value)); - pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value)); - end; - COLOR_PALETTE: - begin - {Creates a RGBQuad to search for the color} - LookColor.rgbRed := GetRValue(Value); - LookColor.rgbGreen := GetGValue(Value); - LookColor.rgbBlue := GetBValue(Value); - {Look in the table for the entry} - for i := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do - if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then - Break; - {Fill the transparency table} - Fillchar(PaletteValues, i, 255); - Self.ResizeData(i + 1) - - end - end {case / with}; - -end; - -{Returns the transparent color for the image} -function TChunktRNS.GetTransparentColor: ColorRef; -var - PaletteChunk: TChunkPLTE; - i: Integer; - Value: Byte; -begin - Result := 0; {Default: Unknown transparent color} - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - begin - Value := BitmapInfo.bmiColors[PaletteValues[1]].rgbRed; - Result := RGB(Value, Value, Value); - end; - COLOR_RGB: - Result := RGB(fOwner.GammaTable[PaletteValues[1]], - fOwner.GammaTable[PaletteValues[3]], - fOwner.GammaTable[PaletteValues[5]]); - COLOR_PALETTE: - begin - {Obtains the palette chunk} - PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE; - - {Looks for an entry with 0 transparency meaning that it is the} - {full transparent entry} - for i := 0 to Self.DataSize - 1 do - if PaletteValues[i] = 0 then - with PaletteChunk.GetPaletteItem(i) do - begin - Result := RGB(rgbRed, rgbGreen, rgbBlue); - break - end - end {COLOR_PALETTE} - end {case Header.ColorType}; -end; - -{Saving the chunk to a stream} -function TChunktRNS.SaveToStream(Stream: TStream): Boolean; -begin - {Copy palette into data buffer} - if DataSize <= 256 then - CopyMemory(fData, @PaletteValues[0], DataSize); - - Result := inherited SaveToStream(Stream); -end; - -{Assigns from another chunk} -procedure TChunktRNS.Assign(Source: TChunk); -begin - CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256); - fBitTransparency := TChunkTrns(Source).fBitTransparency; - inherited Assign(Source); -end; - -{Loads the chunk from a stream} -function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - i, Differ255: Integer; -begin - {Let inherited load} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - - if not Result then Exit; - - {Make sure size is correct} - if Size > 256 then Owner.RaiseError(EPNGInvalidPalette, - EPNGInvalidPaletteText); - - {The unset items should have value 255} - Fillchar(PaletteValues[0], 256, 255); - {Copy the other values} - CopyMemory(@PaletteValues[0], fData, Size); - - {Create the mask if needed} - case Header.ColorType of - {Mask for grayscale and RGB} - COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True; - COLOR_PALETTE: - begin - Differ255 := 0; {Count the entries with a value different from 255} - {Tests if it uses bit transparency} - for i := 0 to Size - 1 do - if PaletteValues[i] <> 255 then inc(Differ255); - - {If it has one value different from 255 it is a bit transparency} - fBitTransparency := (Differ255 = 1); - end {COLOR_PALETTE} - end {case Header.ColorType}; - -end; - -{Prepares the image palette} -procedure TChunkIDAT.PreparePalette; -var - Entries: Word; - j : Integer; - palEntries: TMaxLogPalette; -begin - {In case the image uses grayscale, build a grayscale palette} - with Header do - if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - {Calculate total number of palette entries} - Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount)); - Fillchar(palEntries, sizeof(palEntries), #0); - palEntries.palVersion := $300; - palEntries.palNumEntries := Entries; - - FOR j := 0 TO Entries - 1 DO - with palEntries.palPalEntry[j] do - begin - - {Calculate each palette entry} - peRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)]; - peGreen := peRed; - peBlue := peRed; - end {with BitmapInfo.bmiColors[j]}; - Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^)); - end {if ColorType = COLOR_GRAYSCALE..., with Header} -end; - -{Reads from ZLIB} -function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; - Buffer: Pointer; Count: Integer; var EndPos: Integer; - var crcfile: Cardinal): Integer; -var - ProcResult : Integer; - IDATHeader : Array[0..3] of char; - IDATCRC : Cardinal; -begin - {Uses internal record pointed by ZLIBStream to gather information} - with ZLIBStream, ZLIBStream.zlib do - begin - {Set the buffer the zlib will read into} - next_out := Buffer; - avail_out := Count; - - {Decode until it reach the Count variable} - while avail_out > 0 do - begin - {In case it needs more data and it's in the end of a IDAT chunk,} - {it means that there are more IDAT chunks} - if (fStream.Position = EndPos) and (avail_out > 0) and - (avail_in = 0) then - begin - {End this chunk by reading and testing the crc value} - fStream.Read(IDATCRC, 4); - - {$IFDEF CheckCRC} - if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then - begin - Result := -1; - Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText); - exit; - end; - {$ENDIF} - - {Start reading the next chunk} - fStream.Read(EndPos, 4); {Reads next chunk size} - fStream.Read(IDATHeader[0], 4); {Next chunk header} - {It must be a IDAT chunk since image data is required and PNG} - {specification says that multiple IDAT chunks must be consecutive} - if IDATHeader <> 'IDAT' then - begin - Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText); - result := -1; - exit; - end; - - {Calculate chunk name part of the crc} - {$IFDEF CheckCRC} - crcfile := update_crc($ffffffff, @IDATHeader[0], 4); - {$ENDIF} - EndPos := fStream.Position + ByteSwap(EndPos); - end; - - - {In case it needs compressed data to read from} - if avail_in = 0 then - begin - {In case it's trying to read more than it is avaliable} - if fStream.Position + ZLIBAllocate > EndPos then - avail_in := fStream.Read(Data^, EndPos - fStream.Position) - else - avail_in := fStream.Read(Data^, ZLIBAllocate); - {Update crc} - {$IFDEF CheckCRC} - crcfile := update_crc(crcfile, Data, avail_in); - {$ENDIF} - - {In case there is no more compressed data to read from} - if avail_in = 0 then - begin - Result := Count - avail_out; - Exit; - end; - - {Set next buffer to read and record current position} - next_in := Data; - - end {if avail_in = 0}; - - ProcResult := inflate(zlib, 0); - - {In case the result was not sucessfull} - if (ProcResult < 0) then - begin - Result := -1; - Owner.RaiseError(EPNGZLIBError, - EPNGZLIBErrorText + zliberrors[procresult]); - exit; - end; - - end {while avail_out > 0}; - - end {with}; - - {If everything gone ok, it returns the count bytes} - Result := Count; -end; - -{TChunkIDAT implementation} - -const - {Adam 7 interlacing values} - RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); - ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); - RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); - ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); - -{Copy interlaced images with 1 byte for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col * 3); - repeat - {Copy this row} - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - - {Move to next column} - inc(Src, 3); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy interlaced images with 2 bytes for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col * 3); - repeat - {Copy this row} - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {$IFDEF Store16bits} - {Copy extra pixel values} - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); - {$ENDIF} - - {Move to next column} - inc(Src, 6); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depths 1, 4 or 8} -procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -const - BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); - StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := StartBit[Header.BitDepth]; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or - ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth]) - shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8))); - - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, Header.BitDepth); - until CurBit < 0; - - {Move to next byte in source} - inc(Src); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depth 2} -procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + Col div 2); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) - shl (4 - (4 * Col) mod 8)); - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, 2); - until CurBit < 0; - - {Move to next byte in source} - inc(Src); - until Col >= ImageWidth; -end; - -{Copy ímages with grayscale using bit depth 2} -procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + Col div 2); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F) - shl (4 - (Col*4) mod 8)); - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, 2); - until CurBit < 0; - - {Move to next byte in source} - inc(Src); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using 2 bytes for each pixel} -procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col); - repeat - {Copy this row} - Dest^ := Src^; inc(Dest); - {$IFDEF Store16bits} - Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); - {$ENDIF} - - {Move to next column} - inc(Src, 2); - inc(Dest, ColumnIncrement[Pass] - 1); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Decodes interlaced RGB alpha with 1 byte for each sample} -procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col * 3); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row and alpha value} - Trans^ := pChar(Longint(Src) + 3)^; - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - - {Move to next column} - inc(Src, 4); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Decodes interlaced RGB alpha with 2 bytes for each sample} -procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col * 3); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row and alpha value} - Trans^ := pChar(Longint(Src) + 6)^; - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {$IFDEF Store16bits} - {Copy extra pixel values} - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); - {$ENDIF} - - {Move to next column} - inc(Src, 8); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Decodes 8 bit grayscale image followed by an alpha sample} -procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column, pointers to the data and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this grayscale value and alpha} - Dest^ := Src^; inc(Src); - Trans^ := Src^; inc(Src); - - {Move to next column} - inc(Dest, ColumnIncrement[Pass]); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Decodes 16 bit grayscale image followed by an alpha sample} -procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - Col: Integer; -begin - {Get first column, pointers to the data and enter in loop} - Col := ColumnStart[Pass]; - Dest := pChar(Longint(Dest) + Col); - Trans := pChar(Longint(Trans) + Col); - repeat - {$IFDEF Store16bits} - Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); - {$ENDIF} - {Copy this grayscale value and alpha, transforming 16 bits into 8} - Dest^ := Src^; inc(Src, 2); - Trans^ := Src^; inc(Src, 2); - - {Move to next column} - inc(Dest, ColumnIncrement[Pass]); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Decodes an interlaced image} -procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); -var - CurrentPass: Byte; - PixelsThisRow: Integer; - CurrentRow: Integer; - Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; - CopyProc: procedure(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; -begin - - CopyProc := nil; {Initialize} - {Determine method to copy the image data} - case Header.ColorType of - {R, G, B values for each pixel} - COLOR_RGB: - case Header.BitDepth of - 8: CopyProc := CopyInterlacedRGB8; - 16: CopyProc := CopyInterlacedRGB16; - end {case Header.BitDepth}; - {Palette} - COLOR_PALETTE, COLOR_GRAYSCALE: - case Header.BitDepth of - 1, 4, 8: CopyProc := CopyInterlacedPalette148; - 2 : if Header.ColorType = COLOR_PALETTE then - CopyProc := CopyInterlacedPalette2 - else - CopyProc := CopyInterlacedGray2; - 16 : CopyProc := CopyInterlacedGrayscale16; - end; - {RGB followed by alpha} - COLOR_RGBALPHA: - case Header.BitDepth of - 8: CopyProc := CopyInterlacedRGBAlpha8; - 16: CopyProc := CopyInterlacedRGBAlpha16; - end; - {Grayscale followed by alpha} - COLOR_GRAYSCALEALPHA: - case Header.BitDepth of - 8: CopyProc := CopyInterlacedGrayscaleAlpha8; - 16: CopyProc := CopyInterlacedGrayscaleAlpha16; - end; - end {case Header.ColorType}; - - {Adam7 method has 7 passes to make the final image} - FOR CurrentPass := 0 TO 6 DO - begin - {Calculates the number of pixels and bytes for this pass row} - PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] + - ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass]; - Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType, - Header.BitDepth); - {Clear buffer for this pass} - ZeroMemory(Row_Buffer[not RowUsed], Row_Bytes); - - {Get current row index} - CurrentRow := RowStart[CurrentPass]; - {Get a pointer to the current row image data} - Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow * - (ImageHeight - 1 - CurrentRow)); - Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow); - {$IFDEF Store16bits} - Extra := Ptr(Longint(Header.ExtraImageData) + Header.BytesPerRow * - (ImageHeight - 1 - CurrentRow)); - {$ENDIF} - - if Row_Bytes > 0 then {There must have bytes for this interlaced pass} - while CurrentRow < ImageHeight do - begin - {Reads this line and filter} - if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, - EndPos, CRCFile) = 0 then break; - - FilterRow; - {Copy image data} - - CopyProc(CurrentPass, @Row_Buffer[RowUsed][1], Data, Trans - {$IFDEF Store16bits}, Extra{$ENDIF}); - - {Use the other RowBuffer item} - RowUsed := not RowUsed; - - {Move to the next row} - inc(CurrentRow, RowIncrement[CurrentPass]); - {Move pointer to the next line} - dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow); - inc(Trans, RowIncrement[CurrentPass] * ImageWidth); - {$IFDEF Store16bits} - dec(Extra, RowIncrement[CurrentPass] * Header.BytesPerRow); - {$ENDIF} - end {while CurrentRow < ImageHeight}; - - end {FOR CurrentPass}; - -end; - -{Copy 8 bits RGB image} -procedure TChunkIDAT.CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Copy pixel values} - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {Move to next pixel} - inc(Src, 3); - end {for I} -end; - -{Copy 16 bits RGB image} -procedure TChunkIDAT.CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - //Since windows does not supports 2 bytes for - //each R, G, B value, the method will read only 1 byte from it - {Copy pixel values} - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {$IFDEF Store16bits} - {Copy extra pixel values} - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); - {$ENDIF} - - {Move to next pixel} - inc(Src, 6); - end {for I} -end; - -{Copy types using palettes (1, 4 or 8 bits per pixel)} -procedure TChunkIDAT.CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -begin - {It's simple as copying the data} - CopyMemory(Dest, Src, Row_Bytes); -end; - -{Copy grayscale types using 2 bits for each pixel} -procedure TChunkIDAT.CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - i: Integer; -begin - {2 bits is not supported, this routine will converted into 4 bits} - FOR i := 1 TO Row_Bytes do - begin - Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); - inc(Dest); - Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); - inc(Dest); - inc(Src); - end {FOR i} -end; - -{Copy types using palette with 2 bits for each pixel} -procedure TChunkIDAT.CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - i: Integer; -begin - {2 bits is not supported, this routine will converted into 4 bits} - FOR i := 1 TO Row_Bytes do - begin - Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); - inc(Dest); - Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); - inc(Dest); - inc(Src); - end {FOR i} -end; - -{Copy grayscale images with 16 bits} -procedure TChunkIDAT.CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Windows does not supports 16 bits for each pixel in grayscale} - {mode, so reduce to 8} - Dest^ := Src^; inc(Dest); - {$IFDEF Store16bits} - Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); - {$ENDIF} - - {Move to next pixel} - inc(Src, 2); - end {for I} -end; - -{Copy 8 bits per sample RGB images followed by an alpha byte} -procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - i: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Copy pixel values and transparency} - Trans^ := pChar(Longint(Src) + 3)^; - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {Move to next pixel} - inc(Src, 4); inc(Trans); - end {for I} -end; - -{Copy 16 bits RGB image with alpha using 2 bytes for each sample} -procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - //Copy rgb and alpha values (transforming from 16 bits to 8 bits) - {Copy pixel values} - Trans^ := pChar(Longint(Src) + 6)^; - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); - {$IFDEF Store16bits} - {Copy extra pixel values} - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); - {$ENDIF} - {Move to next pixel} - inc(Src, 8); inc(Trans); - end {for I} -end; - -{Copy 8 bits per sample grayscale followed by alpha} -procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Copy alpha value and then gray value} - Dest^ := Src^; inc(Src); - Trans^ := Src^; inc(Src); - inc(Dest); inc(Trans); - end; -end; - -{Copy 16 bits per sample grayscale followed by alpha} -procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Copy alpha value and then gray value} - {$IFDEF Store16bits} - Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); - {$ENDIF} - Dest^ := Src^; inc(Src, 2); - Trans^ := Src^; inc(Src, 2); - inc(Dest); inc(Trans); - end; -end; - -{Decode non interlaced image} -procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); -var - j: Cardinal; - Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; - CopyProc: procedure( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; -begin - CopyProc := nil; {Initialize} - {Determines the method to copy the image data} - case Header.ColorType of - {R, G, B values} - COLOR_RGB: - case Header.BitDepth of - 8: CopyProc := CopyNonInterlacedRGB8; - 16: CopyProc := CopyNonInterlacedRGB16; - end; - {Types using palettes} - COLOR_PALETTE, COLOR_GRAYSCALE: - case Header.BitDepth of - 1, 4, 8: CopyProc := CopyNonInterlacedPalette148; - 2 : if Header.ColorType = COLOR_PALETTE then - CopyProc := CopyNonInterlacedPalette2 - else - CopyProc := CopyNonInterlacedGray2; - 16 : CopyProc := CopyNonInterlacedGrayscale16; - end; - {R, G, B followed by alpha} - COLOR_RGBALPHA: - case Header.BitDepth of - 8 : CopyProc := CopyNonInterlacedRGBAlpha8; - 16 : CopyProc := CopyNonInterlacedRGBAlpha16; - end; - {Grayscale followed by alpha} - COLOR_GRAYSCALEALPHA: - case Header.BitDepth of - 8 : CopyProc := CopyNonInterlacedGrayscaleAlpha8; - 16 : CopyProc := CopyNonInterlacedGrayscaleAlpha16; - end; - end; - - {Get the image data pointer} - Longint(Data) := Longint(Header.ImageData) + - Header.BytesPerRow * (ImageHeight - 1); - Trans := Header.ImageAlpha; - {$IFDEF Store16bits} - Longint(Extra) := Longint(Header.ExtraImageData) + - Header.BytesPerRow * (ImageHeight - 1); - {$ENDIF} - {Reads each line} - FOR j := 0 to ImageHeight - 1 do - begin - {Read this line Row_Buffer[RowUsed][0] if the filter type for this line} - if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, EndPos, - CRCFile) = 0 then break; - - {Filter the current row} - FilterRow; - {Copies non interlaced row to image} - CopyProc(@Row_Buffer[RowUsed][1], Data, Trans{$IFDEF Store16bits}, Extra - {$ENDIF}); - - {Invert line used} - RowUsed := not RowUsed; - dec(Data, Header.BytesPerRow); - {$IFDEF Store16bits}dec(Extra, Header.BytesPerRow);{$ENDIF} - inc(Trans, ImageWidth); - end {for I}; - - -end; - -{Filter the current line} -procedure TChunkIDAT.FilterRow; -var - pp: Byte; - vv, left, above, aboveleft: Integer; - Col: Cardinal; -begin - {Test the filter} - case Row_Buffer[RowUsed]^[0] of - {No filtering for this line} - FILTER_NONE: begin end; - {AND 255 serves only to never let the result be larger than one byte} - {Sub filter} - FILTER_SUB: - FOR Col := Offset + 1 to Row_Bytes DO - Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + - Row_Buffer[RowUsed][Col - Offset]) and 255; - {Up filter} - FILTER_UP: - FOR Col := 1 to Row_Bytes DO - Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + - Row_Buffer[not RowUsed][Col]) and 255; - {Average filter} - FILTER_AVERAGE: - FOR Col := 1 to Row_Bytes DO - begin - {Obtains up and left pixels} - above := Row_Buffer[not RowUsed][Col]; - if col - 1 < Offset then - left := 0 - else - Left := Row_Buffer[RowUsed][Col - Offset]; - - {Calculates} - Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] + - (left + above) div 2) and 255; - end; - {Paeth filter} - FILTER_PAETH: - begin - {Initialize} - left := 0; - aboveleft := 0; - {Test each byte} - FOR Col := 1 to Row_Bytes DO - begin - {Obtains above pixel} - above := Row_Buffer[not RowUsed][Col]; - {Obtains left and top-left pixels} - if (col - 1 >= offset) Then - begin - left := row_buffer[RowUsed][col - offset]; - aboveleft := row_buffer[not RowUsed][col - offset]; - end; - - {Obtains current pixel and paeth predictor} - vv := row_buffer[RowUsed][Col]; - pp := PaethPredictor(left, above, aboveleft); - - {Calculates} - Row_Buffer[RowUsed][Col] := (pp + vv) and $FF; - end {for}; - end; - - end {case}; -end; - -{Reads the image data from the stream} -function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - ZLIBStream: TZStreamRec2; - CRCCheck, - CRCFile : Cardinal; -begin - {Get pointer to the header chunk} - Header := Owner.Chunks.Item[0] as TChunkIHDR; - {Build palette if necessary} - if Header.HasPalette then PreparePalette(); - - {Copy image width and height} - ImageWidth := Header.Width; - ImageHeight := Header.Height; - - {Initialize to calculate CRC} - {$IFDEF CheckCRC} - CRCFile := update_crc($ffffffff, @ChunkName[0], 4); - {$ENDIF} - - Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information} - ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression} - - {Calculate ending position for the current IDAT chunk} - EndPos := Stream.Position + Size; - - {Allocate memory} - GetMem(Row_Buffer[false], Row_Bytes + 1); - GetMem(Row_Buffer[true], Row_Bytes + 1); - ZeroMemory(Row_Buffer[false], Row_bytes + 1); - {Set the variable to alternate the Row_Buffer item to use} - RowUsed := TRUE; - - {Call special methods for the different interlace methods} - case Owner.InterlaceMethod of - imNone: DecodeNonInterlaced(stream, ZLIBStream, Size, crcfile); - imAdam7: DecodeInterlacedAdam7(stream, ZLIBStream, size, crcfile); - end; - - {Free memory} - ZLIBTerminateInflate(ZLIBStream); {Terminates decompression} - FreeMem(Row_Buffer[False], Row_Bytes + 1); - FreeMem(Row_Buffer[True], Row_Bytes + 1); - - {Now checks CRC} - Stream.Read(CRCCheck, 4); - {$IFDEF CheckCRC} - CRCFile := CRCFile xor $ffffffff; - CRCCheck := ByteSwap(CRCCheck); - Result := CRCCheck = CRCFile; - - {Handle CRC error} - if not Result then - begin - {In case it coult not load chunk} - Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText); - exit; - end; - {$ELSE}Result := TRUE; {$ENDIF} -end; - -const - IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T'); - BUFFER = 5; - -{Saves the IDAT chunk to a stream} -function TChunkIDAT.SaveToStream(Stream: TStream): Boolean; -var - ZLIBStream : TZStreamRec2; -begin - {Get pointer to the header chunk} - Header := Owner.Chunks.Item[0] as TChunkIHDR; - {Copy image width and height} - ImageWidth := Header.Width; - ImageHeight := Header.Height; - Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information} - - {Allocate memory} - GetMem(Encode_Buffer[BUFFER], Row_Bytes); - ZeroMemory(Encode_Buffer[BUFFER], Row_Bytes); - {Allocate buffers for the filters selected} - {Filter none will always be calculated to the other filters to work} - GetMem(Encode_Buffer[FILTER_NONE], Row_Bytes); - ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes); - if pfSub in Owner.Filters then - GetMem(Encode_Buffer[FILTER_SUB], Row_Bytes); - if pfUp in Owner.Filters then - GetMem(Encode_Buffer[FILTER_UP], Row_Bytes); - if pfAverage in Owner.Filters then - GetMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes); - if pfPaeth in Owner.Filters then - GetMem(Encode_Buffer[FILTER_PAETH], Row_Bytes); - - {Initialize ZLIB} - ZLIBStream := ZLIBInitDeflate(Stream, Owner.fCompressionLevel, - Owner.MaxIdatSize); - {Write data depending on the interlace method} - case Owner.InterlaceMethod of - imNone: EncodeNonInterlaced(stream, ZLIBStream); - imAdam7: EncodeInterlacedAdam7(stream, ZLIBStream); - end; - {Terminates ZLIB} - ZLIBTerminateDeflate(ZLIBStream); - - {Release allocated memory} - FreeMem(Encode_Buffer[BUFFER], Row_Bytes); - FreeMem(Encode_Buffer[FILTER_NONE], Row_Bytes); - if pfSub in Owner.Filters then - FreeMem(Encode_Buffer[FILTER_SUB], Row_Bytes); - if pfUp in Owner.Filters then - FreeMem(Encode_Buffer[FILTER_UP], Row_Bytes); - if pfAverage in Owner.Filters then - FreeMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes); - if pfPaeth in Owner.Filters then - FreeMem(Encode_Buffer[FILTER_PAETH], Row_Bytes); - - {Everything went ok} - Result := True; -end; - -{Writes the IDAT using the settings} -procedure WriteIDAT(Stream: TStream; Data: Pointer; const Length: Cardinal); -var - ChunkLen, CRC: Cardinal; -begin - {Writes IDAT header} - ChunkLen := ByteSwap(Length); - Stream.Write(ChunkLen, 4); {Chunk length} - Stream.Write(IDATHeader[0], 4); {Idat header} - CRC := update_crc($ffffffff, @IDATHeader[0], 4); {Crc part for header} - - {Writes IDAT data and calculates CRC for data} - Stream.Write(Data^, Length); - CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff); - {Writes final CRC} - Stream.Write(CRC, 4); -end; - -{Compress and writes IDAT chunk data} -procedure TChunkIDAT.IDATZlibWrite(var ZLIBStream: TZStreamRec2; - Buffer: Pointer; const Length: Cardinal); -begin - with ZLIBStream, ZLIBStream.ZLIB do - begin - {Set data to be compressed} - next_in := Buffer; - avail_in := Length; - - {Compress all the data avaliable to compress} - while avail_in > 0 do - begin - deflate(ZLIB, Z_NO_FLUSH); - - {The whole buffer was used, save data to stream and restore buffer} - if avail_out = 0 then - begin - {Writes this IDAT chunk} - WriteIDAT(fStream, Data, Owner.MaxIdatSize); - - {Restore buffer} - next_out := Data; - avail_out := Owner.MaxIdatSize; - end {if avail_out = 0}; - - end {while avail_in}; - - end {with ZLIBStream, ZLIBStream.ZLIB} -end; - -{Finishes compressing data to write IDAT chunk} -procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2); -begin - with ZLIBStream, ZLIBStream.ZLIB do - begin - {Set data to be compressed} - next_in := nil; - avail_in := 0; - - while deflate(ZLIB,Z_FINISH) <> Z_STREAM_END do - begin - {Writes this IDAT chunk} - WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out); - {Re-update buffer} - next_out := Data; - avail_out := Owner.MaxIdatSize; - end; - - if avail_out < Owner.MaxIdatSize then - {Writes final IDAT} - WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out); - - end {with ZLIBStream, ZLIBStream.ZLIB}; -end; - -{Copy memory to encode RGB image with 1 byte for each color sample} -procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - {Copy pixel values} - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); - {Move to next pixel} - inc(Src, 3); - end {for I} -end; - -{Copy memory to encode RGB images with 16 bits for each color sample} -procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word) - //for sample - {Copy pixel values} - pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2); - pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2); - pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2); - {Move to next pixel} - inc(Src, 3); - end {for I} - -end; - -{Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)} -procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); -begin - {It's simple as copying the data} - CopyMemory(Dest, Src, Row_Bytes); -end; - -{Copy memory to encode grayscale images with 2 bytes for each sample} -procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); -var - I: Integer; -begin - FOR I := 1 TO ImageWidth DO - begin - //Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word) - //for sample - pWORD(Dest)^ := pByte(Longint(Src))^; inc(Dest, 2); - {Move to next pixel} - inc(Src); - end {for I} -end; - -{Encode images using RGB followed by an alpha value using 1 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); -var - i: Integer; -begin - {Copy the data to the destination, including data from Trans pointer} - FOR i := 1 TO ImageWidth do - begin - Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest); - Dest^ := Trans^; inc(Dest); - inc(Src, 3); inc(Trans); - end {for i}; -end; - -{Encode images using RGB followed by an alpha value using 2 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); -var - i: Integer; -begin - {Copy the data to the destination, including data from Trans pointer} - FOR i := 1 TO ImageWidth do - begin - pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest, 2); - pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest, 2); - pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest, 2); - pWord(Dest)^ := PByte(Longint(Trans) )^; inc(Dest, 2); - inc(Src, 3); inc(Trans); - end {for i}; -end; - -{Encode grayscale images followed by an alpha value using 1 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans: pChar); -var - i: Integer; -begin - {Copy the data to the destination, including data from Trans pointer} - FOR i := 1 TO ImageWidth do - begin - Dest^ := Src^; inc(Dest); - Dest^ := Trans^; inc(Dest); - inc(Src); inc(Trans); - end {for i}; -end; - -{Encode grayscale images followed by an alpha value using 2 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans: pChar); -var - i: Integer; -begin - {Copy the data to the destination, including data from Trans pointer} - FOR i := 1 TO ImageWidth do - begin - pWord(Dest)^ := pByte(Src)^; inc(Dest, 2); - pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); - inc(Src); inc(Trans); - end {for i}; -end; - -{Encode non interlaced images} -procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2); -var - {Current line} - j: Cardinal; - {Pointers to image data} - Data, Trans: PChar; - {Filter used for this line} - Filter: Byte; - {Method which will copy the data into the buffer} - CopyProc: procedure(Src, Dest, Trans: pChar) of object; -begin - CopyProc := nil; {Initialize to avoid warnings} - {Defines the method to copy the data to the buffer depending on} - {the image parameters} - case Header.ColorType of - {R, G, B values} - COLOR_RGB: - case Header.BitDepth of - 8: CopyProc := EncodeNonInterlacedRGB8; - 16: CopyProc := EncodeNonInterlacedRGB16; - end; - {Palette and grayscale values} - COLOR_GRAYSCALE, COLOR_PALETTE: - case Header.BitDepth of - 1, 4, 8: CopyProc := EncodeNonInterlacedPalette148; - 16: CopyProc := EncodeNonInterlacedGrayscale16; - end; - {RGB with a following alpha value} - COLOR_RGBALPHA: - case Header.BitDepth of - 8: CopyProc := EncodeNonInterlacedRGBAlpha8; - 16: CopyProc := EncodeNonInterlacedRGBAlpha16; - end; - {Grayscale images followed by an alpha} - COLOR_GRAYSCALEALPHA: - case Header.BitDepth of - 8: CopyProc := EncodeNonInterlacedGrayscaleAlpha8; - 16: CopyProc := EncodeNonInterlacedGrayscaleAlpha16; - end; - end {case Header.ColorType}; - - {Get the image data pointer} - Longint(Data) := Longint(Header.ImageData) + - Header.BytesPerRow * (ImageHeight - 1); - Trans := Header.ImageAlpha; - - {Writes each line} - FOR j := 0 to ImageHeight - 1 do - begin - {Copy data into buffer} - CopyProc(Data, @Encode_Buffer[BUFFER][0], Trans); - {Filter data} - Filter := FilterToEncode; - - {Compress data} - IDATZlibWrite(ZLIBStream, @Filter, 1); - IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes); - - {Adjust pointers to the actual image data} - dec(Data, Header.BytesPerRow); - inc(Trans, ImageWidth); - end; - - {Compress and finishes copying the remaining data} - FinishIDATZlib(ZLIBStream); -end; - -{Copy memory to encode interlaced images using RGB value with 1 byte for} -{each color sample} -procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col * 3); - repeat - {Copy this row} - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); - - {Move to next column} - inc(Src, ColumnIncrement[Pass] * 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy memory to encode interlaced RGB images with 2 bytes each color sample} -procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col * 3); - repeat - {Copy this row} - pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2); - pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2); - pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2); - - {Move to next column} - inc(Src, ColumnIncrement[Pass] * 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy memory to encode interlaced images using palettes using bit depths} -{1, 4, 8 (each pixel in the image)} -procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pChar); -const - BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); - StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); -var - CurBit, Col: Integer; - Src2: PChar; -begin - {Clean the line} - fillchar(Dest^, Row_Bytes, #0); - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - with Header.BitmapInfo.bmiHeader do - repeat - {Copy data} - CurBit := StartBit[biBitCount]; - repeat - {Adjust pointer to pixel byte bounds} - Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8); - {Copy data} - Byte(Dest^) := Byte(Dest^) or - (((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col) - mod 8))) and (BitTable[biBitCount])) shl CurBit; - - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, biBitCount); - until CurBit < 0; - - {Move to next byte in source} - inc(Dest); - until Col >= ImageWidth; -end; - -{Copy to encode interlaced grayscale images using 16 bits for each sample} -procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col); - repeat - {Copy this row} - pWord(Dest)^ := Byte(Src^); inc(Dest, 2); - - {Move to next column} - inc(Src, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy to encode interlaced rgb images followed by an alpha value, all using} -{one byte for each sample} -procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col * 3); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row} - Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); - Dest^ := Trans^; inc(Dest); - - {Move to next column} - inc(Src, ColumnIncrement[Pass] * 3); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy to encode interlaced rgb images followed by an alpha value, all using} -{two byte for each sample} -procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col * 3); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row} - pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2); - pWord(Dest)^ := pByte(Longint(Src) + 1)^; inc(Dest, 2); - pWord(Dest)^ := pByte(Longint(Src) )^; inc(Dest, 2); - pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); - - {Move to next column} - inc(Src, ColumnIncrement[Pass] * 3); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy to encode grayscale interlaced images followed by an alpha value, all} -{using 1 byte for each sample} -procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row} - Dest^ := Src^; inc(Dest); - Dest^ := Trans^; inc(Dest); - - {Move to next column} - inc(Src, ColumnIncrement[Pass]); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy to encode grayscale interlaced images followed by an alpha value, all} -{using 2 bytes for each sample} -procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); -var - Col: Integer; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - Src := pChar(Longint(Src) + Col); - Trans := pChar(Longint(Trans) + Col); - repeat - {Copy this row} - pWord(Dest)^ := pByte(Src)^; inc(Dest, 2); - pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2); - - {Move to next column} - inc(Src, ColumnIncrement[Pass]); - inc(Trans, ColumnIncrement[Pass]); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Encode interlaced images} -procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2); -var - CurrentPass, Filter: Byte; - PixelsThisRow: Integer; - CurrentRow : Integer; - Trans, Data: pChar; - CopyProc: procedure(const Pass: Byte; - Src, Dest, Trans: pChar) of object; -begin - CopyProc := nil; {Initialize to avoid warnings} - {Defines the method to copy the data to the buffer depending on} - {the image parameters} - case Header.ColorType of - {R, G, B values} - COLOR_RGB: - case Header.BitDepth of - 8: CopyProc := EncodeInterlacedRGB8; - 16: CopyProc := EncodeInterlacedRGB16; - end; - {Grayscale and palette} - COLOR_PALETTE, COLOR_GRAYSCALE: - case Header.BitDepth of - 1, 4, 8: CopyProc := EncodeInterlacedPalette148; - 16: CopyProc := EncodeInterlacedGrayscale16; - end; - {RGB followed by alpha} - COLOR_RGBALPHA: - case Header.BitDepth of - 8: CopyProc := EncodeInterlacedRGBAlpha8; - 16: CopyProc := EncodeInterlacedRGBAlpha16; - end; - COLOR_GRAYSCALEALPHA: - {Grayscale followed by alpha} - case Header.BitDepth of - 8: CopyProc := EncodeInterlacedGrayscaleAlpha8; - 16: CopyProc := EncodeInterlacedGrayscaleAlpha16; - end; - end {case Header.ColorType}; - - {Compress the image using the seven passes for ADAM 7} - FOR CurrentPass := 0 TO 6 DO - begin - {Calculates the number of pixels and bytes for this pass row} - PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] + - ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass]; - Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType, - Header.BitDepth); - ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes); - - {Get current row index} - CurrentRow := RowStart[CurrentPass]; - {Get a pointer to the current row image data} - Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow * - (ImageHeight - 1 - CurrentRow)); - Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow); - - {Process all the image rows} - if Row_Bytes > 0 then - while CurrentRow < ImageHeight do - begin - {Copy data into buffer} - CopyProc(CurrentPass, Data, @Encode_Buffer[BUFFER][0], Trans); - {Filter data} - Filter := FilterToEncode; - - {Compress data} - IDATZlibWrite(ZLIBStream, @Filter, 1); - IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes); - - {Move to the next row} - inc(CurrentRow, RowIncrement[CurrentPass]); - {Move pointer to the next line} - dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow); - inc(Trans, RowIncrement[CurrentPass] * ImageWidth); - end {while CurrentRow < ImageHeight} - - end {CurrentPass}; - - {Compress and finishes copying the remaining data} - FinishIDATZlib(ZLIBStream); -end; - -{Filters the row to be encoded and returns the best filter} -function TChunkIDAT.FilterToEncode: Byte; -var - Run, LongestRun, ii, jj: Cardinal; - Last, Above, LastAbove: Byte; -begin - {Selecting more filters using the Filters property from TPngObject} - {increases the chances to the file be much smaller, but decreases} - {the performace} - - {This method will creates the same line data using the different} - {filter methods and select the best} - - {Sub-filter} - if pfSub in Owner.Filters then - for ii := 0 to Row_Bytes - 1 do - begin - {There is no previous pixel when it's on the first pixel, so} - {set last as zero when in the first} - if (ii >= Offset) then - last := Encode_Buffer[BUFFER]^[ii - Offset] - else - last := 0; - Encode_Buffer[FILTER_SUB]^[ii] := Encode_Buffer[BUFFER]^[ii] - last; - end; - - {Up filter} - if pfUp in Owner.Filters then - for ii := 0 to Row_Bytes - 1 do - Encode_Buffer[FILTER_UP]^[ii] := Encode_Buffer[BUFFER]^[ii] - - Encode_Buffer[FILTER_NONE]^[ii]; - - {Average filter} - if pfAverage in Owner.Filters then - for ii := 0 to Row_Bytes - 1 do - begin - {Get the previous pixel, if the current pixel is the first, the} - {previous is considered to be 0} - if (ii >= Offset) then - last := Encode_Buffer[BUFFER]^[ii - Offset] - else - last := 0; - {Get the pixel above} - above := Encode_Buffer[FILTER_NONE]^[ii]; - - {Calculates formula to the average pixel} - Encode_Buffer[FILTER_AVERAGE]^[ii] := Encode_Buffer[BUFFER]^[ii] - - (above + last) div 2 ; - end; - - {Paeth filter (the slower)} - if pfPaeth in Owner.Filters then - begin - {Initialize} - last := 0; - lastabove := 0; - for ii := 0 to Row_Bytes - 1 do - begin - {In case this pixel is not the first in the line obtains the} - {previous one and the one above the previous} - if (ii >= Offset) then - begin - last := Encode_Buffer[BUFFER]^[ii - Offset]; - lastabove := Encode_Buffer[FILTER_NONE]^[ii - Offset]; - end; - {Obtains the pixel above} - above := Encode_Buffer[FILTER_NONE]^[ii]; - {Calculate paeth filter for this byte} - Encode_Buffer[FILTER_PAETH]^[ii] := Encode_Buffer[BUFFER]^[ii] - - PaethPredictor(last, above, lastabove); - end; - end; - - {Now calculates the same line using no filter, which is necessary} - {in order to have data to the filters when the next line comes} - CopyMemory(@Encode_Buffer[FILTER_NONE]^[0], - @Encode_Buffer[BUFFER]^[0], Row_Bytes); - - {If only filter none is selected in the filter list, we don't need} - {to proceed and further} - if (Owner.Filters = [pfNone]) or (Owner.Filters = []) then - begin - Result := FILTER_NONE; - exit; - end {if (Owner.Filters = [pfNone...}; - - {Check which filter is the best by checking which has the larger} - {sequence of the same byte, since they are best compressed} - LongestRun := 0; Result := FILTER_NONE; - for ii := FILTER_NONE TO FILTER_PAETH do - {Check if this filter was selected} - if TFilter(ii) in Owner.Filters then - begin - Run := 0; - {Check if it's the only filter} - if Owner.Filters = [TFilter(ii)] then - begin - Result := ii; - exit; - end; - - {Check using a sequence of four bytes} - for jj := 2 to Row_Bytes - 1 do - if (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-1]) or - (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-2]) then - inc(Run); {Count the number of sequences} - - {Check if this one is the best so far} - if (Run > LongestRun) then - begin - Result := ii; - LongestRun := Run; - end {if (Run > LongestRun)}; - - end {if TFilter(ii) in Owner.Filters}; -end; - -{TChunkPLTE implementation} - -{Returns an item in the palette} -function TChunkPLTE.GetPaletteItem(Index: Byte): TRGBQuad; -begin - {Test if item is valid, if not raise error} - if Index > Count - 1 then - Owner.RaiseError(EPNGError, EPNGUnknownPalEntryText) - else - {Returns the item} - Result := Header.BitmapInfo.bmiColors[Index]; -end; - -{Loads the palette chunk from a stream} -function TChunkPLTE.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -type - pPalEntry = ^PalEntry; - PalEntry = record - r, g, b: Byte; - end; -var - j : Integer; {For the FOR} - PalColor : pPalEntry; - palEntries: TMaxLogPalette; -begin - {Let ancestor load data and check CRC} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result then exit; - - {This chunk must be divisible by 3 in order to be valid} - if (Size mod 3 <> 0) or (Size div 3 > 256) then - begin - {Raise error} - Result := FALSE; - Owner.RaiseError(EPNGInvalidPalette, EPNGInvalidPaletteText); - exit; - end {if Size mod 3 <> 0}; - - {Fill array with the palette entries} - fCount := Size div 3; - Fillchar(palEntries, sizeof(palEntries), #0); - palEntries.palVersion := $300; - palEntries.palNumEntries := fCount; - PalColor := Data; - FOR j := 0 TO fCount - 1 DO - with palEntries.palPalEntry[j] do - begin - peRed := Owner.GammaTable[PalColor.r]; - peGreen := Owner.GammaTable[PalColor.g]; - peBlue := Owner.GammaTable[PalColor.b]; - peFlags := 0; - {Move to next palette entry} - inc(PalColor); - end; - Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^)); -end; - -{Saves the PLTE chunk to a stream} -function TChunkPLTE.SaveToStream(Stream: TStream): Boolean; -var - J: Integer; - DataPtr: pByte; - BitmapInfo: TMAXBITMAPINFO; - palEntries: TMaxLogPalette; -begin - {Adjust size to hold all the palette items} - if fCount = 0 then fCount := Header.BitmapInfo.bmiHeader.biClrUsed; - ResizeData(fCount * 3); - {Get all the palette entries} - fillchar(palEntries, sizeof(palEntries), #0); - GetPaletteEntries(Header.ImagePalette, 0, 256, palEntries.palPalEntry[0]); - {Copy pointer to data} - DataPtr := fData; - - {Copy palette items} - BitmapInfo := Header.BitmapInfo; - FOR j := 0 TO fCount - 1 DO - with palEntries.palPalEntry[j] do - begin - DataPtr^ := Owner.InverseGamma[peRed]; inc(DataPtr); - DataPtr^ := Owner.InverseGamma[peGreen]; inc(DataPtr); - DataPtr^ := Owner.InverseGamma[peBlue]; inc(DataPtr); - end {with BitmapInfo}; - - {Let ancestor do the rest of the work} - Result := inherited SaveToStream(Stream); -end; - -{Assigns from another PLTE chunk} -procedure TChunkPLTE.Assign(Source: TChunk); -begin - {Copy the number of palette items} - if Source is TChunkPLTE then - fCount := TChunkPLTE(Source).fCount - else - Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); -end; - -{TChunkgAMA implementation} - -{Assigns from another chunk} -procedure TChunkgAMA.Assign(Source: TChunk); -begin - {Copy the gamma value} - if Source is TChunkgAMA then - Gamma := TChunkgAMA(Source).Gamma - else - Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); -end; - -{Gamma chunk being created} -constructor TChunkgAMA.Create(Owner: TPngObject); -begin - {Call ancestor} - inherited Create(Owner); - Gamma := 1; {Initial value} -end; - -{Returns gamma value} -function TChunkgAMA.GetValue: Cardinal; -begin - {Make sure that the size is four bytes} - if DataSize <> 4 then - begin - {Adjust size and returns 1} - ResizeData(4); - Result := 1; - end - {If it's right, read the value} - else Result := Cardinal(ByteSwap(pCardinal(Data)^)) -end; - -function Power(Base, Exponent: Extended): Extended; -begin - if Exponent = 0.0 then - Result := 1.0 {Math rule} - else if (Base = 0) or (Exponent = 0) then Result := 0 - else - Result := Exp(Exponent * Ln(Base)); -end; - -{Loading the chunk from a stream} -function TChunkgAMA.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -var - i: Integer; - Value: Cardinal; -begin - {Call ancestor and test if it went ok} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result then exit; - Value := Gamma; - {Build gamma table and inverse table for saving} - if Value <> 0 then - with Owner do - FOR i := 0 TO 255 DO - begin - GammaTable[I] := Round(Power((I / 255), 1 / - (Value / 100000 * 2.2)) * 255); - InverseGamma[Round(Power((I / 255), 1 / - (Value / 100000 * 2.2)) * 255)] := I; - end -end; - -{Sets the gamma value} -procedure TChunkgAMA.SetValue(const Value: Cardinal); -begin - {Make sure that the size is four bytes} - if DataSize <> 4 then ResizeData(4); - {If it's right, set the value} - pCardinal(Data)^ := ByteSwap(Value); -end; - -{TPngObject implementation} - -{Assigns from another object} -procedure TPngObject.Assign(Source: TPersistent); -begin - {Being cleared} - if Source = nil then - ClearChunks - {Assigns contents from another TPNGObject} - else if Source is TPNGObject then - AssignPNG(Source as TPNGObject) - {Copy contents from a TBitmap} - {$IFDEF UseDelphi}else if Source is TBitmap then - with Source as TBitmap do - AssignHandle(Handle, Transparent, - ColorToRGB(TransparentColor)){$ENDIF} - {Unknown source, let ancestor deal with it} - else - inherited; -end; - -{Clear all the chunks in the list} -procedure TPngObject.ClearChunks; -var - i: Integer; -begin - {Initialize gamma} - InitializeGamma(); - {Free all the objects and memory (0 chunks Bug fixed by Noel Sharpe)} - for i := 0 TO Integer(Chunks.Count) - 1 do - TChunk(Chunks.Item[i]).Free; - Chunks.Count := 0; -end; - -{Portable Network Graphics object being created as a blank image} -constructor TPNGObject.CreateBlank(ColorType, BitDepth: Cardinal; - cx, cy: Integer); -var NewIHDR: TChunkIHDR; -begin - {Calls creator} - Create; - {Checks if the parameters are ok} - if not (ColorType in [COLOR_GRAYSCALE, COLOR_RGB, COLOR_PALETTE, - COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA]) or not (BitDepth in - [1,2,4,8, 16]) or ((ColorType = COLOR_PALETTE) and (BitDepth = 16)) or - ((ColorType = COLOR_RGB) and (BitDepth < 8)) then - begin - RaiseError(EPNGInvalidSpec, EInvalidSpec); - exit; - end; - if Bitdepth = 2 then Bitdepth := 4; - - {Add the basis chunks} - InitializeGamma; - BeingCreated := True; - Chunks.Add(TChunkIEND); - NewIHDR := Chunks.Add(TChunkIHDR) as TChunkIHDR; - NewIHDR.IHDRData.ColorType := ColorType; - NewIHDR.IHDRData.BitDepth := BitDepth; - NewIHDR.IHDRData.Width := cx; - NewIHDR.IHDRData.Height := cy; - NewIHDR.PrepareImageData; - if NewIHDR.HasPalette then - TChunkPLTE(Chunks.Add(TChunkPLTE)).fCount := 1 shl BitDepth; - Chunks.Add(TChunkIDAT); - BeingCreated := False; -end; - -{Portable Network Graphics object being created} -constructor TPngObject.Create; -begin - {Let it be created} - inherited Create; - - {Initial properties} - {$IFDEF UseDelphi}fCanvas := TCanvas.Create;{$ENDIF} - fFilters := [pfSub]; - fCompressionLevel := 7; - fInterlaceMethod := imNone; - fMaxIdatSize := High(Word); - {Create chunklist object} - fChunkList := TPngList.Create(Self); - -end; - -{Portable Network Graphics object being destroyed} -destructor TPngObject.Destroy; -begin - {Free object list} - ClearChunks; - fChunkList.Free; - {$IFDEF UseDelphi}if fCanvas <> nil then - fCanvas.Free;{$ENDIF} - - {Call ancestor destroy} - inherited Destroy; -end; - -{Returns linesize and byte offset for pixels} -procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal); -begin - {There must be an Header chunk to calculate size} - if HeaderPresent then - begin - {Calculate number of bytes for each line} - LineSize := BytesForPixels(Header.Width, Header.ColorType, Header.BitDepth); - - {Calculates byte offset} - Case Header.ColorType of - {Grayscale} - COLOR_GRAYSCALE: - If Header.BitDepth = 16 Then - Offset := 2 - Else - Offset := 1 ; - {It always smaller or equal one byte, so it occupes one byte} - COLOR_PALETTE: - offset := 1; - {It might be 3 or 6 bytes} - COLOR_RGB: - offset := 3 * Header.BitDepth Div 8; - {It might be 2 or 4 bytes} - COLOR_GRAYSCALEALPHA: - offset := 2 * Header.BitDepth Div 8; - {4 or 8 bytes} - COLOR_RGBALPHA: - offset := 4 * Header.BitDepth Div 8; - else - Offset := 0; - End ; - - end - else - begin - {In case if there isn't any Header chunk} - Offset := 0; - LineSize := 0; - end; - -end; - -{Returns image height} -function TPngObject.GetHeight: Integer; -begin - {There must be a Header chunk to get the size, otherwise returns 0} - if HeaderPresent then - Result := TChunkIHDR(Chunks.Item[0]).Height - else Result := 0; -end; - -{Returns image width} -function TPngObject.GetWidth: Integer; -begin - {There must be a Header chunk to get the size, otherwise returns 0} - if HeaderPresent then - Result := Header.Width - else Result := 0; -end; - -{Returns if the image is empty} -function TPngObject.GetEmpty: Boolean; -begin - Result := (Chunks.Count = 0); -end; - -{Raises an error} -procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String); -begin - raise ExceptionClass.Create(Text); -end; - -{Set the maximum size for IDAT chunk} -procedure TPngObject.SetMaxIdatSize(const Value: Integer); -begin - {Make sure the size is at least 65535} - if Value < High(Word) then - fMaxIdatSize := High(Word) else fMaxIdatSize := Value; -end; - -{Draws the image using pixel information from TChunkpHYs} -procedure TPNGObject.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); - function Rect(Left, Top, Right, Bottom: Integer): TRect; - begin - Result.Left := Left; - Result.Top := Top; - Result.Right := Right; - Result.Bottom := Bottom; - end; -var - PPMeterY, PPMeterX: Double; - NewSizeX, NewSizeY: Integer; - DC: HDC; -begin - {Get system information} - DC := GetDC(0); - PPMeterY := GetDeviceCaps(DC, LOGPIXELSY) / 0.0254; - PPMeterX := GetDeviceCaps(DC, LOGPIXELSX) / 0.0254; - ReleaseDC(0, DC); - - {In case it does not has pixel information} - if not HasPixelInformation then - Draw(Canvas, Rect(Point.X, Point.Y, Point.X + Width, - Point.Y + Height)) - else - with PixelInformation do - begin - NewSizeX := Trunc(Self.Width / (PPUnitX / PPMeterX)); - NewSizeY := Trunc(Self.Height / (PPUnitY / PPMeterY)); - Draw(Canvas, Rect(Point.X, Point.Y, Point.X + NewSizeX, - Point.Y + NewSizeY)); - end; -end; - -{$IFNDEF UseDelphi} - {Creates a file stream reading from the filename in the parameter and load} - procedure TPngObject.LoadFromFile(const Filename: String); - var - FileStream: TFileStream; - begin - {Test if the file exists} - if not FileExists(Filename) then - begin - {In case it does not exists, raise error} - RaiseError(EPNGNotExists, EPNGNotExistsText); - exit; - end; - - {Creates the file stream to read} - FileStream := TFileStream.Create(Filename, [fsmRead]); - LoadFromStream(FileStream); {Loads the data} - FileStream.Free; {Free file stream} - end; - - {Saves the current png image to a file} - procedure TPngObject.SaveToFile(const Filename: String); - var - FileStream: TFileStream; - begin - {Creates the file stream to write} - FileStream := TFileStream.Create(Filename, [fsmWrite]); - SaveToStream(FileStream); {Saves the data} - FileStream.Free; {Free file stream} - end; - -{$ENDIF} - -{Returns if it has the pixel information chunk} -function TPngObject.HasPixelInformation: Boolean; -begin - Result := (Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs) <> nil; -end; - -{Returns the pixel information chunk} -function TPngObject.GetPixelInformation: TChunkpHYs; -begin - Result := Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs; - if not Assigned(Result) then - begin - Result := Chunks.Add(tChunkpHYs) as tChunkpHYs; - Result.fUnit := utMeter; - end; -end; - -{Returns pointer to the chunk TChunkIHDR which should be the first} -function TPngObject.GetHeader: TChunkIHDR; -begin - {If there is a TChunkIHDR returns it, otherwise returns nil} - if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then - Result := Chunks.Item[0] as TChunkIHDR - else - begin - {No header, throw error message} - RaiseError(EPNGHeaderNotPresent, EPNGHeaderNotPresentText); - Result := nil - end -end; - -{Draws using partial transparency} -procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect); - {Adjust the rectangle structure} - procedure AdjustRect(var Rect: TRect); - var - t: Integer; - begin - if Rect.Right < Rect.Left then - begin - t := Rect.Right; - Rect.Right := Rect.Left; - Rect.Left := t; - end; - if Rect.Bottom < Rect.Top then - begin - t := Rect.Bottom; - Rect.Bottom := Rect.Top; - Rect.Top := t; - end - end; - -type - {Access to pixels} - TPixelLine = Array[Word] of TRGBQuad; - pPixelLine = ^TPixelLine; -const - {Structure used to create the bitmap} - BitmapInfoHeader: TBitmapInfoHeader = - (biSize: sizeof(TBitmapInfoHeader); - biWidth: 100; - biHeight: 100; - biPlanes: 1; - biBitCount: 32; - biCompression: BI_RGB; - biSizeImage: 0; - biXPelsPerMeter: 0; - biYPelsPerMeter: 0; - biClrUsed: 0; - biClrImportant: 0); -var - {Buffer bitmap creation} - BitmapInfo : TBitmapInfo; - BufferDC : HDC; - BufferBits : Pointer; - OldBitmap, - BufferBitmap: HBitmap; - Header: TChunkIHDR; - - {Transparency/palette chunks} - TransparencyChunk: TChunktRNS; - PaletteChunk: TChunkPLTE; - TransValue, PaletteIndex: Byte; - CurBit: Integer; - Data: PByte; - - {Buffer bitmap modification} - BytesPerRowDest, - BytesPerRowSrc, - BytesPerRowAlpha: Integer; - ImageSource, ImageSourceOrg, - AlphaSource : pByteArray; - ImageData : pPixelLine; - i, j, i2, j2 : Integer; - - {For bitmap stretching} - W, H : Cardinal; - Stretch : Boolean; - FactorX, FactorY: Double; -begin - {Prepares the rectangle structure to stretch draw} - if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit; - AdjustRect(Rect); - {Gets the width and height} - W := Rect.Right - Rect.Left; - H := Rect.Bottom - Rect.Top; - Header := Self.Header; {Fast access to header} - Stretch := (W <> Header.Width) or (H <> Header.Height); - if Stretch then FactorX := W / Header.Width else FactorX := 1; - if Stretch then FactorY := H / Header.Height else FactorY := 1; - - {Prepare to create the bitmap} - Fillchar(BitmapInfo, sizeof(BitmapInfo), #0); - BitmapInfoHeader.biWidth := W; - BitmapInfoHeader.biHeight := -Integer(H); - BitmapInfo.bmiHeader := BitmapInfoHeader; - - {Create the bitmap which will receive the background, the applied} - {alpha blending and then will be painted on the background} - BufferDC := CreateCompatibleDC(0); - {In case BufferDC could not be created} - if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText); - BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS, - BufferBits, 0, 0); - {In case buffer bitmap could not be created} - if (BufferBitmap = 0) or (BufferBits = Nil) then - begin - if BufferBitmap <> 0 then DeleteObject(BufferBitmap); - DeleteDC(BufferDC); - RaiseError(EPNGOutMemory, EPNGOutMemoryText); - end; - - {Selects new bitmap and release old bitmap} - OldBitmap := SelectObject(BufferDC, BufferBitmap); - - {Draws the background on the buffer image} - BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY); - - {Obtain number of bytes for each row} - BytesPerRowAlpha := Header.Width; - BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31) - and not 31) div 8; {Number of bytes for each image row in destination} - BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) + - 31) and not 31) div 8; {Number of bytes for each image row in source} - - {Obtains image pointers} - ImageData := BufferBits; - AlphaSource := Header.ImageAlpha; - Longint(ImageSource) := Longint(Header.ImageData) + - Header.BytesPerRow * Longint(Header.Height - 1); - ImageSourceOrg := ImageSource; - - case Header.BitmapInfo.bmiHeader.biBitCount of - {R, G, B images} - 24: - FOR j := 1 TO H DO - begin - {Process all the pixels in this line} - FOR i := 0 TO W - 1 DO - begin - if Stretch then i2 := trunc(i / FactorX) else i2 := i; - {Optmize when we don´t have transparency} - if (AlphaSource[i2] <> 0) then - if (AlphaSource[i2] = 255) then - ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^ - else - with ImageData[i] do - begin - rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed * - (not AlphaSource[i2])) shr 8; - rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] + - rgbGreen * (not AlphaSource[i2])) shr 8; - rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue * - (not AlphaSource[i2])) shr 8; - end; - end; - - {Move pointers} - inc(Longint(ImageData), BytesPerRowDest); - if Stretch then j2 := trunc(j / FactorY) else j2 := j; - Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; - Longint(AlphaSource) := Longint(Header.ImageAlpha) + - BytesPerRowAlpha * j2; - end; - {Palette images with 1 byte for each pixel} - 1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then - FOR j := 1 TO H DO - begin - {Process all the pixels in this line} - FOR i := 0 TO W - 1 DO - with ImageData[i], Header.BitmapInfo do begin - if Stretch then i2 := trunc(i / FactorX) else i2 := i; - rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] + - rgbRed * (255 - AlphaSource[i2])) shr 8; - rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] + - rgbGreen * (255 - AlphaSource[i2])) shr 8; - rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] + - rgbBlue * (255 - AlphaSource[i2])) shr 8; - end; - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - if Stretch then j2 := trunc(j / FactorY) else j2 := j; - Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; - Longint(AlphaSource) := Longint(Header.ImageAlpha) + - BytesPerRowAlpha * j2; - end - else {Palette images} - begin - {Obtain pointer to the transparency chunk} - TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS)); - PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE)); - - FOR j := 1 TO H DO - begin - {Process all the pixels in this line} - i := 0; - repeat - CurBit := 0; - if Stretch then i2 := trunc(i / FactorX) else i2 := i; - Data := @ImageSource[i2]; - - repeat - {Obtains the palette index} - case Header.BitDepth of - 1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1; - 2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F; - else PaletteIndex := Data^; - end; - - {Updates the image with the new pixel} - with ImageData[i] do - begin - TransValue := TransparencyChunk.PaletteValues[PaletteIndex]; - rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed * - TransValue + rgbRed * (255 - TransValue)) shr 8; - rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen * - TransValue + rgbGreen * (255 - TransValue)) shr 8; - rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue * - TransValue + rgbBlue * (255 - TransValue)) shr 8; - end; - - {Move to next data} - inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount); - until CurBit >= 8; - {Move to next source data} - //inc(Data); - until i >= Integer(W); - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - if Stretch then j2 := trunc(j / FactorY) else j2 := j; - Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2; - end - end {Palette images} - end {case Header.BitmapInfo.bmiHeader.biBitCount}; - - {Draws the new bitmap on the foreground} - BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY); - - {Free bitmap} - SelectObject(BufferDC, OldBitmap); - DeleteObject(BufferBitmap); - DeleteDC(BufferDC); -end; - -{Draws the image into a canvas} -procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect); -var - Header: TChunkIHDR; -begin - {Quit in case there is no header, otherwise obtain it} - if Empty then Exit; - Header := Chunks.GetItem(0) as TChunkIHDR; - - {Copy the data to the canvas} - case Self.TransparencyMode of - {$IFDEF PartialTransparentDraw} - ptmPartial: - DrawPartialTrans(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect); - {$ENDIF} - ptmBit: DrawTransparentBitmap(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, - Header.ImageData, Header.BitmapInfo.bmiHeader, - pBitmapInfo(@Header.BitmapInfo), Rect, - {$IFDEF UseDelphi}ColorToRGB({$ENDIF}TransparentColor) - {$IFDEF UseDelphi}){$ENDIF} - else - begin - SetStretchBltMode(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, COLORONCOLOR); - StretchDiBits(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect.Left, - Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0, - Header.Width, Header.Height, Header.ImageData, - pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY) - end - end {case} -end; - -{Characters for the header} -const - PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10); - -{Loads the image from a stream of data} -procedure TPngObject.LoadFromStream(Stream: TStream); -var - Header : Array[0..7] of Char; - HasIDAT : Boolean; - - {Chunks reading} - ChunkCount : Cardinal; - ChunkLength: Cardinal; - ChunkName : TChunkName; -begin - {Initialize before start loading chunks} - ChunkCount := 0; - ClearChunks(); - {Reads the header} - Stream.Read(Header[0], 8); - - {Test if the header matches} - if Header <> PngHeader then - begin - RaiseError(EPNGInvalidFileHeader, EPNGInvalidFileHeaderText); - Exit; - end; - - - HasIDAT := FALSE; - Chunks.Count := 10; - - {Load chunks} - repeat - inc(ChunkCount); {Increment number of chunks} - if Chunks.Count < ChunkCount then {Resize the chunks list if needed} - Chunks.Count := Chunks.Count + 10; - - {Reads chunk length and invert since it is in network order} - {also checks the Read method return, if it returns 0, it} - {means that no bytes was readed, probably because it reached} - {the end of the file} - if Stream.Read(ChunkLength, 4) = 0 then - begin - {In case it found the end of the file here} - Chunks.Count := ChunkCount - 1; - RaiseError(EPNGUnexpectedEnd, EPNGUnexpectedEndText); - end; - - ChunkLength := ByteSwap(ChunkLength); - {Reads chunk name} - Stream.Read(Chunkname, 4); - - {Here we check if the first chunk is the Header which is necessary} - {to the file in order to be a valid Portable Network Graphics image} - if (ChunkCount = 1) and (ChunkName <> 'IHDR') then - begin - Chunks.Count := ChunkCount - 1; - RaiseError(EPNGIHDRNotFirst, EPNGIHDRNotFirstText); - exit; - end; - - {Has a previous IDAT} - if (HasIDAT and (ChunkName = 'IDAT')) or (ChunkName = 'cHRM') then - begin - dec(ChunkCount); - Stream.Seek(ChunkLength + 4, soFromCurrent); - Continue; - end; - {Tell it has an IDAT chunk} - if ChunkName = 'IDAT' then HasIDAT := TRUE; - - {Creates object for this chunk} - Chunks.SetItem(ChunkCount - 1, CreateClassChunk(Self, ChunkName)); - - {Check if the chunk is critical and unknown} - {$IFDEF ErrorOnUnknownCritical} - if (TChunk(Chunks.Item[ChunkCount - 1]).ClassType = TChunk) and - ((Byte(ChunkName[0]) AND $20) = 0) and (ChunkName <> '') then - begin - Chunks.Count := ChunkCount; - RaiseError(EPNGUnknownCriticalChunk, EPNGUnknownCriticalChunkText); - end; - {$ENDIF} - - {Loads it} - try if not TChunk(Chunks.Item[ChunkCount - 1]).LoadFromStream(Stream, - ChunkName, ChunkLength) then break; - except - Chunks.Count := ChunkCount; - raise; - end; - - {Terminates when it reaches the IEND chunk} - until (ChunkName = 'IEND'); - - {Resize the list to the appropriate size} - Chunks.Count := ChunkCount; - - {Check if there is data} - if not HasIDAT then - RaiseError(EPNGNoImageData, EPNGNoImageDataText); -end; - -{Changing height is not supported} -procedure TPngObject.SetHeight(Value: Integer); -begin - Resize(Width, Value) -end; - -{Changing width is not supported} -procedure TPngObject.SetWidth(Value: Integer); -begin - Resize(Value, Height) -end; - -{$IFDEF UseDelphi} -{Saves to clipboard format (thanks to Antoine Pottern)} -procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word; - var AData: THandle; var APalette: HPalette); -begin - with TBitmap.Create do - try - Width := Self.Width; - Height := Self.Height; - Self.Draw(Canvas, Rect(0, 0, Width, Height)); - SaveToClipboardFormat(AFormat, AData, APalette); - finally - Free; - end {try} -end; - -{Loads data from clipboard} -procedure TPngObject.LoadFromClipboardFormat(AFormat: Word; - AData: THandle; APalette: HPalette); -begin - with TBitmap.Create do - try - LoadFromClipboardFormat(AFormat, AData, APalette); - Self.AssignHandle(Handle, False, 0); - finally - Free; - end {try} -end; - -{Returns if the image is transparent} -function TPngObject.GetTransparent: Boolean; -begin - Result := (TransparencyMode <> ptmNone); -end; - -{$ENDIF} - -{Saving the PNG image to a stream of data} -procedure TPngObject.SaveToStream(Stream: TStream); -var - j: Integer; -begin - {Reads the header} - Stream.Write(PNGHeader[0], 8); - {Write each chunk} - FOR j := 0 TO Chunks.Count - 1 DO - Chunks.Item[j].SaveToStream(Stream) -end; - -{Prepares the Header chunk} -procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap); -var - DC: HDC; -begin - {Set width and height} - Header.Width := Info.bmWidth; - Header.Height := abs(Info.bmHeight); - {Set bit depth} - if Info.bmBitsPixel >= 16 then - Header.BitDepth := 8 else Header.BitDepth := Info.bmBitsPixel; - {Set color type} - if Info.bmBitsPixel >= 16 then - Header.ColorType := COLOR_RGB else Header.ColorType := COLOR_PALETTE; - {Set other info} - Header.CompressionMethod := 0; {deflate/inflate} - Header.InterlaceMethod := 0; {no interlace} - - {Prepares bitmap headers to hold data} - Header.PrepareImageData(); - {Copy image data} - DC := CreateCompatibleDC(0); - GetDIBits(DC, Handle, 0, Header.Height, Header.ImageData, - pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS); - - DeleteDC(DC); -end; - -{Loads the image from a resource} -procedure TPngObject.LoadFromResourceName(Instance: HInst; - const Name: String); -var - ResStream: TResourceStream; -begin - {Creates an especial stream to load from the resource} - try ResStream := TResourceStream.Create(Instance, Name, RT_RCDATA); - except RaiseError(EPNGCouldNotLoadResource, EPNGCouldNotLoadResourceText); - exit; end; - - {Loads the png image from the resource} - try - LoadFromStream(ResStream); - finally - ResStream.Free; - end; -end; - -{Loads the png from a resource ID} -procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer); -begin - LoadFromResourceName(Instance, String(ResID)); -end; - -{Assigns this tpngobject to another object} -procedure TPngObject.AssignTo(Dest: TPersistent); -{$IFDEF UseDelphi} - function DetectPixelFormat: TPixelFormat; - begin - with Header do - begin - {Always use 24bits for partial transparency} - if TransparencyMode = ptmPartial then - DetectPixelFormat := pf24bit - else - case BitDepth of - {Only supported by COLOR_PALETTE} - 1: DetectPixelFormat := pf1bit; - 2, 4: DetectPixelFormat := pf4bit; - {8 may be palette or r, g, b values} - 8, 16: - case ColorType of - COLOR_RGB, COLOR_GRAYSCALE: DetectPixelFormat := pf24bit; - COLOR_PALETTE: DetectPixelFormat := pf8bit; - else raise Exception.Create(''); - end {case ColorFormat of} - else raise Exception.Create(''); - end {case BitDepth of} - end {with Header} - end; -var - TRNS: TChunkTRNS; -{$ENDIF} -begin - {If the destination is also a TPNGObject make it assign} - {this one} - if Dest is TPNGObject then - TPNGObject(Dest).AssignPNG(Self) - {$IFDEF UseDelphi} - {In case the destination is a bitmap} - else if (Dest is TBitmap) and HeaderPresent then - begin - {Copies the handle using CopyImage API} - TBitmap(Dest).PixelFormat := DetectPixelFormat; - TBitmap(Dest).Width := Width; - TBitmap(Dest).Height := Height; - TBitmap(Dest).Canvas.Draw(0, 0, Self); - - {Copy transparency mode} - if (TransparencyMode = ptmBit) then - begin - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - TBitmap(Dest).TransparentColor := TRNS.TransparentColor; - TBitmap(Dest).Transparent := True - end {if (TransparencyMode = ptmBit)} - - end - else - {Unknown destination kind} - inherited AssignTo(Dest); - {$ENDIF} -end; - -{Assigns from a bitmap object} -procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean; - TransparentColor: ColorRef); -var - BitmapInfo: Windows.TBitmap; - {Chunks} - Header: TChunkIHDR; - PLTE: TChunkPLTE; - IDAT: TChunkIDAT; - IEND: TChunkIEND; - TRNS: TChunkTRNS; - i: Integer; - palEntries : TMaxLogPalette; -begin - {Obtain bitmap info} - GetObject(Handle, SizeOf(BitmapInfo), @BitmapInfo); - - {Clear old chunks and prepare} - ClearChunks(); - - {Create the chunks} - Header := TChunkIHDR.Create(Self); - - {This method will fill the Header chunk with bitmap information} - {and copy the image data} - BuildHeader(Header, Handle, @BitmapInfo); - - if Header.HasPalette then PLTE := TChunkPLTE.Create(Self) else PLTE := nil; - if Transparent then TRNS := TChunkTRNS.Create(Self) else TRNS := nil; - IDAT := TChunkIDAT.Create(Self); - IEND := TChunkIEND.Create(Self); - - {Add chunks} - TPNGPointerList(Chunks).Add(Header); - if Header.HasPalette then TPNGPointerList(Chunks).Add(PLTE); - if Transparent then TPNGPointerList(Chunks).Add(TRNS); - TPNGPointerList(Chunks).Add(IDAT); - TPNGPointerList(Chunks).Add(IEND); - - {In case there is a image data, set the PLTE chunk fCount variable} - {to the actual number of palette colors which is 2^(Bits for each pixel)} - if Header.HasPalette then - begin - PLTE.fCount := 1 shl BitmapInfo.bmBitsPixel; - - {Create and set palette} - fillchar(palEntries, sizeof(palEntries), 0); - palEntries.palVersion := $300; - palEntries.palNumEntries := 1 shl BitmapInfo.bmBitsPixel; - for i := 0 to palEntries.palNumEntries - 1 do - begin - palEntries.palPalEntry[i].peRed := Header.BitmapInfo.bmiColors[i].rgbRed; - palEntries.palPalEntry[i].peGreen := Header.BitmapInfo.bmiColors[i].rgbGreen; - palEntries.palPalEntry[i].peBlue := Header.BitmapInfo.bmiColors[i].rgbBlue; - end; - DoSetPalette(CreatePalette(pLogPalette(@palEntries)^), false); - end; - - {In case it is a transparent bitmap, prepares it} - if Transparent then TRNS.TransparentColor := TransparentColor; -end; - -{Assigns from another PNG} -procedure TPngObject.AssignPNG(Source: TPNGObject); -var - J: Integer; -begin - {Copy properties} - InterlaceMethod := Source.InterlaceMethod; - MaxIdatSize := Source.MaxIdatSize; - CompressionLevel := Source.CompressionLevel; - Filters := Source.Filters; - - {Clear old chunks and prepare} - ClearChunks(); - Chunks.Count := Source.Chunks.Count; - {Create chunks and makes a copy from the source} - FOR J := 0 TO Chunks.Count - 1 DO - with Source.Chunks do - begin - Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self)); - TChunk(Chunks.Item[J]).Assign(TChunk(Item[J])); - end {with}; -end; - -{Returns a alpha data scanline} -function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray; -begin - with Header do - if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then - Longint(Result) := Longint(ImageAlpha) + (LineIndex * Longint(Width)) - else Result := nil; {In case the image does not use alpha information} -end; - -{$IFDEF Store16bits} -{Returns a png data extra scanline} -function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer; -begin - with Header do - Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) * - BytesPerRow)) - (LineIndex * BytesPerRow); -end; -{$ENDIF} - -{Returns a png data scanline} -function TPngObject.GetScanline(const LineIndex: Integer): Pointer; -begin - with Header do - Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) * - BytesPerRow)) - (LineIndex * BytesPerRow); -end; - -{Initialize gamma table} -procedure TPngObject.InitializeGamma; -var - i: Integer; -begin - {Build gamma table as if there was no gamma} - FOR i := 0 to 255 do - begin - GammaTable[i] := i; - InverseGamma[i] := i; - end {for i} -end; - -{Returns the transparency mode used by this png} -function TPngObject.GetTransparencyMode: TPNGTransparencyMode; -var - TRNS: TChunkTRNS; -begin - with Header do - begin - Result := ptmNone; {Default result} - {Gets the TRNS chunk pointer} - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - - {Test depending on the color type} - case ColorType of - {This modes are always partial} - COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Result := ptmPartial; - {This modes support bit transparency} - COLOR_RGB, COLOR_GRAYSCALE: if TRNS <> nil then Result := ptmBit; - {Supports booth translucid and bit} - COLOR_PALETTE: - {A TRNS chunk must be present, otherwise it won't support transparency} - if TRNS <> nil then - if TRNS.BitTransparency then - Result := ptmBit else Result := ptmPartial - end {case} - - end {with Header} -end; - -{Add a text chunk} -procedure TPngObject.AddtEXt(const Keyword, Text: String); -var - TextChunk: TChunkTEXT; -begin - TextChunk := Chunks.Add(TChunkText) as TChunkTEXT; - TextChunk.Keyword := Keyword; - TextChunk.Text := Text; -end; - -{Add a text chunk} -procedure TPngObject.AddzTXt(const Keyword, Text: String); -var - TextChunk: TChunkzTXt; -begin - TextChunk := Chunks.Add(TChunkzTXt) as TChunkzTXt; - TextChunk.Keyword := Keyword; - TextChunk.Text := Text; -end; - -{Removes the image transparency} -procedure TPngObject.RemoveTransparency; -var - TRNS: TChunkTRNS; -begin - {Removes depending on the color type} - with Header do - case ColorType of - {Palette uses the TChunktRNS to store alpha} - COLOR_PALETTE: - begin - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - if TRNS <> nil then Chunks.RemoveChunk(TRNS) - end; - {Png allocates different memory space to hold alpha information} - {for these types} - COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA: - begin - {Transform into the appropriate color type} - if ColorType = COLOR_GRAYSCALEALPHA then - ColorType := COLOR_GRAYSCALE - else ColorType := COLOR_RGB; - {Free the pointer data} - if ImageAlpha <> nil then FreeMem(ImageAlpha); - ImageAlpha := nil - end - end -end; - -{Generates alpha information} -procedure TPngObject.CreateAlpha; -var - TRNS: TChunkTRNS; -begin - {Generates depending on the color type} - with Header do - case ColorType of - {Png allocates different memory space to hold alpha information} - {for these types} - COLOR_GRAYSCALE, COLOR_RGB: - begin - {Transform into the appropriate color type} - if ColorType = COLOR_GRAYSCALE then - ColorType := COLOR_GRAYSCALEALPHA - else ColorType := COLOR_RGBALPHA; - {Allocates memory to hold alpha information} - GetMem(ImageAlpha, Integer(Width) * Integer(Height)); - FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #255); - end; - {Palette uses the TChunktRNS to store alpha} - COLOR_PALETTE: - begin - {Gets/creates TRNS chunk} - if Chunks.ItemFromClass(TChunkTRNS) = nil then - TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS - else - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - - {Prepares the TRNS chunk} - with TRNS do - begin - ResizeData(256); - Fillchar(PaletteValues[0], 256, 255); - fDataSize := 1 shl Header.BitDepth; - fBitTransparency := False - end {with Chunks.Add}; - end; - end {case Header.ColorType} - -end; - -{Returns transparent color} -function TPngObject.GetTransparentColor: TColor; -var - TRNS: TChunkTRNS; -begin - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - {Reads the transparency chunk to get this info} - if Assigned(TRNS) then Result := TRNS.TransparentColor - else Result := 0 -end; - -{$OPTIMIZATION OFF} -procedure TPngObject.SetTransparentColor(const Value: TColor); -var - TRNS: TChunkTRNS; -begin - if HeaderPresent then - {Tests the ColorType} - case Header.ColorType of - {Not allowed for this modes} - COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Self.RaiseError( - EPNGCannotChangeTransparent, EPNGCannotChangeTransparentText); - {Allowed} - COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE: - begin - TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; - if not Assigned(TRNS) then TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS; - - {Sets the transparency value from TRNS chunk} - TRNS.TransparentColor := {$IFDEF UseDelphi}ColorToRGB({$ENDIF}Value - {$IFDEF UseDelphi}){$ENDIF} - end {COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE)} - end {case} -end; - -{Returns if header is present} -function TPngObject.HeaderPresent: Boolean; -begin - Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR)) -end; - -{Returns pixel for png using palette and grayscale} -function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor; -var - ByteData: Byte; - DataDepth: Byte; -begin - with png, Header do - begin - {Make sure the bitdepth is not greater than 8} - DataDepth := BitDepth; - if DataDepth > 8 then DataDepth := 8; - {Obtains the byte containing this pixel} - ByteData := pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)]; - {Moves the bits we need to the right} - ByteData := (ByteData shr ((8 - DataDepth) - - (X mod (8 div DataDepth)) * DataDepth)); - {Discard the unwanted pixels} - ByteData:= ByteData and ($FF shr (8 - DataDepth)); - - {For palette mode map the palette entry and for grayscale convert and - returns the intensity} - case ColorType of - COLOR_PALETTE: - with TChunkPLTE(png.Chunks.ItemFromClass(TChunkPLTE)).Item[ByteData] do - Result := rgb(GammaTable[rgbRed], GammaTable[rgbGreen], - GammaTable[rgbBlue]); - COLOR_GRAYSCALE: - begin - if BitDepth = 1 - then ByteData := GammaTable[Byte(ByteData * 255)] - else ByteData := GammaTable[Byte(ByteData * ((1 shl DataDepth) + 1))]; - Result := rgb(ByteData, ByteData, ByteData); - end; - else Result := 0; - end {case}; - end {with} -end; - -{In case vcl units are not being used} -{$IFNDEF UseDelphi} -function ColorToRGB(const Color: TColor): COLORREF; -begin - Result := Color -end; -{$ENDIF} - -{Sets a pixel for grayscale and palette pngs} -procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer; - const Value: TColor); -const - ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF); -var - ByteData: pByte; - DataDepth: Byte; - ValEntry: Byte; -begin - with png.Header do - begin - {Map into a palette entry} - ValEntry := GetNearestPaletteIndex(Png.Palette, ColorToRGB(Value)); - - {16 bits grayscale extra bits are discarted} - DataDepth := BitDepth; - if DataDepth > 8 then DataDepth := 8; - {Gets a pointer to the byte we intend to change} - ByteData := @pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)]; - {Clears the old pixel data} - ByteData^ := ByteData^ and not (ClearFlag[DataDepth] shl ((8 - DataDepth) - - (X mod (8 div DataDepth)) * DataDepth)); - - {Setting the new pixel} - ByteData^ := ByteData^ or (ValEntry shl ((8 - DataDepth) - - (X mod (8 div DataDepth)) * DataDepth)); - end {with png.Header} -end; - -{Returns pixel when png uses RGB} -function GetRGBLinePixel(const png: TPngObject; - const X, Y: Integer): TColor; -begin - with pRGBLine(png.Scanline[Y])^[X] do - Result := RGB(rgbtRed, rgbtGreen, rgbtBlue) -end; - -{Sets pixel when png uses RGB} -procedure SetRGBLinePixel(const png: TPngObject; - const X, Y: Integer; Value: TColor); -begin - with pRGBLine(png.Scanline[Y])^[X] do - begin - rgbtRed := GetRValue(Value); - rgbtGreen := GetGValue(Value); - rgbtBlue := GetBValue(Value) - end -end; - -{Returns pixel when png uses grayscale} -function GetGrayLinePixel(const png: TPngObject; - const X, Y: Integer): TColor; -var - B: Byte; -begin - B := PByteArray(png.Scanline[Y])^[X]; - Result := RGB(B, B, B); -end; - -{Sets pixel when png uses grayscale} -procedure SetGrayLinePixel(const png: TPngObject; - const X, Y: Integer; Value: TColor); -begin - PByteArray(png.Scanline[Y])^[X] := GetRValue(Value); -end; - -{Resizes the PNG image} -procedure TPngObject.Resize(const CX, CY: Integer); - function Min(const A, B: Integer): Integer; - begin - if A < B then Result := A else Result := B; - end; -var - Header: TChunkIHDR; - Line, NewBytesPerRow: Integer; - NewHandle: HBitmap; - NewDC: HDC; - NewImageData: Pointer; - NewImageAlpha: Pointer; - NewImageExtra: Pointer; -begin - if (CX > 0) and (CY > 0) then - begin - {Gets some actual information} - Header := Self.Header; - - {Creates the new image} - NewDC := CreateCompatibleDC(Header.ImageDC); - Header.BitmapInfo.bmiHeader.biWidth := cx; - Header.BitmapInfo.bmiHeader.biHeight := cy; - NewHandle := CreateDIBSection(NewDC, pBitmapInfo(@Header.BitmapInfo)^, - DIB_RGB_COLORS, NewImageData, 0, 0); - SelectObject(NewDC, NewHandle); - {$IFDEF UseDelphi}Canvas.Handle := NewDC;{$ENDIF} - NewBytesPerRow := (((Header.BitmapInfo.bmiHeader.biBitCount * cx) + 31) - and not 31) div 8; - - {Copies the image data} - for Line := 0 to Min(CY - 1, Height - 1) do - CopyMemory(Ptr(Longint(NewImageData) + (Longint(CY) - 1) * - NewBytesPerRow - (Line * NewBytesPerRow)), Scanline[Line], - Min(NewBytesPerRow, Header.BytesPerRow)); - - {Build array for alpha information, if necessary} - if (Header.ColorType = COLOR_RGBALPHA) or - (Header.ColorType = COLOR_GRAYSCALEALPHA) then - begin - GetMem(NewImageAlpha, CX * CY); - Fillchar(NewImageAlpha^, CX * CY, 255); - for Line := 0 to Min(CY - 1, Height - 1) do - CopyMemory(Ptr(Longint(NewImageAlpha) + (Line * CX)), - AlphaScanline[Line], Min(CX, Width)); - FreeMem(Header.ImageAlpha); - Header.ImageAlpha := NewImageAlpha; - end; - - {$IFDEF Store16bits} - if (Header.BitDepth = 16) then - begin - GetMem(NewImageExtra, CX * CY); - Fillchar(NewImageExtra^, CX * CY, 0); - for Line := 0 to Min(CY - 1, Height - 1) do - CopyMemory(Ptr(Longint(NewImageExtra) + (Line * CX)), - ExtraScanline[Line], Min(CX, Width)); - FreeMem(Header.ExtraImageData); - Header.ExtraImageData := NewImageExtra; - end; - {$ENDIF} - - {Deletes the old image} - DeleteObject(Header.ImageHandle); - DeleteDC(Header.ImageDC); - - {Prepares the header to get the new image} - Header.BytesPerRow := NewBytesPerRow; - Header.IHDRData.Width := CX; - Header.IHDRData.Height := CY; - Header.ImageData := NewImageData; - - {Replaces with the new image} - Header.ImageHandle := NewHandle; - Header.ImageDC := NewDC; - end - else - {The new size provided is invalid} - RaiseError(EPNGInvalidNewSize, EInvalidNewSize) - -end; - -{Sets a pixel} -procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor); -begin - if ((X >= 0) and (X <= Width - 1)) and - ((Y >= 0) and (Y <= Height - 1)) then - with Header do - begin - if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then - SetByteArrayPixel(Self, X, Y, Value) - else if ColorType in [COLOR_GRAYSCALEALPHA] then - SetGrayLinePixel(Self, X, Y, Value) - else - SetRGBLinePixel(Self, X, Y, Value) - end {with} -end; - - -{Returns a pixel} -function TPngObject.GetPixels(const X, Y: Integer): TColor; -begin - if ((X >= 0) and (X <= Width - 1)) and - ((Y >= 0) and (Y <= Height - 1)) then - with Header do - begin - if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then - Result := GetByteArrayPixel(Self, X, Y) - else if ColorType in [COLOR_GRAYSCALEALPHA] then - Result := GetGrayLinePixel(Self, X, Y) - else - Result := GetRGBLinePixel(Self, X, Y) - end {with} - else Result := 0 -end; - -{Returns the image palette} -function TPngObject.GetPalette: HPALETTE; -begin - Result := Header.ImagePalette; -end; - -{Assigns from another TChunk} -procedure TChunkpHYs.Assign(Source: TChunk); -begin - fPPUnitY := TChunkpHYs(Source).fPPUnitY; - fPPUnitX := TChunkpHYs(Source).fPPUnitX; - fUnit := TChunkpHYs(Source).fUnit; -end; - -{Loads the chunk from a stream} -function TChunkpHYs.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -begin - {Let ancestor load the data} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size <> 9) then exit; {Size must be 9} - - {Reads data} - fPPUnitX := ByteSwap(pCardinal(Longint(Data))^); - fPPUnitY := ByteSwap(pCardinal(Longint(Data) + 4)^); - fUnit := pUnitType(Longint(Data) + 8)^; -end; - -{Saves the chunk to a stream} -function TChunkpHYs.SaveToStream(Stream: TStream): Boolean; -begin - {Update data} - ResizeData(9); {Make sure the size is 9} - pCardinal(Data)^ := ByteSwap(fPPUnitX); - pCardinal(Longint(Data) + 4)^ := ByteSwap(fPPUnitY); - pUnitType(Longint(Data) + 8)^ := fUnit; - - {Let inherited save data} - Result := inherited SaveToStream(Stream); -end; - -procedure TPngObject.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); -begin - if (Header.HasPalette) then - begin - {Update the palette entries} - if UpdateColors then - Header.PaletteToDIB(Value); - - {Resize the new palette} - SelectPalette(Header.ImageDC, Value, False); - RealizePalette(Header.ImageDC); - - {Replaces} - DeleteObject(Header.ImagePalette); - Header.ImagePalette := Value; - end -end; - -{Set palette based on a windows palette handle} -procedure TPngObject.SetPalette(Value: HPALETTE); -begin - DoSetPalette(Value, true); -end; - -{Returns the library version} -function TPNGObject.GetLibraryVersion: String; -begin - Result := LibraryVersion -end; - -initialization - {Initialize} - ChunkClasses := nil; - {crc table has not being computed yet} - crc_table_computed := FALSE; - {Register the necessary chunks for png} - RegisterCommonChunks; - {Registers TPNGObject to use with TPicture} - {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} - TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject); - {$ENDIF}{$ENDIF} -finalization - {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} - TPicture.UnregisterGraphicClass(TPNGObject); - {$ENDIF}{$ENDIF} - {Free chunk classes} - FreeChunkClassList; -end. - - diff --git a/plugins/Chess4Net/lib/PNGImage/pnglang.pas b/plugins/Chess4Net/lib/PNGImage/pnglang.pas deleted file mode 100644 index c4a5fb84c1..0000000000 --- a/plugins/Chess4Net/lib/PNGImage/pnglang.pas +++ /dev/null @@ -1,355 +0,0 @@ -{Portable Network Graphics Delphi Language Info (24 July 2002)} - -{Feel free to change the text bellow to adapt to your language} -{Also if you have a translation to other languages and want to} -{share it, send me: gubadaud@terra.com.br } -unit pnglang; - -interface - -{$DEFINE English} -{.$DEFINE Polish} -{.$DEFINE Portuguese} -{.$DEFINE German} -{.$DEFINE French} -{.$DEFINE Slovenian} - -{Language strings for english} -resourcestring - {$IFDEF Polish} - EPngInvalidCRCText = 'Ten obraz "Portable Network Graphics" jest nieprawid³owy ' + - 'poniewa¿ zawiera on nieprawid³owe czêœci danych (b³¹d crc)'; - EPNGInvalidIHDRText = 'Obraz "Portable Network Graphics" nie mo¿e zostaæ ' + - 'wgrany poniewa¿ jedna z czêœci danych (ihdr) mo¿e byæ uszkodzona'; - EPNGMissingMultipleIDATText = 'Obraz "Portable Network Graphics" jest ' + - 'nieprawid³owy poniewa¿ brakuje w nim czêœci obrazu.'; - EPNGZLIBErrorText = 'Nie mo¿na zdekompresowaæ obrazu poniewa¿ zawiera ' + - 'b³êdnie zkompresowane dane.'#13#10 + ' Opis b³êdu: '; - EPNGInvalidPaletteText = 'Obraz "Portable Network Graphics" zawiera ' + - 'niew³aœciw¹ paletê.'; - EPNGInvalidFileHeaderText = 'Plik który jest odczytywany jest nieprawid³owym '+ - 'obrazem "Portable Network Graphics" poniewa¿ zawiera nieprawid³owy nag³ówek.' + - ' Plik mo¿ê byæ uszkodzony, spróbuj pobraæ go ponownie.'; - EPNGIHDRNotFirstText = 'Obraz "Portable Network Graphics" nie jest ' + - 'obs³ugiwany lub mo¿e byæ niew³aœciwy.'#13#10 + '(stopka IHDR nie jest pierwsza)'; - EPNGNotExistsText = 'Plik png nie mo¿e zostaæ wgrany poniewa¿ nie ' + - 'istnieje.'; - EPNGSizeExceedsText = 'Obraz "Portable Network Graphics" nie jest ' + - 'obs³ugiwany poniewa¿ jego szerokoœæ lub wysokoœæ przekracza maksimum ' + - 'rozmiaru, który wynosi 65535 pikseli d³ugoœci.'; - EPNGUnknownPalEntryText = 'Nie znaleziono wpisów palety.'; - EPNGMissingPaletteText = 'Obraz "Portable Network Graphics" nie mo¿e zostaæ ' + - 'wgrany poniewa¿ u¿ywa tabeli kolorów której brakuje.'; - EPNGUnknownCriticalChunkText = 'Obraz "Portable Network Graphics" ' + - 'zawiera nieznan¹ krytyczn¹ czêœæ która nie mo¿e zostaæ odkodowana.'; - EPNGUnknownCompressionText = 'Obraz "Portable Network Graphics" jest ' + - 'skompresowany nieznanym schemat który nie mo¿e zostaæ odszyfrowany.'; - EPNGUnknownInterlaceText = 'Obraz "Portable Network Graphics" u¿ywa ' + - 'nie znany schamat przeplatania który nie mo¿e zostaæ odszyfrowany.'; - EPNGCannotAssignChunkText = 'Stopka mysi byæ kompatybilna aby zosta³a wyznaczona.'; - EPNGUnexpectedEndText = 'Obraz "Portable Network Graphics" jest nieprawid³owy ' + - 'poniewa¿ dekoder znalaz³ niespodziewanie koniec pliku.'; - EPNGNoImageDataText = 'Obraz "Portable Network Graphics" nie zawiera' + - 'danych.'; - EPNGCannotAddChunkText = 'Program próbuje dodaæ krytyczn¹ ' + - 'stopkê do aktualnego obrazu co jest niedozwolone.'; - EPNGCannotAddInvalidImageText = 'Nie mo¿na dodaæ nowej stopki ' + - 'poniewa¿ aktualny obraz jest nieprawid³owy.'; - EPNGCouldNotLoadResourceText = 'Obraz png nie mo¿e zostaæ za³adowany z' + - 'zasobów o podanym ID.'; - EPNGOutMemoryText = 'Niektóre operacje nie mog¹ zostaæ zrealizowane poniewa¿ ' + - 'systemowi brakuje zasobów. Zamknij kilka okien i spróbuj ponownie.'; - EPNGCannotChangeTransparentText = 'Ustawienie bitu przezroczystego koloru jest ' + - 'zabronione dla obrazów png zawieraj¹cych wartoœæ alpha dla ka¿dego piksela ' + - '(COLOR_RGBALPHA i COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Ta operacja jest niedozwolona poniewa¿ ' + - 'aktualny obraz zawiera niew³aœciwy nag³ówek.'; - EInvalidNewSize = 'The new size provided for image resizing is invalid.'; - EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + - 'because invalid image type parameters have being provided.'; - {$ENDIF} - - {$IFDEF English} - EPngInvalidCRCText = 'This "Portable Network Graphics" image is not valid ' + - 'because it contains invalid pieces of data (crc error)'; - EPNGInvalidIHDRText = 'The "Portable Network Graphics" image could not be ' + - 'loaded because one of its main piece of data (ihdr) might be corrupted'; - EPNGMissingMultipleIDATText = 'This "Portable Network Graphics" image is ' + - 'invalid because it has missing image parts.'; - EPNGZLIBErrorText = 'Could not decompress the image because it contains ' + - 'invalid compressed data.'#13#10 + ' Description: '; - EPNGInvalidPaletteText = 'The "Portable Network Graphics" image contains ' + - 'an invalid palette.'; - EPNGInvalidFileHeaderText = 'The file being readed is not a valid '+ - '"Portable Network Graphics" image because it contains an invalid header.' + - ' This file may be corruped, try obtaining it again.'; - EPNGIHDRNotFirstText = 'This "Portable Network Graphics" image is not ' + - 'supported or it might be invalid.'#13#10 + '(IHDR chunk is not the first)'; - EPNGNotExistsText = 'The png file could not be loaded because it does not ' + - 'exists.'; - EPNGSizeExceedsText = 'This "Portable Network Graphics" image is not ' + - 'supported because either it''s width or height exceeds the maximum ' + - 'size, which is 65535 pixels length.'; - EPNGUnknownPalEntryText = 'There is no such palette entry.'; - EPNGMissingPaletteText = 'This "Portable Network Graphics" could not be ' + - 'loaded because it uses a color table which is missing.'; - EPNGUnknownCriticalChunkText = 'This "Portable Network Graphics" image ' + - 'contains an unknown critical part which could not be decoded.'; - EPNGUnknownCompressionText = 'This "Portable Network Graphics" image is ' + - 'encoded with an unknown compression scheme which could not be decoded.'; - EPNGUnknownInterlaceText = 'This "Portable Network Graphics" image uses ' + - 'an unknown interlace scheme which could not be decoded.'; - EPNGCannotAssignChunkText = 'The chunks must be compatible to be assigned.'; - EPNGUnexpectedEndText = 'This "Portable Network Graphics" image is invalid ' + - 'because the decoder found an unexpected end of the file.'; - EPNGNoImageDataText = 'This "Portable Network Graphics" image contains no ' + - 'data.'; - EPNGCannotAddChunkText = 'The program tried to add a existent critical ' + - 'chunk to the current image which is not allowed.'; - EPNGCannotAddInvalidImageText = 'It''s not allowed to add a new chunk ' + - 'because the current image is invalid.'; - EPNGCouldNotLoadResourceText = 'The png image could not be loaded from the ' + - 'resource ID.'; - EPNGOutMemoryText = 'Some operation could not be performed because the ' + - 'system is out of resources. Close some windows and try again.'; - EPNGCannotChangeTransparentText = 'Setting bit transparency color is not ' + - 'allowed for png images containing alpha value for each pixel ' + - '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'This operation is not valid because the ' + - 'current image contains no valid header.'; - EInvalidNewSize = 'The new size provided for image resizing is invalid.'; - EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + - 'because invalid image type parameters have being provided.'; - {$ENDIF} - {$IFDEF Portuguese} - EPngInvalidCRCText = 'Essa imagem "Portable Network Graphics" não é válida ' + - 'porque contém chunks inválidos de dados (erro crc)'; - EPNGInvalidIHDRText = 'A imagem "Portable Network Graphics" não pode ser ' + - 'carregada porque um dos seus chunks importantes (ihdr) pode estar '+ - 'inválido'; - EPNGMissingMultipleIDATText = 'Essa imagem "Portable Network Graphics" é ' + - 'inválida porque tem chunks de dados faltando.'; - EPNGZLIBErrorText = 'Não foi possível descomprimir os dados da imagem ' + - 'porque ela contém dados inválidos.'#13#10 + ' Descrição: '; - EPNGInvalidPaletteText = 'A imagem "Portable Network Graphics" contém ' + - 'uma paleta inválida.'; - EPNGInvalidFileHeaderText = 'O arquivo sendo lido não é uma imagem '+ - '"Portable Network Graphics" válida porque contém um cabeçalho inválido.' + - ' O arquivo pode estar corrompida, tente obter ela novamente.'; - EPNGIHDRNotFirstText = 'Essa imagem "Portable Network Graphics" não é ' + - 'suportada ou pode ser inválida.'#13#10 + '(O chunk IHDR não é o ' + - 'primeiro)'; - EPNGNotExistsText = 'A imagem png não pode ser carregada porque ela não ' + - 'existe.'; - EPNGSizeExceedsText = 'Essa imagem "Portable Network Graphics" não é ' + - 'suportada porque a largura ou a altura ultrapassam o tamanho máximo, ' + - 'que é de 65535 pixels de diâmetro.'; - EPNGUnknownPalEntryText = 'Não existe essa entrada de paleta.'; - EPNGMissingPaletteText = 'Essa imagem "Portable Network Graphics" não pode ' + - 'ser carregada porque usa uma paleta que está faltando.'; - EPNGUnknownCriticalChunkText = 'Essa imagem "Portable Network Graphics" ' + - 'contém um chunk crítico desconheçido que não pode ser decodificado.'; - EPNGUnknownCompressionText = 'Essa imagem "Portable Network Graphics" está ' + - 'codificada com um esquema de compressão desconheçido e não pode ser ' + - 'decodificada.'; - EPNGUnknownInterlaceText = 'Essa imagem "Portable Network Graphics" usa um ' + - 'um esquema de interlace que não pode ser decodificado.'; - EPNGCannotAssignChunkText = 'Os chunk devem ser compatíveis para serem ' + - 'copiados.'; - EPNGUnexpectedEndText = 'Essa imagem "Portable Network Graphics" é ' + - 'inválida porque o decodificador encontrou um fim inesperado.'; - EPNGNoImageDataText = 'Essa imagem "Portable Network Graphics" não contém ' + - 'dados.'; - EPNGCannotAddChunkText = 'O programa tentou adicionar um chunk crítico ' + - 'já existente para a imagem atual, oque não é permitido.'; - EPNGCannotAddInvalidImageText = 'Não é permitido adicionar um chunk novo ' + - 'porque a imagem atual é inválida.'; - EPNGCouldNotLoadResourceText = 'A imagem png não pode ser carregada apartir' + - ' do resource.'; - EPNGOutMemoryText = 'Uma operação não pode ser completada porque o sistema ' + - 'está sem recursos. Fecha algumas janelas e tente novamente.'; - EPNGCannotChangeTransparentText = 'Definir transparência booleana não é ' + - 'permitido para imagens png contendo informação alpha para cada pixel ' + - '(COLOR_RGBALPHA e COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Essa operação não é válida porque a ' + - 'imagem atual não contém um cabeçalho válido.'; - EInvalidNewSize = 'O novo tamanho fornecido para o redimensionamento de ' + - 'imagem é inválido.'; - EInvalidSpec = 'A imagem "Portable Network Graphics" não pode ser criada ' + - 'porque parâmetros de tipo de imagem inválidos foram usados.'; - {$ENDIF} - {Language strings for German} - {$IFDEF German} - EPngInvalidCRCText = 'Dieses "Portable Network Graphics" Bild ist ' + - 'ungültig, weil Teile der Daten fehlerhaft sind (CRC-Fehler)'; - EPNGInvalidIHDRText = 'Dieses "Portable Network Graphics" Bild konnte ' + - 'nicht geladen werden, weil wahrscheinlich einer der Hauptdatenbreiche ' + - '(IHDR) beschädigt ist'; - EPNGMissingMultipleIDATText = 'Dieses "Portable Network Graphics" Bild ' + - 'ist ungültig, weil Grafikdaten fehlen.'; - EPNGZLIBErrorText = 'Die Grafik konnte nicht entpackt werden, weil Teile der ' + - 'komprimierten Daten fehlerhaft sind.'#13#10 + ' Beschreibung: '; - EPNGInvalidPaletteText = 'Das "Portable Network Graphics" Bild enthält ' + - 'eine ungültige Palette.'; - EPNGInvalidFileHeaderText = 'Die Datei, die gelesen wird, ist kein ' + - 'gültiges "Portable Network Graphics" Bild, da es keinen gültigen ' + - 'Header enthält. Die Datei könnte beschädigt sein, versuchen Sie, ' + - 'eine neue Kopie zu bekommen.'; - EPNGIHDRNotFirstText = 'Dieses "Portable Network Graphics" Bild wird ' + - 'nicht unterstützt oder ist ungültig.'#13#10 + - '(Der IHDR-Abschnitt ist nicht der erste Abschnitt in der Datei).'; - EPNGNotExistsText = 'Die PNG Datei konnte nicht geladen werden, da sie ' + - 'nicht existiert.'; - EPNGSizeExceedsText = 'Dieses "Portable Network Graphics" Bild wird nicht ' + - 'unterstützt, weil entweder seine Breite oder seine Höhe das Maximum von ' + - '65535 Pixeln überschreitet.'; - EPNGUnknownPalEntryText = 'Es gibt keinen solchen Palettenwert.'; - EPNGMissingPaletteText = 'Dieses "Portable Network Graphics" Bild konnte ' + - 'nicht geladen werden, weil die benötigte Farbtabelle fehlt.'; - EPNGUnknownCriticalChunkText = 'Dieses "Portable Network Graphics" Bild ' + - 'enhält einen unbekannten aber notwendigen Teil, welcher nicht entschlüsselt ' + - 'werden kann.'; - EPNGUnknownCompressionText = 'Dieses "Portable Network Graphics" Bild ' + - 'wurde mit einem unbekannten Komprimierungsalgorithmus kodiert, welcher ' + - 'nicht entschlüsselt werden kann.'; - EPNGUnknownInterlaceText = 'Dieses "Portable Network Graphics" Bild ' + - 'benutzt ein unbekanntes Interlace-Schema, welches nicht entschlüsselt ' + - 'werden kann.'; - EPNGCannotAssignChunkText = 'Die Abschnitte müssen kompatibel sein, damit ' + - 'sie zugewiesen werden können.'; - EPNGUnexpectedEndText = 'Dieses "Portable Network Graphics" Bild ist ' + - 'ungültig: Der Dekoder ist unerwartete auf das Ende der Datei gestoßen.'; - EPNGNoImageDataText = 'Dieses "Portable Network Graphics" Bild enthält ' + - 'keine Daten.'; - EPNGCannotAddChunkText = 'Das Programm versucht einen existierenden und ' + - 'notwendigen Abschnitt zum aktuellen Bild hinzuzufügen. Dies ist nicht ' + - 'zulässig.'; - EPNGCannotAddInvalidImageText = 'Es ist nicht zulässig, einem ungültigen ' + - 'Bild einen neuen Abschnitt hinzuzufügen.'; - EPNGCouldNotLoadResourceText = 'Das PNG Bild konnte nicht aus den ' + - 'Resourcendaten geladen werden.'; - EPNGOutMemoryText = 'Es stehen nicht genügend Resourcen im System zur ' + - 'Verfügung, um die Operation auszuführen. Schließen Sie einige Fenster '+ - 'und versuchen Sie es erneut.'; - EPNGCannotChangeTransparentText = 'Das Setzen der Bit-' + - 'Transparent-Farbe ist für PNG-Images die Alpha-Werte für jedes ' + - 'Pixel enthalten (COLOR_RGBALPHA und COLOR_GRAYSCALEALPHA) nicht ' + - 'zulässig'; - EPNGHeaderNotPresentText = 'Die Datei, die gelesen wird, ist kein ' + - 'gültiges "Portable Network Graphics" Bild, da es keinen gültigen ' + - 'Header enthält.'; - EInvalidNewSize = 'The new size provided for image resizing is invalid.'; - EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + - 'because invalid image type parameters have being provided.'; - {$ENDIF} - {Language strings for French} - {$IFDEF French} - EPngInvalidCRCText = 'Cette image "Portable Network Graphics" n''est pas valide ' + - 'car elle contient des données invalides (erreur crc)'; - EPNGInvalidIHDRText = 'Cette image "Portable Network Graphics" n''a pu être ' + - 'chargée car l''une de ses principale donnée (ihdr) doit être corrompue'; - EPNGMissingMultipleIDATText = 'Cette image "Portable Network Graphics" est ' + - 'invalide car elle contient des parties d''image manquantes.'; - EPNGZLIBErrorText = 'Impossible de décompresser l''image car elle contient ' + - 'des données compressées invalides.'#13#10 + ' Description: '; - EPNGInvalidPaletteText = 'L''image "Portable Network Graphics" contient ' + - 'une palette invalide.'; - EPNGInvalidFileHeaderText = 'Le fichier actuellement lu est une image '+ - '"Portable Network Graphics" invalide car elle contient un en-tête invalide.' + - ' Ce fichier doit être corrompu, essayer de l''obtenir à nouveau.'; - EPNGIHDRNotFirstText = 'Cette image "Portable Network Graphics" n''est pas ' + - 'supportée ou doit être invalide.'#13#10 + '(la partie IHDR n''est pas la première)'; - EPNGNotExistsText = 'Le fichier png n''a pu être chargé car il n''éxiste pas.'; - EPNGSizeExceedsText = 'Cette image "Portable Network Graphics" n''est pas supportée ' + - 'car sa longueur ou sa largeur excède la taille maximale, qui est de 65535 pixels.'; - EPNGUnknownPalEntryText = 'Il n''y a aucune entrée pour cette palette.'; - EPNGMissingPaletteText = 'Cette image "Portable Network Graphics" n''a pu être ' + - 'chargée car elle utilise une table de couleur manquante.'; - EPNGUnknownCriticalChunkText = 'Cette image "Portable Network Graphics" ' + - 'contient une partie critique inconnue qui n'' pu être décodée.'; - EPNGUnknownCompressionText = 'Cette image "Portable Network Graphics" est ' + - 'encodée à l''aide d''un schémas de compression inconnu qui ne peut être décodé.'; - EPNGUnknownInterlaceText = 'Cette image "Portable Network Graphics" utilise ' + - 'un schémas d''entrelacement inconnu qui ne peut être décodé.'; - EPNGCannotAssignChunkText = 'Ce morceau doit être compatible pour être assigné.'; - EPNGUnexpectedEndText = 'Cette image "Portable Network Graphics" est invalide ' + - 'car le decodeur est arrivé à une fin de fichier non attendue.'; - EPNGNoImageDataText = 'Cette image "Portable Network Graphics" ne contient pas de ' + - 'données.'; - EPNGCannotAddChunkText = 'Le programme a essayé d''ajouter un morceau critique existant ' + - 'à l''image actuelle, ce qui n''est pas autorisé.'; - EPNGCannotAddInvalidImageText = 'Il n''est pas permis d''ajouter un nouveau morceau ' + - 'car l''image actuelle est invalide.'; - EPNGCouldNotLoadResourceText = 'L''image png n''a pu être chargée depuis ' + - 'l''ID ressource.'; - EPNGOutMemoryText = 'Certaines opérations n''ont pu être effectuée car le ' + - 'système n''a plus de ressources. Fermez quelques fenêtres et essayez à nouveau.'; - EPNGCannotChangeTransparentText = 'Définir le bit de transparence n''est pas ' + - 'permis pour des images png qui contiennent une valeur alpha pour chaque pixel ' + - '(COLOR_RGBALPHA et COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Cette opération n''est pas valide car l''image ' + - 'actuelle ne contient pas de header valide.'; - EPNGAlphaNotSupportedText = 'Le type de couleur de l''image "Portable Network Graphics" actuelle ' + - 'contient déjà des informations alpha ou il ne peut être converti.'; - EInvalidNewSize = 'The new size provided for image resizing is invalid.'; - EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + - 'because invalid image type parameters have being provided.'; - {$ENDIF} - {Language strings for slovenian} - {$IFDEF Slovenian} - EPngInvalidCRCText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + - 'ker vsebuje neveljavne dele podatkov (CRC napaka).'; - EPNGInvalidIHDRText = 'Slike "Portable Network Graphics" ni bilo možno ' + - 'naložiti, ker je eden od glavnih delov podatkov (IHDR) verjetno pokvarjen.'; - EPNGMissingMultipleIDATText = 'Ta "Portable Network Graphics" slika je ' + - 'naveljavna, ker manjkajo deli slike.'; - EPNGZLIBErrorText = 'Ne morem raztegniti slike, ker vsebuje ' + - 'neveljavne stisnjene podatke.'#13#10 + ' Opis: '; - EPNGInvalidPaletteText = 'Slika "Portable Network Graphics" vsebuje ' + - 'neveljavno barvno paleto.'; - EPNGInvalidFileHeaderText = 'Datoteka za branje ni veljavna '+ - '"Portable Network Graphics" slika, ker vsebuje neveljavno glavo.' + - ' Datoteka je verjetno pokvarjena, poskusite jo ponovno naložiti.'; - EPNGIHDRNotFirstText = 'Ta "Portable Network Graphics" slika ni ' + - 'podprta ali pa je neveljavna.'#13#10 + '(IHDR del datoteke ni prvi).'; - EPNGNotExistsText = 'Ne morem naložiti png datoteke, ker ta ne ' + - 'obstaja.'; - EPNGSizeExceedsText = 'Ta "Portable Network Graphics" slika ni ' + - 'podprta, ker ali njena širina ali višina presega najvecjo možno vrednost ' + - '65535 pik.'; - EPNGUnknownPalEntryText = 'Slika nima vnešene take barvne palete.'; - EPNGMissingPaletteText = 'Te "Portable Network Graphics" ne morem ' + - 'naložiti, ker uporablja manjkajoco barvno paleto.'; - EPNGUnknownCriticalChunkText = 'Ta "Portable Network Graphics" slika ' + - 'vsebuje neznan kriticni del podatkov, ki ga ne morem prebrati.'; - EPNGUnknownCompressionText = 'Ta "Portable Network Graphics" slika je ' + - 'kodirana z neznano kompresijsko shemo, ki je ne morem prebrati.'; - EPNGUnknownInterlaceText = 'Ta "Portable Network Graphics" slika uporablja ' + - 'neznano shemo za preliv, ki je ne morem prebrati.'; - EPNGCannotAssignChunkText = Košcki morajo biti med seboj kompatibilni za prireditev vrednosti.'; - EPNGUnexpectedEndText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + - 'ker je bralnik prišel do nepricakovanega konca datoteke.'; - EPNGNoImageDataText = 'Ta "Portable Network Graphics" ne vsebuje nobenih ' + - 'podatkov.'; - EPNGCannotAddChunkText = 'Program je poskusil dodati obstojeci kriticni ' + - 'kos podatkov k trenutni sliki, kar ni dovoljeno.'; - EPNGCannotAddInvalidImageText = 'Ni dovoljeno dodati nov kos podatkov, ' + - 'ker trenutna slika ni veljavna.'; - EPNGCouldNotLoadResourceText = 'Ne morem naložiti png slike iz ' + - 'skladišca.'; - EPNGOutMemoryText = 'Ne morem izvesti operacije, ker je ' + - 'sistem ostal brez resorjev. Zaprite nekaj oken in poskusite znova.'; - EPNGCannotChangeTransparentText = 'Ni dovoljeno nastaviti prosojnosti posamezne barve ' + - 'za png slike, ki vsebujejo alfa prosojno vrednost za vsako piko ' + - '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Ta operacija ni veljavna, ker ' + - 'izbrana slika ne vsebuje veljavne glave.'; - EInvalidNewSize = 'The new size provided for image resizing is invalid.'; - EInvalidSpec = 'The "Portable Network Graphics" could not be created ' + - 'because invalid image type parameters have being provided.'; - {$ENDIF} - - -implementation - -end. diff --git a/plugins/Chess4Net/lib/PNGImage/zlibpas.pas b/plugins/Chess4Net/lib/PNGImage/zlibpas.pas deleted file mode 100644 index 64a8526bd4..0000000000 --- a/plugins/Chess4Net/lib/PNGImage/zlibpas.pas +++ /dev/null @@ -1,156 +0,0 @@ -{Portable Network Graphics Delphi ZLIB linking (16 May 2002) } - -{This unit links ZLIB to pngimage unit in order to implement } -{the library. It's now using the new ZLIB version, 1.1.4 } -{Note: The .obj files must be located in the subdirectory \obj} - -unit zlibpas; - -interface - -type - - TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; - TFree = procedure (AppData, Block: Pointer); - - // Internal structure. Ignore. - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in: Integer; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out: Integer; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - internal: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - AppData: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Integer; // adler32 value of the uncompressed data - reserved: Integer; // reserved for future use - end; - -function inflateInit_(var strm: TZStreamRec; version: PChar; - recsize: Integer): Integer; forward; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; forward; -function inflateEnd(var strm: TZStreamRec): Integer; forward; -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; forward; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; forward; -function deflateEnd(var strm: TZStreamRec): Integer; forward; - -const - zlib_version = '1.2.3'; - - -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = (-1); - Z_STREAM_ERROR = (-2); - Z_DATA_ERROR = (-3); - Z_MEM_ERROR = (-4); - Z_BUF_ERROR = (-5); - Z_VERSION_ERROR = (-6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - _z_errmsg: array[0..9] of PChar = ( - 'need dictionary', // Z_NEED_DICT (2) - 'stream end', // Z_STREAM_END (1) - '', // Z_OK (0) - 'file error', // Z_ERRNO (-1) - 'stream error', // Z_STREAM_ERROR (-2) - 'data error', // Z_DATA_ERROR (-3) - 'insufficient memory', // Z_MEM_ERROR (-4) - 'buffer error', // Z_BUF_ERROR (-5) - 'incompatible version', // Z_VERSION_ERROR (-6) - '' - ); - -implementation - -{$L obj\adler32.obj} -{$L obj\deflate.obj} -{$L obj\infback.obj} -{$L obj\inffast.obj} -{$L obj\inflate.obj} -{$L obj\inftrees.obj} -{$L obj\trees.obj} -{$L obj\compress.obj} -{$L obj\crc32.obj} - - - -function adler32(adler: LongInt; const buf: PChar; len: Integer): LongInt; external; - -procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl; -begin - FillChar(P^, count, B); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer);cdecl; -begin - Move(source^, dest^, count); -end; - - -// deflate compresses data -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; external; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function deflateEnd(var strm: TZStreamRec): Integer; external; - -// inflate decompresses data -function inflateInit_(var strm: TZStreamRec; version: PChar; - recsize: Integer): Integer; external; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function inflateEnd(var strm: TZStreamRec): Integer; external; -function inflateReset(var strm: TZStreamRec): Integer; external; - - -function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer; -begin - GetMem(Result, Items*Size); -end; - -procedure zcfree(AppData, Block: Pointer); -begin - FreeMem(Block); -end; - -end. - - - - - - - - - diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas deleted file mode 100644 index c515cf9a36..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas +++ /dev/null @@ -1,1374 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit ActiveIMM_TLB; - -{$INCLUDE TntCompilers.inc} - -{TNT-IGNORE-UNIT} - -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : $Revision: 1.1 $ -// File generated on 04/03/2001 11:32:13 PM from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: C:\Program Files\Microsoft Platform SDK\Include\dimm.tlb (1) -// IID\LCID: {4955DD30-B159-11D0-8FCF-00AA006BCC59}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\Stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// Errors: -// Hint: Member 'End' of 'IActiveIMMMessagePumpOwner' changed to 'End_' -// Error creating palette bitmap of (TCActiveIMM) : Server D:\D5Addons\Dimm\dimm.dll contains no icons -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. -interface - -uses - Windows, ActiveX, Classes, OleServer; - -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// -const - // TypeLibrary Major and minor versions - ActiveIMMMajorVersion = 0; - ActiveIMMMinorVersion = 1; - - LIBID_ActiveIMM: TGUID = '{4955DD30-B159-11D0-8FCF-00AA006BCC59}'; - - IID_IEnumRegisterWordA: TGUID = '{08C03412-F96B-11D0-A475-00AA006BCC59}'; - IID_IEnumRegisterWordW: TGUID = '{4955DD31-B159-11D0-8FCF-00AA006BCC59}'; - IID_IEnumInputContext: TGUID = '{09B5EAB0-F997-11D1-93D4-0060B067B86E}'; - IID_IActiveIMMRegistrar: TGUID = '{B3458082-BD00-11D1-939B-0060B067B86E}'; - IID_IActiveIMMMessagePumpOwner: TGUID = '{B5CF2CFA-8AEB-11D1-9364-0060B067B86E}'; - IID_IActiveIMMApp: TGUID = '{08C0E040-62D1-11D1-9326-0060B067B86E}'; - IID_IActiveIMMIME: TGUID = '{08C03411-F96B-11D0-A475-00AA006BCC59}'; - IID_IActiveIME: TGUID = '{6FE20962-D077-11D0-8FE7-00AA006BCC59}'; - IID_IActiveIME2: TGUID = '{E1C4BF0E-2D53-11D2-93E1-0060B067B86E}'; - CLASS_CActiveIMM: TGUID = '{4955DD33-B159-11D0-8FCF-00AA006BCC59}'; -type - -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// - IEnumRegisterWordA = interface; - IEnumRegisterWordW = interface; - IEnumInputContext = interface; - IActiveIMMRegistrar = interface; - IActiveIMMMessagePumpOwner = interface; - IActiveIMMApp = interface; - IActiveIMMIME = interface; - IActiveIME = interface; - IActiveIME2 = interface; - -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// - CActiveIMM = IActiveIMMApp; - - -// *********************************************************************// -// Declaration of structures, unions and aliases. -// *********************************************************************// - wireHBITMAP = ^_userHBITMAP; - wireHWND = ^_RemotableHandle; - PUserType1 = ^TGUID; {*} - PUserType2 = ^tagMSG; {*} - PUserType3 = ^REGISTERWORDA; {*} - PUserType4 = ^REGISTERWORDW; {*} - PUserType5 = ^CANDIDATEFORM; {*} - PUserType6 = ^LOGFONTA; {*} - PUserType7 = ^LOGFONTW; {*} - PUserType8 = ^COMPOSITIONFORM; {*} - PUserType9 = ^tagPOINT; {*} - PWord1 = ^Word; {*} - PUserType10 = ^IMEMENUITEMINFOA; {*} - PUserType11 = ^IMEMENUITEMINFOW; {*} - PUserType12 = ^INPUTCONTEXT; {*} - PByte1 = ^Byte; {*} - - __MIDL___MIDL_itf_dimm_0000_0001 = packed record - lpReading: PAnsiChar; - lpWord: PAnsiChar; - end; - - REGISTERWORDA = __MIDL___MIDL_itf_dimm_0000_0001; - - __MIDL___MIDL_itf_dimm_0000_0002 = packed record - lpReading: PWideChar; - lpWord: PWideChar; - end; - - REGISTERWORDW = __MIDL___MIDL_itf_dimm_0000_0002; - - __MIDL___MIDL_itf_dimm_0000_0003 = packed record - lfHeight: Integer; - lfWidth: Integer; - lfEscapement: Integer; - lfOrientation: Integer; - lfWeight: Integer; - lfItalic: Byte; - lfUnderline: Byte; - lfStrikeOut: Byte; - lfCharSet: Byte; - lfOutPrecision: Byte; - lfClipPrecision: Byte; - lfQuality: Byte; - lfPitchAndFamily: Byte; - lfFaceName: array[0..31] of Shortint; - end; - - LOGFONTA = __MIDL___MIDL_itf_dimm_0000_0003; - - __MIDL___MIDL_itf_dimm_0000_0004 = packed record - lfHeight: Integer; - lfWidth: Integer; - lfEscapement: Integer; - lfOrientation: Integer; - lfWeight: Integer; - lfItalic: Byte; - lfUnderline: Byte; - lfStrikeOut: Byte; - lfCharSet: Byte; - lfOutPrecision: Byte; - lfClipPrecision: Byte; - lfQuality: Byte; - lfPitchAndFamily: Byte; - lfFaceName: array[0..31] of Word; - end; - - LOGFONTW = __MIDL___MIDL_itf_dimm_0000_0004; - - tagPOINT = packed record - x: Integer; - y: Integer; - end; - - tagRECT = packed record - left: Integer; - top: Integer; - right: Integer; - bottom: Integer; - end; - - __MIDL___MIDL_itf_dimm_0000_0005 = packed record - dwIndex: LongWord; - dwStyle: LongWord; - ptCurrentPos: tagPOINT; - rcArea: tagRECT; - end; - - CANDIDATEFORM = __MIDL___MIDL_itf_dimm_0000_0005; - - __MIDL___MIDL_itf_dimm_0000_0006 = packed record - dwStyle: LongWord; - ptCurrentPos: tagPOINT; - rcArea: tagRECT; - end; - - COMPOSITIONFORM = __MIDL___MIDL_itf_dimm_0000_0006; - - __MIDL___MIDL_itf_dimm_0000_0007 = packed record - dwSize: LongWord; - dwStyle: LongWord; - dwCount: LongWord; - dwSelection: LongWord; - dwPageStart: LongWord; - dwPageSize: LongWord; - dwOffset: array[0..0] of LongWord; - end; - - CANDIDATELIST = __MIDL___MIDL_itf_dimm_0000_0007; - - __MIDL___MIDL_itf_dimm_0000_0008 = packed record - dwStyle: LongWord; - szDescription: array[0..31] of Shortint; - end; - - STYLEBUFA = __MIDL___MIDL_itf_dimm_0000_0008; - - __MIDL___MIDL_itf_dimm_0000_0009 = packed record - dwStyle: LongWord; - szDescription: array[0..31] of Word; - end; - - STYLEBUFW = __MIDL___MIDL_itf_dimm_0000_0009; - - __MIDL___MIDL_itf_dimm_0000_0010 = packed record - cbSize: SYSUINT; - fType: SYSUINT; - fState: SYSUINT; - wID: SYSUINT; - hbmpChecked: wireHBITMAP; - hbmpUnchecked: wireHBITMAP; - dwItemData: LongWord; - szString: array[0..79] of Shortint; - hbmpItem: wireHBITMAP; - end; - - IMEMENUITEMINFOA = __MIDL___MIDL_itf_dimm_0000_0010; - - _userBITMAP = packed record - bmType: Integer; - bmWidth: Integer; - bmHeight: Integer; - bmWidthBytes: Integer; - bmPlanes: Word; - bmBitsPixel: Word; - cbSize: LongWord; - pBuffer: ^Byte; - end; - - __MIDL_IWinTypes_0007 = record - case Integer of - 0: (hInproc: Integer); - 1: (hRemote: ^_userBITMAP); - end; - - _userHBITMAP = packed record - fContext: Integer; - u: __MIDL_IWinTypes_0007; - end; - - __MIDL___MIDL_itf_dimm_0000_0011 = packed record - cbSize: SYSUINT; - fType: SYSUINT; - fState: SYSUINT; - wID: SYSUINT; - hbmpChecked: wireHBITMAP; - hbmpUnchecked: wireHBITMAP; - dwItemData: LongWord; - szString: array[0..79] of Word; - hbmpItem: wireHBITMAP; - end; - - IMEMENUITEMINFOW = __MIDL___MIDL_itf_dimm_0000_0011; - - __MIDL___MIDL_itf_dimm_0000_0013 = record - case Integer of - 0: (A: LOGFONTA); - 1: (W: LOGFONTW); - end; - - __MIDL___MIDL_itf_dimm_0000_0012 = packed record - hWnd: wireHWND; - fOpen: Integer; - ptStatusWndPos: tagPOINT; - ptSoftKbdPos: tagPOINT; - fdwConversion: LongWord; - fdwSentence: LongWord; - lfFont: __MIDL___MIDL_itf_dimm_0000_0013; - cfCompForm: COMPOSITIONFORM; - cfCandForm: array[0..3] of CANDIDATEFORM; - hCompStr: LongWord; - hCandInfo: LongWord; - hGuideLine: LongWord; - hPrivate: LongWord; - dwNumMsgBuf: LongWord; - hMsgBuf: LongWord; - fdwInit: LongWord; - dwReserve: array[0..2] of LongWord; - end; - - __MIDL_IWinTypes_0009 = record - case Integer of - 0: (hInproc: Integer); - 1: (hRemote: Integer); - end; - - _RemotableHandle = packed record - fContext: Integer; - u: __MIDL_IWinTypes_0009; - end; - - INPUTCONTEXT = __MIDL___MIDL_itf_dimm_0000_0012; - - __MIDL___MIDL_itf_dimm_0000_0014 = packed record - dwPrivateDataSize: LongWord; - fdwProperty: LongWord; - fdwConversionCaps: LongWord; - fdwSentenceCaps: LongWord; - fdwUICaps: LongWord; - fdwSCSCaps: LongWord; - fdwSelectCaps: LongWord; - end; - - IMEINFO = __MIDL___MIDL_itf_dimm_0000_0014; - UINT_PTR = LongWord; - LONG_PTR = Integer; - - tagMSG = packed record - hWnd: wireHWND; - message: SYSUINT; - wParam: UINT_PTR; - lParam: LONG_PTR; - time: LongWord; - pt: tagPOINT; - end; - - -// *********************************************************************// -// Interface: IEnumRegisterWordA -// Flags: (0) -// GUID: {08C03412-F96B-11D0-A475-00AA006BCC59} -// *********************************************************************// - IEnumRegisterWordA = interface(IUnknown) - ['{08C03412-F96B-11D0-A475-00AA006BCC59}'] - function Clone(out ppEnum: IEnumRegisterWordA): HResult; stdcall; - function Next(ulCount: LongWord; out rgRegisterWord: REGISTERWORDA; out pcFetched: LongWord): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(ulCount: LongWord): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IEnumRegisterWordW -// Flags: (0) -// GUID: {4955DD31-B159-11D0-8FCF-00AA006BCC59} -// *********************************************************************// - IEnumRegisterWordW = interface(IUnknown) - ['{4955DD31-B159-11D0-8FCF-00AA006BCC59}'] - function Clone(out ppEnum: IEnumRegisterWordW): HResult; stdcall; - function Next(ulCount: LongWord; out rgRegisterWord: REGISTERWORDW; out pcFetched: LongWord): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(ulCount: LongWord): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IEnumInputContext -// Flags: (0) -// GUID: {09B5EAB0-F997-11D1-93D4-0060B067B86E} -// *********************************************************************// - IEnumInputContext = interface(IUnknown) - ['{09B5EAB0-F997-11D1-93D4-0060B067B86E}'] - function Clone(out ppEnum: IEnumInputContext): HResult; stdcall; - function Next(ulCount: LongWord; out rgInputContext: LongWord; out pcFetched: LongWord): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(ulCount: LongWord): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIMMRegistrar -// Flags: (0) -// GUID: {B3458082-BD00-11D1-939B-0060B067B86E} -// *********************************************************************// - IActiveIMMRegistrar = interface(IUnknown) - ['{B3458082-BD00-11D1-939B-0060B067B86E}'] - function RegisterIME(var rclsid: TGUID; lgid: Word; pszIconFile: PWideChar; pszDesc: PWideChar): HResult; stdcall; - function UnregisterIME(var rclsid: TGUID): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIMMMessagePumpOwner -// Flags: (0) -// GUID: {B5CF2CFA-8AEB-11D1-9364-0060B067B86E} -// *********************************************************************// - IActiveIMMMessagePumpOwner = interface(IUnknown) - ['{B5CF2CFA-8AEB-11D1-9364-0060B067B86E}'] - function Start: HResult; stdcall; - function End_: HResult; stdcall; - function OnTranslateMessage(var pMsg: tagMSG): HResult; stdcall; - function Pause(out pdwCookie: LongWord): HResult; stdcall; - function Resume(dwCookie: LongWord): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIMMApp -// Flags: (0) -// GUID: {08C0E040-62D1-11D1-9326-0060B067B86E} -// *********************************************************************// - IActiveIMMApp = interface(IUnknown) - ['{08C0E040-62D1-11D1-9326-0060B067B86E}'] - function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; stdcall; - function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDA): HResult; stdcall; - function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDW): HResult; stdcall; - function CreateContext(out phIMC: LongWord): HResult; stdcall; - function DestroyContext(hIME: LongWord): HResult; stdcall; - function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; stdcall; - function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar; var pData: Pointer; - out pEnum: IEnumRegisterWordW): HResult; stdcall; - function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; stdcall; - function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; stdcall; - function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; stdcall; - function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; stdcall; - function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; stdcall; - function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; stdcall; - function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; stdcall; - function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; - function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; - function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; stdcall; - function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; stdcall; - function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; - uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; - uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; - out puCopied: SYSUINT): HResult; stdcall; - function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; - out pfdwSentence: LongWord): HResult; stdcall; - function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; stdcall; - function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; - out pdwResult: LongWord): HResult; stdcall; - function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; - out pdwResult: LongWord): HResult; stdcall; - function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetOpenStatus(hIMC: LongWord): HResult; stdcall; - function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; stdcall; - function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; - out puCopied: SYSUINT): HResult; stdcall; - function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; - out puCopied: SYSUINT): HResult; stdcall; - function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; stdcall; - function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; stdcall; - function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; stdcall; - function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; stdcall; - function IsIME(var hKL: Pointer): HResult; stdcall; - function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; stdcall; - function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; stdcall; - function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; - function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; stdcall; - function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar): HResult; stdcall; - function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; stdcall; - function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; stdcall; - function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; stdcall; - function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; stdcall; - function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; - function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; - function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; stdcall; - function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; stdcall; - function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; stdcall; - function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; stdcall; - function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; stdcall; - function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szUnregister: PAnsiChar): HResult; stdcall; - function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szUnregister: PWideChar): HResult; stdcall; - function Activate(fRestoreLayout: Integer): HResult; stdcall; - function Deactivate: HResult; stdcall; - function OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; - function FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; stdcall; - function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; stdcall; - function GetLangId(var hKL: Pointer; out plid: Word): HResult; stdcall; - function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; stdcall; - function DisableIME(idThread: LongWord): HResult; stdcall; - function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOA; - out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; - out pdwResult: LongWord): HResult; stdcall; - function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOW; - out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; - out pdwResult: LongWord): HResult; stdcall; - function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIMMIME -// Flags: (0) -// GUID: {08C03411-F96B-11D0-A475-00AA006BCC59} -// *********************************************************************// - IActiveIMMIME = interface(IUnknown) - ['{08C03411-F96B-11D0-A475-00AA006BCC59}'] - function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; stdcall; - function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDA): HResult; stdcall; - function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDW): HResult; stdcall; - function CreateContext(out phIMC: LongWord): HResult; stdcall; - function DestroyContext(hIME: LongWord): HResult; stdcall; - function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; stdcall; - function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar; var pData: Pointer; - out pEnum: IEnumRegisterWordW): HResult; stdcall; - function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; stdcall; - function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; stdcall; - function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; stdcall; - function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; stdcall; - function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; stdcall; - function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; stdcall; - function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; stdcall; - function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; - function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; stdcall; - function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; stdcall; - function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; stdcall; - function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; - uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; - uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; - out puCopied: SYSUINT): HResult; stdcall; - function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; - out pfdwSentence: LongWord): HResult; stdcall; - function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; stdcall; - function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; - out pdwResult: LongWord): HResult; stdcall; - function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; - out pdwResult: LongWord): HResult; stdcall; - function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; - out puCopied: SYSUINT): HResult; stdcall; - function GetOpenStatus(hIMC: LongWord): HResult; stdcall; - function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; stdcall; - function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; - out puCopied: SYSUINT): HResult; stdcall; - function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; - out puCopied: SYSUINT): HResult; stdcall; - function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; stdcall; - function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; stdcall; - function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; stdcall; - function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; stdcall; - function IsIME(var hKL: Pointer): HResult; stdcall; - function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; stdcall; - function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; stdcall; - function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; - function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; stdcall; - function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar): HResult; stdcall; - function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; stdcall; - function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; stdcall; - function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; stdcall; - function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; stdcall; - function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; - function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; - function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; stdcall; - function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; stdcall; - function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; stdcall; - function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; stdcall; - function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; stdcall; - function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szUnregister: PAnsiChar): HResult; stdcall; - function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szUnregister: PWideChar): HResult; stdcall; - function GenerateMessage(hIMC: LongWord): HResult; stdcall; - function LockIMC(hIMC: LongWord; out ppIMC: PUserType12): HResult; stdcall; - function UnlockIMC(hIMC: LongWord): HResult; stdcall; - function GetIMCLockCount(hIMC: LongWord; out pdwLockCount: LongWord): HResult; stdcall; - function CreateIMCC(dwSize: LongWord; out phIMCC: LongWord): HResult; stdcall; - function DestroyIMCC(hIMCC: LongWord): HResult; stdcall; - function LockIMCC(hIMCC: LongWord; out ppv: Pointer): HResult; stdcall; - function UnlockIMCC(hIMCC: LongWord): HResult; stdcall; - function ReSizeIMCC(hIMCC: LongWord; dwSize: LongWord; out phIMCC: LongWord): HResult; stdcall; - function GetIMCCSize(hIMCC: LongWord; out pdwSize: LongWord): HResult; stdcall; - function GetIMCCLockCount(hIMCC: LongWord; out pdwLockCount: LongWord): HResult; stdcall; - function GetHotKey(dwHotKeyID: LongWord; out puModifiers: SYSUINT; out puVKey: SYSUINT; - out phKL: Pointer): HResult; stdcall; - function SetHotKey(dwHotKeyID: LongWord; uModifiers: SYSUINT; uVKey: SYSUINT; var hKL: Pointer): HResult; stdcall; - function CreateSoftKeyboard(uType: SYSUINT; var hOwner: _RemotableHandle; x: SYSINT; - y: SYSINT; out phSoftKbdWnd: wireHWND): HResult; stdcall; - function DestroySoftKeyboard(var hSoftKbdWnd: _RemotableHandle): HResult; stdcall; - function ShowSoftKeyboard(var hSoftKbdWnd: _RemotableHandle; nCmdShow: SYSINT): HResult; stdcall; - function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; stdcall; - function GetLangId(var hKL: Pointer; out plid: Word): HResult; stdcall; - function KeybdEvent(lgidIME: Word; bVk: Byte; bScan: Byte; dwFlags: LongWord; - dwExtraInfo: LongWord): HResult; stdcall; - function LockModal: HResult; stdcall; - function UnlockModal: HResult; stdcall; - function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; stdcall; - function DisableIME(idThread: LongWord): HResult; stdcall; - function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOA; - out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; - out pdwResult: LongWord): HResult; stdcall; - function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOW; - out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; - out pdwResult: LongWord): HResult; stdcall; - function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; stdcall; - function RequestMessageA(hIMC: LongWord; wParam: UINT_PTR; lParam: LONG_PTR; - out plResult: LONG_PTR): HResult; stdcall; - function RequestMessageW(hIMC: LongWord; wParam: UINT_PTR; lParam: LONG_PTR; - out plResult: LONG_PTR): HResult; stdcall; - function SendIMCA(var hWnd: _RemotableHandle; uMsg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; - function SendIMCW(var hWnd: _RemotableHandle; uMsg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR; out plResult: LONG_PTR): HResult; stdcall; - function IsSleeping: HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIME -// Flags: (0) -// GUID: {6FE20962-D077-11D0-8FE7-00AA006BCC59} -// *********************************************************************// - IActiveIME = interface(IUnknown) - ['{6FE20962-D077-11D0-8FE7-00AA006BCC59}'] - function Inquire(dwSystemInfoFlags: LongWord; out pIMEInfo: IMEINFO; szWndClass: PWideChar; - out pdwPrivate: LongWord): HResult; stdcall; - function ConversionList(hIMC: LongWord; szSource: PWideChar; uFlag: SYSUINT; uBufLen: SYSUINT; - out pDest: CANDIDATELIST; out puCopied: SYSUINT): HResult; stdcall; - function Configure(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pRegisterWord: REGISTERWORDW): HResult; stdcall; - function Destroy(uReserved: SYSUINT): HResult; stdcall; - function Escape(hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; out plResult: LONG_PTR): HResult; stdcall; - function SetActiveContext(hIMC: LongWord; fFlag: Integer): HResult; stdcall; - function ProcessKey(hIMC: LongWord; uVirKey: SYSUINT; lParam: LongWord; var pbKeyState: Byte): HResult; stdcall; - function Notify(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; stdcall; - function Select(hIMC: LongWord; fSelect: Integer): HResult; stdcall; - function SetCompositionString(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; stdcall; - function ToAsciiEx(uVirKey: SYSUINT; uScanCode: SYSUINT; var pbKeyState: Byte; - fuState: SYSUINT; hIMC: LongWord; out pdwTransBuf: LongWord; - out puSize: SYSUINT): HResult; stdcall; - function RegisterWord(szReading: PWideChar; dwStyle: LongWord; szString: PWideChar): HResult; stdcall; - function UnregisterWord(szReading: PWideChar; dwStyle: LongWord; szString: PWideChar): HResult; stdcall; - function GetRegisterWordStyle(nItem: SYSUINT; out pStyleBuf: STYLEBUFW; out puBufSize: SYSUINT): HResult; stdcall; - function EnumRegisterWord(szReading: PWideChar; dwStyle: LongWord; szRegister: PWideChar; - var pData: Pointer; out ppEnum: IEnumRegisterWordW): HResult; stdcall; - function GetCodePageA(out uCodePage: SYSUINT): HResult; stdcall; - function GetLangId(out plid: Word): HResult; stdcall; - end; - -// *********************************************************************// -// Interface: IActiveIME2 -// Flags: (0) -// GUID: {E1C4BF0E-2D53-11D2-93E1-0060B067B86E} -// *********************************************************************// - IActiveIME2 = interface(IActiveIME) - ['{E1C4BF0E-2D53-11D2-93E1-0060B067B86E}'] - function Sleep: HResult; stdcall; - function Unsleep(fDead: Integer): HResult; stdcall; - end; - -// *********************************************************************// -// The Class CoCActiveIMM provides a Create and CreateRemote method to -// create instances of the default interface IActiveIMMApp exposed by -// the CoClass CActiveIMM. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// - CoCActiveIMM = class - class function Create: IActiveIMMApp; - class function CreateRemote(const MachineName: AnsiString): IActiveIMMApp; - end; - - -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TCActiveIMM -// Help String : -// Default Interface: IActiveIMMApp -// Def. Intf. DISP? : No -// Event Interface: -// TypeFlags : (2) CanCreate -// *********************************************************************// -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} - TCActiveIMMProperties= class; -{$ENDIF} - TCActiveIMM = class(TOleServer) - private - FIntf: IActiveIMMApp; -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} - FProps: TCActiveIMMProperties; - function GetServerProperties: TCActiveIMMProperties; -{$ENDIF} - function GetDefaultInterface: IActiveIMMApp; - protected - procedure InitServerData; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure Connect; override; - procedure ConnectTo(svrIntf: IActiveIMMApp); - procedure Disconnect; override; - function AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; out phPrev: LongWord): HResult; - function ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDA): HResult; - function ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDW): HResult; - function CreateContext(out phIMC: LongWord): HResult; - function DestroyContext(hIME: LongWord): HResult; - function EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szRegister: PAnsiChar; var pData: Pointer; out pEnum: IEnumRegisterWordA): HResult; - function EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar; var pData: Pointer; - out pEnum: IEnumRegisterWordW): HResult; - function EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; - function EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; var pData: Pointer; - out plResult: LONG_PTR): HResult; - function GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; - function GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; - function GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; - function GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; - function GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; out pCandidate: CANDIDATEFORM): HResult; - function GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; - function GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; - function GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; - function GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; - function GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; - function GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; - function GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; uBufLen: SYSUINT; - uFlag: SYSUINT; out pDst: CANDIDATELIST; out puCopied: SYSUINT): HResult; - function GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; - uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; - out puCopied: SYSUINT): HResult; - function GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; - out pfdwSentence: LongWord): HResult; - function GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; - function GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; - out puCopied: SYSUINT): HResult; - function GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; - out puCopied: SYSUINT): HResult; - function GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PAnsiChar; - out pdwResult: LongWord): HResult; - function GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; pBuf: PWideChar; - out pdwResult: LongWord): HResult; - function GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; - out puCopied: SYSUINT): HResult; - function GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; - out puCopied: SYSUINT): HResult; - function GetOpenStatus(hIMC: LongWord): HResult; - function GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; - function GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFA; - out puCopied: SYSUINT): HResult; - function GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; out pStyleBuf: STYLEBUFW; - out puCopied: SYSUINT): HResult; - function GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; - function GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; - function InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; - function InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; out phKL: Pointer): HResult; - function IsIME(var hKL: Pointer): HResult; - function IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; - function IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; - function NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; dwValue: LongWord): HResult; - function REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; szRegister: PAnsiChar): HResult; - function REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar): HResult; - function ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; - function SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; - function SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; - function SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; - function SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; - function SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; dwReadLen: LongWord): HResult; - function SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; - function SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; fdwSentence: LongWord): HResult; - function SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; - function SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; - function SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; - function UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szUnregister: PAnsiChar): HResult; - function UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szUnregister: PWideChar): HResult; - function Activate(fRestoreLayout: Integer): HResult; - function Deactivate: HResult; - function OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR; out plResult: LONG_PTR): HResult; - function FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; - function GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; - function GetLangId(var hKL: Pointer; out plid: Word): HResult; - function AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; dwFlags: LongWord): HResult; - function DisableIME(idThread: LongWord): HResult; - function GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOA; - out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; - out pdwResult: LongWord): HResult; - function GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOW; - out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; - out pdwResult: LongWord): HResult; - function EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; - property DefaultInterface: IActiveIMMApp read GetDefaultInterface; - published -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} - property Server: TCActiveIMMProperties read GetServerProperties; -{$ENDIF} - end; - -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TCActiveIMM -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// - TCActiveIMMProperties = class(TPersistent) - private - FServer: TCActiveIMM; - function GetDefaultInterface: IActiveIMMApp; - constructor Create(AServer: TCActiveIMM); - protected - public - property DefaultInterface: IActiveIMMApp read GetDefaultInterface; - published - end; -{$ENDIF} - -implementation - -uses - ComObj; - -class function CoCActiveIMM.Create: IActiveIMMApp; -begin - Result := CreateComObject(CLASS_CActiveIMM) as IActiveIMMApp; -end; - -class function CoCActiveIMM.CreateRemote(const MachineName: AnsiString): IActiveIMMApp; -begin - Result := CreateRemoteComObject(MachineName, CLASS_CActiveIMM) as IActiveIMMApp; -end; - -procedure TCActiveIMM.InitServerData; -const - CServerData: TServerData = ( - ClassID: '{4955DD33-B159-11D0-8FCF-00AA006BCC59}'; - IntfIID: '{08C0E040-62D1-11D1-9326-0060B067B86E}'; - EventIID: ''; - LicenseKey: nil; - Version: 500); -begin - ServerData := @CServerData; -end; - -procedure TCActiveIMM.Connect; -var - punk: IUnknown; -begin - if FIntf = nil then - begin - punk := GetServer; - Fintf:= punk as IActiveIMMApp; - end; -end; - -procedure TCActiveIMM.ConnectTo(svrIntf: IActiveIMMApp); -begin - Disconnect; - FIntf := svrIntf; -end; - -procedure TCActiveIMM.DisConnect; -begin - if Fintf <> nil then - begin - FIntf := nil; - end; -end; - -function TCActiveIMM.GetDefaultInterface: IActiveIMMApp; -begin - if FIntf = nil then - Connect; - Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation'); - Result := FIntf; -end; - -constructor TCActiveIMM.Create(AOwner: TComponent); -begin - inherited Create(AOwner); -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} - FProps := TCActiveIMMProperties.Create(Self); -{$ENDIF} -end; - -destructor TCActiveIMM.Destroy; -begin -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} - FProps.Free; -{$ENDIF} - inherited Destroy; -end; - -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -function TCActiveIMM.GetServerProperties: TCActiveIMMProperties; -begin - Result := FProps; -end; -{$ENDIF} - -function TCActiveIMM.AssociateContext(var hWnd: _RemotableHandle; hIME: LongWord; - out phPrev: LongWord): HResult; -begin - Result := DefaultInterface.AssociateContext(hWnd, hIME, phPrev); -end; - -function TCActiveIMM.ConfigureIMEA(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDA): HResult; -begin - Result := DefaultInterface.ConfigureIMEA(hKL, hWnd, dwMode, pData); -end; - -function TCActiveIMM.ConfigureIMEW(var hKL: Pointer; var hWnd: _RemotableHandle; dwMode: LongWord; - var pData: REGISTERWORDW): HResult; -begin - Result := DefaultInterface.ConfigureIMEW(hKL, hWnd, dwMode, pData); -end; - -function TCActiveIMM.CreateContext(out phIMC: LongWord): HResult; -begin - Result := DefaultInterface.CreateContext(phIMC); -end; - -function TCActiveIMM.DestroyContext(hIME: LongWord): HResult; -begin - Result := DefaultInterface.DestroyContext(hIME); -end; - -function TCActiveIMM.EnumRegisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szRegister: PAnsiChar; var pData: Pointer; - out pEnum: IEnumRegisterWordA): HResult; -begin - Result := DefaultInterface.EnumRegisterWordA(hKL, szReading, dwStyle, szRegister, pData, pEnum); -end; - -function TCActiveIMM.EnumRegisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar; var pData: Pointer; - out pEnum: IEnumRegisterWordW): HResult; -begin - Result := DefaultInterface.EnumRegisterWordW(hKL, szReading, dwStyle, szRegister, pData, pEnum); -end; - -function TCActiveIMM.EscapeA(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; - var pData: Pointer; out plResult: LONG_PTR): HResult; -begin - Result := DefaultInterface.EscapeA(hKL, hIMC, uEscape, pData, plResult); -end; - -function TCActiveIMM.EscapeW(var hKL: Pointer; hIMC: LongWord; uEscape: SYSUINT; - var pData: Pointer; out plResult: LONG_PTR): HResult; -begin - Result := DefaultInterface.EscapeW(hKL, hIMC, uEscape, pData, plResult); -end; - -function TCActiveIMM.GetCandidateListA(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetCandidateListA(hIMC, dwIndex, uBufLen, pCandList, puCopied); -end; - -function TCActiveIMM.GetCandidateListW(hIMC: LongWord; dwIndex: LongWord; uBufLen: SYSUINT; - out pCandList: CANDIDATELIST; out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetCandidateListW(hIMC, dwIndex, uBufLen, pCandList, puCopied); -end; - -function TCActiveIMM.GetCandidateListCountA(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; -begin - Result := DefaultInterface.GetCandidateListCountA(hIMC, pdwListSize, pdwBufLen); -end; - -function TCActiveIMM.GetCandidateListCountW(hIMC: LongWord; out pdwListSize: LongWord; - out pdwBufLen: LongWord): HResult; -begin - Result := DefaultInterface.GetCandidateListCountW(hIMC, pdwListSize, pdwBufLen); -end; - -function TCActiveIMM.GetCandidateWindow(hIMC: LongWord; dwIndex: LongWord; - out pCandidate: CANDIDATEFORM): HResult; -begin - Result := DefaultInterface.GetCandidateWindow(hIMC, dwIndex, pCandidate); -end; - -function TCActiveIMM.GetCompositionFontA(hIMC: LongWord; out plf: LOGFONTA): HResult; -begin - Result := DefaultInterface.GetCompositionFontA(hIMC, plf); -end; - -function TCActiveIMM.GetCompositionFontW(hIMC: LongWord; out plf: LOGFONTW): HResult; -begin - Result := DefaultInterface.GetCompositionFontW(hIMC, plf); -end; - -function TCActiveIMM.GetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; -begin - Result := DefaultInterface.GetCompositionStringA(hIMC, dwIndex, dwBufLen, plCopied, pBuf); -end; - -function TCActiveIMM.GetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - out plCopied: Integer; out pBuf: Pointer): HResult; -begin - Result := DefaultInterface.GetCompositionStringW(hIMC, dwIndex, dwBufLen, plCopied, pBuf); -end; - -function TCActiveIMM.GetCompositionWindow(hIMC: LongWord; out pCompForm: COMPOSITIONFORM): HResult; -begin - Result := DefaultInterface.GetCompositionWindow(hIMC, pCompForm); -end; - -function TCActiveIMM.GetContext(var hWnd: _RemotableHandle; out phIMC: LongWord): HResult; -begin - Result := DefaultInterface.GetContext(hWnd, phIMC); -end; - -function TCActiveIMM.GetConversionListA(var hKL: Pointer; hIMC: LongWord; pSrc: PAnsiChar; - uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetConversionListA(hKL, hIMC, pSrc, uBufLen, uFlag, pDst, puCopied); -end; - -function TCActiveIMM.GetConversionListW(var hKL: Pointer; hIMC: LongWord; pSrc: PWideChar; - uBufLen: SYSUINT; uFlag: SYSUINT; out pDst: CANDIDATELIST; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetConversionListW(hKL, hIMC, pSrc, uBufLen, uFlag, pDst, puCopied); -end; - -function TCActiveIMM.GetConversionStatus(hIMC: LongWord; out pfdwConversion: LongWord; - out pfdwSentence: LongWord): HResult; -begin - Result := DefaultInterface.GetConversionStatus(hIMC, pfdwConversion, pfdwSentence); -end; - -function TCActiveIMM.GetDefaultIMEWnd(var hWnd: _RemotableHandle; out phDefWnd: wireHWND): HResult; -begin - Result := DefaultInterface.GetDefaultIMEWnd(hWnd, phDefWnd); -end; - -function TCActiveIMM.GetDescriptionA(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PAnsiChar; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetDescriptionA(hKL, uBufLen, szDescription, puCopied); -end; - -function TCActiveIMM.GetDescriptionW(var hKL: Pointer; uBufLen: SYSUINT; szDescription: PWideChar; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetDescriptionW(hKL, uBufLen, szDescription, puCopied); -end; - -function TCActiveIMM.GetGuideLineA(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - pBuf: PAnsiChar; out pdwResult: LongWord): HResult; -begin - Result := DefaultInterface.GetGuideLineA(hIMC, dwIndex, dwBufLen, pBuf, pdwResult); -end; - -function TCActiveIMM.GetGuideLineW(hIMC: LongWord; dwIndex: LongWord; dwBufLen: LongWord; - pBuf: PWideChar; out pdwResult: LongWord): HResult; -begin - Result := DefaultInterface.GetGuideLineW(hIMC, dwIndex, dwBufLen, pBuf, pdwResult); -end; - -function TCActiveIMM.GetIMEFileNameA(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PAnsiChar; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetIMEFileNameA(hKL, uBufLen, szFileName, puCopied); -end; - -function TCActiveIMM.GetIMEFileNameW(var hKL: Pointer; uBufLen: SYSUINT; szFileName: PWideChar; - out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetIMEFileNameW(hKL, uBufLen, szFileName, puCopied); -end; - -function TCActiveIMM.GetOpenStatus(hIMC: LongWord): HResult; -begin - Result := DefaultInterface.GetOpenStatus(hIMC); -end; - -function TCActiveIMM.GetProperty(var hKL: Pointer; fdwIndex: LongWord; out pdwProperty: LongWord): HResult; -begin - Result := DefaultInterface.GetProperty(hKL, fdwIndex, pdwProperty); -end; - -function TCActiveIMM.GetRegisterWordStyleA(var hKL: Pointer; nItem: SYSUINT; - out pStyleBuf: STYLEBUFA; out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetRegisterWordStyleA(hKL, nItem, pStyleBuf, puCopied); -end; - -function TCActiveIMM.GetRegisterWordStyleW(var hKL: Pointer; nItem: SYSUINT; - out pStyleBuf: STYLEBUFW; out puCopied: SYSUINT): HResult; -begin - Result := DefaultInterface.GetRegisterWordStyleW(hKL, nItem, pStyleBuf, puCopied); -end; - -function TCActiveIMM.GetStatusWindowPos(hIMC: LongWord; out pptPos: tagPOINT): HResult; -begin - Result := DefaultInterface.GetStatusWindowPos(hIMC, pptPos); -end; - -function TCActiveIMM.GetVirtualKey(var hWnd: _RemotableHandle; out puVirtualKey: SYSUINT): HResult; -begin - Result := DefaultInterface.GetVirtualKey(hWnd, puVirtualKey); -end; - -function TCActiveIMM.InstallIMEA(szIMEFileName: PAnsiChar; szLayoutText: PAnsiChar; out phKL: Pointer): HResult; -begin - Result := DefaultInterface.InstallIMEA(szIMEFileName, szLayoutText, phKL); -end; - -function TCActiveIMM.InstallIMEW(szIMEFileName: PWideChar; szLayoutText: PWideChar; - out phKL: Pointer): HResult; -begin - Result := DefaultInterface.InstallIMEW(szIMEFileName, szLayoutText, phKL); -end; - -function TCActiveIMM.IsIME(var hKL: Pointer): HResult; -begin - Result := DefaultInterface.IsIME(hKL); -end; - -function TCActiveIMM.IsUIMessageA(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; -begin - Result := DefaultInterface.IsUIMessageA(hWndIME, msg, wParam, lParam); -end; - -function TCActiveIMM.IsUIMessageW(var hWndIME: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR): HResult; -begin - Result := DefaultInterface.IsUIMessageW(hWndIME, msg, wParam, lParam); -end; - -function TCActiveIMM.NotifyIME(hIMC: LongWord; dwAction: LongWord; dwIndex: LongWord; - dwValue: LongWord): HResult; -begin - Result := DefaultInterface.NotifyIME(hIMC, dwAction, dwIndex, dwValue); -end; - -function TCActiveIMM.REGISTERWORDA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szRegister: PAnsiChar): HResult; -begin - Result := DefaultInterface.REGISTERWORDA(hKL, szReading, dwStyle, szRegister); -end; - -function TCActiveIMM.REGISTERWORDW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szRegister: PWideChar): HResult; -begin - Result := DefaultInterface.REGISTERWORDW(hKL, szReading, dwStyle, szRegister); -end; - -function TCActiveIMM.ReleaseContext(var hWnd: _RemotableHandle; hIMC: LongWord): HResult; -begin - Result := DefaultInterface.ReleaseContext(hWnd, hIMC); -end; - -function TCActiveIMM.SetCandidateWindow(hIMC: LongWord; var pCandidate: CANDIDATEFORM): HResult; -begin - Result := DefaultInterface.SetCandidateWindow(hIMC, pCandidate); -end; - -function TCActiveIMM.SetCompositionFontA(hIMC: LongWord; var plf: LOGFONTA): HResult; -begin - Result := DefaultInterface.SetCompositionFontA(hIMC, plf); -end; - -function TCActiveIMM.SetCompositionFontW(hIMC: LongWord; var plf: LOGFONTW): HResult; -begin - Result := DefaultInterface.SetCompositionFontW(hIMC, plf); -end; - -function TCActiveIMM.SetCompositionStringA(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; - dwReadLen: LongWord): HResult; -begin - Result := DefaultInterface.SetCompositionStringA(hIMC, dwIndex, pComp, dwCompLen, pRead, dwReadLen); -end; - -function TCActiveIMM.SetCompositionStringW(hIMC: LongWord; dwIndex: LongWord; var pComp: Pointer; - dwCompLen: LongWord; var pRead: Pointer; - dwReadLen: LongWord): HResult; -begin - Result := DefaultInterface.SetCompositionStringW(hIMC, dwIndex, pComp, dwCompLen, pRead, dwReadLen); -end; - -function TCActiveIMM.SetCompositionWindow(hIMC: LongWord; var pCompForm: COMPOSITIONFORM): HResult; -begin - Result := DefaultInterface.SetCompositionWindow(hIMC, pCompForm); -end; - -function TCActiveIMM.SetConversionStatus(hIMC: LongWord; fdwConversion: LongWord; - fdwSentence: LongWord): HResult; -begin - Result := DefaultInterface.SetConversionStatus(hIMC, fdwConversion, fdwSentence); -end; - -function TCActiveIMM.SetOpenStatus(hIMC: LongWord; fOpen: Integer): HResult; -begin - Result := DefaultInterface.SetOpenStatus(hIMC, fOpen); -end; - -function TCActiveIMM.SetStatusWindowPos(hIMC: LongWord; var pptPos: tagPOINT): HResult; -begin - Result := DefaultInterface.SetStatusWindowPos(hIMC, pptPos); -end; - -function TCActiveIMM.SimulateHotKey(var hWnd: _RemotableHandle; dwHotKeyID: LongWord): HResult; -begin - Result := DefaultInterface.SimulateHotKey(hWnd, dwHotKeyID); -end; - -function TCActiveIMM.UnregisterWordA(var hKL: Pointer; szReading: PAnsiChar; dwStyle: LongWord; - szUnregister: PAnsiChar): HResult; -begin - Result := DefaultInterface.UnregisterWordA(hKL, szReading, dwStyle, szUnregister); -end; - -function TCActiveIMM.UnregisterWordW(var hKL: Pointer; szReading: PWideChar; dwStyle: LongWord; - szUnregister: PWideChar): HResult; -begin - Result := DefaultInterface.UnregisterWordW(hKL, szReading, dwStyle, szUnregister); -end; - -function TCActiveIMM.Activate(fRestoreLayout: Integer): HResult; -begin - Result := DefaultInterface.Activate(fRestoreLayout); -end; - -function TCActiveIMM.Deactivate: HResult; -begin - Result := DefaultInterface.Deactivate; -end; - -function TCActiveIMM.OnDefWindowProc(var hWnd: _RemotableHandle; msg: SYSUINT; wParam: UINT_PTR; - lParam: LONG_PTR; out plResult: LONG_PTR): HResult; -begin - Result := DefaultInterface.OnDefWindowProc(hWnd, msg, wParam, lParam, plResult); -end; - -function TCActiveIMM.FilterClientWindows(var aaClassList: Word; uSize: SYSUINT): HResult; -begin - Result := DefaultInterface.FilterClientWindows(aaClassList, uSize); -end; - -function TCActiveIMM.GetCodePageA(var hKL: Pointer; out uCodePage: SYSUINT): HResult; -begin - Result := DefaultInterface.GetCodePageA(hKL, uCodePage); -end; - -function TCActiveIMM.GetLangId(var hKL: Pointer; out plid: Word): HResult; -begin - Result := DefaultInterface.GetLangId(hKL, plid); -end; - -function TCActiveIMM.AssociateContextEx(var hWnd: _RemotableHandle; hIMC: LongWord; - dwFlags: LongWord): HResult; -begin - Result := DefaultInterface.AssociateContextEx(hWnd, hIMC, dwFlags); -end; - -function TCActiveIMM.DisableIME(idThread: LongWord): HResult; -begin - Result := DefaultInterface.DisableIME(idThread); -end; - -function TCActiveIMM.GetImeMenuItemsA(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOA; - out pImeMenu: IMEMENUITEMINFOA; dwSize: LongWord; - out pdwResult: LongWord): HResult; -begin - Result := DefaultInterface.GetImeMenuItemsA(hIMC, dwFlags, dwType, pImeParentMenu, pImeMenu, - dwSize, pdwResult); -end; - -function TCActiveIMM.GetImeMenuItemsW(hIMC: LongWord; dwFlags: LongWord; dwType: LongWord; - var pImeParentMenu: IMEMENUITEMINFOW; - out pImeMenu: IMEMENUITEMINFOW; dwSize: LongWord; - out pdwResult: LongWord): HResult; -begin - Result := DefaultInterface.GetImeMenuItemsW(hIMC, dwFlags, dwType, pImeParentMenu, pImeMenu, - dwSize, pdwResult); -end; - -function TCActiveIMM.EnumInputContext(idThread: LongWord; out ppEnum: IEnumInputContext): HResult; -begin - Result := DefaultInterface.EnumInputContext(idThread, ppEnum); -end; - -{$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -constructor TCActiveIMMProperties.Create(AServer: TCActiveIMM); -begin - inherited Create; - FServer := AServer; -end; - -function TCActiveIMMProperties.GetDefaultInterface: IActiveIMMApp; -begin - Result := FServer.DefaultInterface; -end; - -{$ENDIF} - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas deleted file mode 100644 index 0f3e69893c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas +++ /dev/null @@ -1,835 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntActnList; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Controls, ActnList, Buttons, ExtCtrls, ComCtrls, StdCtrls, Menus; - -type -{TNT-WARN TActionList} - TTntActionList = class(TActionList{TNT-ALLOW TActionList}) - private - FCheckActionsTimer: TTimer; - procedure CheckActions(Sender: TObject); - public - constructor Create(AOwner: TComponent); override; - end; - - ITntAction = interface - ['{59D0AE37-8161-4AD6-9102-14B28E5761EB}'] - end; - -//--------------------------------------------------------------------------------------------- -// ACTIONS -//--------------------------------------------------------------------------------------------- - -{TNT-WARN TCustomAction} - TTntCustomAction = class(TCustomAction{TNT-ALLOW TCustomAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TAction} - TTntAction = class(TAction{TNT-ALLOW TAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -//--------------------------------------------------------------------------------------------- - -// MENU ACTION LINK -//--------------------------------------------------------------------------------------------- - -{TNT-WARN TMenuActionLink} - TTntMenuActionLink = class(TMenuActionLink{TNT-ALLOW TMenuActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -//--------------------------------------------------------------------------------------------- -// CONTROL ACTION LINKS -//--------------------------------------------------------------------------------------------- - -{TNT-WARN TListViewActionLink} - TTntListViewActionLink = class(TListViewActionLink{TNT-ALLOW TListViewActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -{TNT-WARN TComboBoxExActionLink} - TTntComboBoxExActionLink = class(TComboBoxExActionLink{TNT-ALLOW TComboBoxExActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -{TNT-WARN TSpeedButtonActionLink} - TTntSpeedButtonActionLink = class(TSpeedButtonActionLink{TNT-ALLOW TSpeedButtonActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - {$IFDEF COMPILER_10_UP} - function IsImageIndexLinked: Boolean; override; - procedure SetImageIndex(Value: Integer); override; - {$ENDIF} - end; - -{$IFDEF COMPILER_10_UP} -{TNT-WARN TBitBtnActionLink} - TTntBitBtnActionLink = class(TBitBtnActionLink{TNT-ALLOW TBitBtnActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - {$IFDEF COMPILER_10_UP} - function IsImageIndexLinked: Boolean; override; - procedure SetImageIndex(Value: Integer); override; - {$ENDIF} - end; -{$ENDIF} - -{TNT-WARN TToolButtonActionLink} - TTntToolButtonActionLink = class(TToolButtonActionLink{TNT-ALLOW TToolButtonActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -{TNT-WARN TButtonActionLink} - TTntButtonActionLink = class(TButtonActionLink{TNT-ALLOW TButtonActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -{TNT-WARN TWinControlActionLink} - TTntWinControlActionLink = class(TWinControlActionLink{TNT-ALLOW TWinControlActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -{TNT-WARN TControlActionLink} - TTntControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}) - protected - function IsCaptionLinked: Boolean; override; - function IsHintLinked: Boolean; override; - procedure SetCaption(const Value: string{TNT-ALLOW string}); override; - procedure SetHint(const Value: string{TNT-ALLOW string}); override; - end; - -//--------------------------------------------------------------------------------------------- -// helper procs -//--------------------------------------------------------------------------------------------- - -//-- TCustomAction helper routines -procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); -function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; -function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; -procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); -function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; -function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; -procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); - -// -- TControl helper routines -function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; -procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); - -// -- TControlActionLink helper routines -function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; -function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; -procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); -procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); - -type - TUpgradeActionListItemsProc = procedure (ActionList: TTntActionList); - -var - UpgradeActionListItemsProc: TUpgradeActionListItemsProc; - -implementation - -uses - SysUtils, TntMenus, TntClasses, TntControls; - -{ TActionListList } - -type - TActionListList = class(TList) - private - FActionList: TTntActionList; - protected - procedure Notify(Ptr: Pointer; Action: TListNotification); override; - end; - -procedure TActionListList.Notify(Ptr: Pointer; Action: TListNotification); -begin - inherited; - if (Action = lnAdded) and (FActionList <> nil) and (Ptr <> nil) - and (not Supports(TObject(Ptr), ITntAction)) then - begin - FActionList.FCheckActionsTimer.Enabled := False; - FActionList.FCheckActionsTimer.Enabled := True; - end; -end; - -{ THackActionList } - -type -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - THackCustomActionList = class(TComponent) - private - FActions: TList; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - THackCustomActionList = class(TComponent) - private - FActions: TList; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - THackCustomActionList = class(TComponent) - private - FActions: TList; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - THackCustomActionList = class(TComponent) - private - FActions: TList; - end; -{$ENDIF} - -{ TTntActionList } - -constructor TTntActionList.Create(AOwner: TComponent); -begin - inherited; - if (csDesigning in ComponentState) then begin - FCheckActionsTimer := TTimer.Create(Self); - FCheckActionsTimer.Enabled := False; - FCheckActionsTimer.Interval := 50; - FCheckActionsTimer.OnTimer := CheckActions; - // - THackCustomActionList(Self).FActions.Free; - THackCustomActionList(Self).FActions := TActionListList.Create; - TActionListList(THackCustomActionList(Self).FActions).FActionList := Self; - end; -end; - -procedure TTntActionList.CheckActions(Sender: TObject); -begin - if FCheckActionsTimer <> nil then begin - FCheckActionsTimer.Enabled := False; - end; - Assert(csDesigning in ComponentState); - Assert(Assigned(UpgradeActionListItemsProc)); - UpgradeActionListItemsProc(Self); -end; - -{ TCustomActionHelper } - -type - TCustomActionHelper = class(TComponent) - private - FAction: TCustomAction{TNT-ALLOW TCustomAction}; - private - FCaption: WideString; - FSettingNewCaption: Boolean; - FOldWideCaption: WideString; - FNewAnsiCaption: AnsiString; - procedure SetAnsiCaption(const Value: AnsiString); - function SettingNewCaption: Boolean; - procedure SetCaption(const Value: WideString); - function GetCaption: WideString; - private - FHint: WideString; - FSettingNewHint: Boolean; - FOldWideHint: WideString; - FNewAnsiHint: AnsiString; - procedure SetAnsiHint(const Value: AnsiString); - function SettingNewHint: Boolean; - procedure SetHint(const Value: WideString); - function GetHint: WideString; - end; - -procedure TCustomActionHelper.SetAnsiCaption(const Value: AnsiString); -begin - FAction.Caption := Value; - if (Value = '') and (FNewAnsiCaption <> '') then - FOldWideCaption := ''; -end; - -function TCustomActionHelper.SettingNewCaption: Boolean; -begin - Result := FSettingNewCaption and (FAction.Caption <> FNewAnsiCaption); -end; - -function TCustomActionHelper.GetCaption: WideString; -begin - if SettingNewCaption then - Result := FOldWideCaption - else - Result := GetSyncedWideString(FCaption, FAction.Caption) -end; - -procedure TCustomActionHelper.SetCaption(const Value: WideString); -begin - FOldWideCaption := GetCaption; - FNewAnsiCaption := Value; - FSettingNewCaption := True; - try - SetSyncedWideString(Value, FCaption, FAction.Caption, SetAnsiCaption) - finally - FSettingNewCaption := False; - end; -end; - -procedure TCustomActionHelper.SetAnsiHint(const Value: AnsiString); -begin - FAction.Hint := Value; - if (Value = '') and (FNewAnsiHint <> '') then - FOldWideHint := ''; -end; - -function TCustomActionHelper.SettingNewHint: Boolean; -begin - Result := FSettingNewHint and (FAction.Hint <> FNewAnsiHint); -end; - -function TCustomActionHelper.GetHint: WideString; -begin - if SettingNewHint then - Result := FOldWideHint - else - Result := GetSyncedWideString(FHint, FAction.Hint) -end; - -procedure TCustomActionHelper.SetHint(const Value: WideString); -begin - FOldWideHint := GetHint; - FNewAnsiHint := Value; - FSettingNewHint := True; - try - SetSyncedWideString(Value, FHint, FAction.Hint, SetAnsiHint) - finally - FSettingNewHint := False; - end; -end; - -function FindActionHelper(Action: TCustomAction{TNT-ALLOW TCustomAction}): TCustomActionHelper; -var - i: integer; -begin - Assert(Action <> nil); - Result := nil; - if Supports(Action, ITntAction) then begin - for i := 0 to Action.ComponentCount - 1 do begin - if Action.Components[i] is TCustomActionHelper then begin - Result := TCustomActionHelper(Action.Components[i]); - break; - end; - end; - if Result = nil then begin - Result := TCustomActionHelper.Create(Action); - Result.FAction := Action; - end; - end; -end; - -//-- TCustomAction helper routines - -procedure TntAction_SetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); -begin - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - SetCaption(Value) - else - Action.Caption := Value; -end; - -function TntAction_GetCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; -begin - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - Result := GetCaption - else - Result := Action.Caption; -end; - -function TntAction_GetNewCaption(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; -begin - Result := Default; - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - if SettingNewCaption then - Result := FCaption; -end; - -procedure TntAction_SetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Value: WideString); -begin - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - SetHint(Value) - else - Action.Hint := Value; -end; - -function TntAction_GetHint(Action: TCustomAction{TNT-ALLOW TCustomAction}): WideString; -begin - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - Result := GetHint - else - Result := Action.Hint; -end; - -function TntAction_GetNewHint(Action: TCustomAction{TNT-ALLOW TCustomAction}; const Default: WideString): WideString; -begin - Result := Default; - if Supports(Action, ITntAction) then - with FindActionHelper(Action) do - if SettingNewHint then - Result := FHint; -end; - -procedure TntAction_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - with Action do begin - if (Source is TCustomAction{TNT-ALLOW TCustomAction}) then begin - Caption := TntAction_GetCaption(Source as TCustomAction{TNT-ALLOW TCustomAction}); - Hint := TntAction_GetHint(Source as TCustomAction{TNT-ALLOW TCustomAction}); - end else if (Source is TControl) then begin - Caption := TntControl_GetText(Source as TControl); - Hint := TntControl_GetHint(Source as TControl); - end; - end; -end; - -// -- TControl helper routines - -function TntControl_GetActionLinkClass(Control: TControl; InheritedLinkClass: TControlActionLinkClass): TControlActionLinkClass; -begin - if Control is TCustomListView{TNT-ALLOW TCustomListView} then - Result := TTntListViewActionLink - else if Control is TComboBoxEx then - Result := TTntComboBoxExActionLink - else if Control is TSpeedButton{TNT-ALLOW TSpeedButton} then - Result := TTntSpeedButtonActionLink - {$IFDEF COMPILER_10_UP} - else if Control is TBitBtn{TNT-ALLOW TBitBtn} then - Result := TTntBitBtnActionLink - {$ENDIF} - else if Control is TToolButton{TNT-ALLOW TToolButton} then - Result := TTntToolButtonActionLink - else if Control is TButtonControl then - Result := TTntButtonActionLink - else if Control is TWinControl then - Result := TTntWinControlActionLink - else - Result := TTntControlActionLink; - - Assert(Result.ClassParent = InheritedLinkClass); -end; - -procedure TntControl_BeforeInherited_ActionChange(Control: TControl; Sender: TObject; CheckDefaults: Boolean); -begin - if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin - if not CheckDefaults or (TntControl_GetText(Control) = '') or (TntControl_GetText(Control) = Control.Name) then - TntControl_SetText(Control, TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); - if not CheckDefaults or (TntControl_GetHint(Control) = '') then - TntControl_SetHint(Control, TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender))); - end; -end; - -// -- TControlActionLink helper routines - -function TntActionLink_IsCaptionLinked(InheritedIsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; -begin - Result := InheritedIsCaptionLinked - and (TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetText(FClient)); -end; - -function TntActionLink_IsHintLinked(InheritedIsHintLinked: Boolean; Action: TBasicAction; FClient: TControl): Boolean; -begin - Result := InheritedIsHintLinked - and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = TntControl_GetHint(FClient)); -end; - -procedure TntActionLink_SetCaption(IsCaptionLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); -begin - if IsCaptionLinked then - TntControl_SetText(FClient, TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); -end; - -procedure TntActionLink_SetHint(IsHintLinked: Boolean; Action: TBasicAction; FClient: TControl; const Value: string{TNT-ALLOW string}); -begin - if IsHintLinked then - TntControl_SetHint(FClient, TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value)); -end; - -//--------------------------------------------------------------------------------------------- -// ACTIONS -//--------------------------------------------------------------------------------------------- - -{ TTntCustomAction } - -procedure TTntCustomAction.Assign(Source: TPersistent); -begin - inherited; - TntAction_AfterInherited_Assign(Self, Source); -end; - -procedure TTntCustomAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntCustomAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntCustomAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntCustomAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntAction } - -procedure TTntAction.Assign(Source: TPersistent); -begin - inherited; - TntAction_AfterInherited_Assign(Self, Source); -end; - -procedure TTntAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -//--------------------------------------------------------------------------------------------- -// MENU ACTION LINK -//--------------------------------------------------------------------------------------------- - -{ TTntMenuActionLink } - -function TTntMenuActionLink.IsCaptionLinked: Boolean; -begin - Result := inherited IsCaptionLinked - and WideSameCaption(TntAction_GetCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}), (FClient as TTntMenuItem).Caption); -end; - -function TTntMenuActionLink.IsHintLinked: Boolean; -begin - Result := inherited IsHintLinked - and (TntAction_GetHint(Action as TCustomAction{TNT-ALLOW TCustomAction}) = (FClient as TTntMenuItem).Hint); -end; - -procedure TTntMenuActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - if IsCaptionLinked then - (FClient as TTntMenuItem).Caption := TntAction_GetNewCaption(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); -end; - -procedure TTntMenuActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - if IsHintLinked then - (FClient as TTntMenuItem).Hint := TntAction_GetNewHint(Action as TCustomAction{TNT-ALLOW TCustomAction}, Value); -end; - -//--------------------------------------------------------------------------------------------- -// CONTROL ACTION LINKS -//--------------------------------------------------------------------------------------------- - -{ TTntListViewActionLink } - -function TTntListViewActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntListViewActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntListViewActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntListViewActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{ TTntComboBoxExActionLink } - -function TTntComboBoxExActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntComboBoxExActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntComboBoxExActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntComboBoxExActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{ TTntSpeedButtonActionLink } - -function TTntSpeedButtonActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntSpeedButtonActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntSpeedButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntSpeedButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{$IFDEF COMPILER_10_UP} -// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. - -function TTntSpeedButtonActionLink.IsImageIndexLinked: Boolean; -begin - Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked -end; - -procedure TTntSpeedButtonActionLink.SetImageIndex(Value: Integer); -begin - ; // taken from TActionLink.IsImageIndexLinked -end; -{$ENDIF} - -{$IFDEF COMPILER_10_UP} -{ TTntBitBtnActionLink } - -function TTntBitBtnActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntBitBtnActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntBitBtnActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntBitBtnActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{$IFDEF COMPILER_10_UP} -// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. - -function TTntBitBtnActionLink.IsImageIndexLinked: Boolean; -begin - Result := Action is TCustomAction{TNT-ALLOW TCustomAction}; // taken from TActionLink.IsImageIndexLinked -end; - -procedure TTntBitBtnActionLink.SetImageIndex(Value: Integer); -begin - ; // taken from TActionLink.IsImageIndexLinked -end; -{$ENDIF} - -{$ENDIF} - -{ TTntToolButtonActionLink } - -function TTntToolButtonActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntToolButtonActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntToolButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntToolButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{ TTntButtonActionLink } - -function TTntButtonActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntButtonActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntButtonActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntButtonActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{ TTntWinControlActionLink } - -function TTntWinControlActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntWinControlActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntWinControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntWinControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -{ TTntControlActionLink } - -function TTntControlActionLink.IsCaptionLinked: Boolean; -begin - Result := TntActionLink_IsCaptionLinked(inherited IsCaptionLinked, Action, FClient); -end; - -function TTntControlActionLink.IsHintLinked: Boolean; -begin - Result := TntActionLink_IsHintLinked(inherited IsHintLinked, Action, FClient); -end; - -procedure TTntControlActionLink.SetCaption(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetCaption(IsCaptionLinked, Action, FClient, Value); -end; - -procedure TTntControlActionLink.SetHint(const Value: string{TNT-ALLOW string}); -begin - TntActionLink_SetHint(IsHintLinked, Action, FClient, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas deleted file mode 100644 index bc4b03c883..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas +++ /dev/null @@ -1,191 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntAxCtrls; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - ComObj, StdVcl, - {$IFNDEF COMPILER_10_UP} - TntWideStrings, - {$ELSE} - WideStrings, - {$ENDIF} - TntClasses; - -type - TWideStringsAdapter = class(TAutoIntfObject, IStrings, IWideStringsAdapter) - private - FStrings: TWideStrings; - protected - { IWideStringsAdapter } - procedure ReferenceStrings(S: TWideStrings); - procedure ReleaseStrings; - { IStrings } - function Get_ControlDefault(Index: Integer): OleVariant; safecall; - procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall; - function Count: Integer; safecall; - function Get_Item(Index: Integer): OleVariant; safecall; - procedure Set_Item(Index: Integer; Value: OleVariant); safecall; - procedure Remove(Index: Integer); safecall; - procedure Clear; safecall; - function Add(Item: OleVariant): Integer; safecall; - function _NewEnum: IUnknown; safecall; - public - constructor Create(Strings: TTntStrings); - end; - -implementation - -uses - Classes, ActiveX, Variants; - -{ TStringsEnumerator } - -type - TStringsEnumerator = class(TContainedObject, IEnumString) - private - FIndex: Integer; // index of next unread string - FStrings: IStrings; - public - constructor Create(const Strings: IStrings); - function Next(celt: Longint; out elt; - pceltFetched: PLongint): HResult; stdcall; - function Skip(celt: Longint): HResult; stdcall; - function Reset: HResult; stdcall; - function Clone(out enm: IEnumString): HResult; stdcall; - end; - -constructor TStringsEnumerator.Create(const Strings: IStrings); -begin - inherited Create(Strings); - FStrings := Strings; -end; - -function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; -var - I: Integer; -begin - I := 0; - while (I < celt) and (FIndex < FStrings.Count) do - begin - TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[FIndex])); - Inc(I); - Inc(FIndex); - end; - if pceltFetched <> nil then pceltFetched^ := I; - if I = celt then Result := S_OK else Result := S_FALSE; -end; - -function TStringsEnumerator.Skip(celt: Longint): HResult; -begin - if (FIndex + celt) <= FStrings.Count then - begin - Inc(FIndex, celt); - Result := S_OK; - end - else - begin - FIndex := FStrings.Count; - Result := S_FALSE; - end; -end; - -function TStringsEnumerator.Reset: HResult; -begin - FIndex := 0; - Result := S_OK; -end; - -function TStringsEnumerator.Clone(out enm: IEnumString): HResult; -begin - try - enm := TStringsEnumerator.Create(FStrings); - TStringsEnumerator(enm).FIndex := FIndex; - Result := S_OK; - except - Result := E_UNEXPECTED; - end; -end; - -{ TWideStringsAdapter } - -constructor TWideStringsAdapter.Create(Strings: TTntStrings); -var - StdVcl: ITypeLib; -begin - OleCheck(LoadRegTypeLib(LIBID_STDVCL, 4, 0, 0, StdVcl)); - inherited Create(StdVcl, IStrings); - FStrings := Strings; -end; - -procedure TWideStringsAdapter.ReferenceStrings(S: TWideStrings); -begin - FStrings := S; -end; - -procedure TWideStringsAdapter.ReleaseStrings; -begin - FStrings := nil; -end; - -function TWideStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant; -begin - Result := Get_Item(Index); -end; - -procedure TWideStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant); -begin - Set_Item(Index, Value); -end; - -function TWideStringsAdapter.Count: Integer; -begin - Result := 0; - if FStrings <> nil then Result := FStrings.Count; -end; - -function TWideStringsAdapter.Get_Item(Index: Integer): OleVariant; -begin - Result := NULL; - if (FStrings <> nil) then Result := WideString(FStrings[Index]); -end; - -procedure TWideStringsAdapter.Set_Item(Index: Integer; Value: OleVariant); -begin - if (FStrings <> nil) then FStrings[Index] := Value; -end; - -procedure TWideStringsAdapter.Remove(Index: Integer); -begin - if FStrings <> nil then FStrings.Delete(Index); -end; - -procedure TWideStringsAdapter.Clear; -begin - if FStrings <> nil then FStrings.Clear; -end; - -function TWideStringsAdapter.Add(Item: OleVariant): Integer; -begin - Result := -1; - if FStrings <> nil then Result := FStrings.Add(Item); -end; - -function TWideStringsAdapter._NewEnum: IUnknown; -begin - Result := TStringsEnumerator.Create(Self); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas deleted file mode 100644 index 2528c42ffb..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas +++ /dev/null @@ -1,92 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntBandActn; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, BandActn, TntActnList; - -type -{TNT-WARN TCustomizeActionBars} - TTntCustomizeActionBars = class(TCustomizeActionBars{TNT-ALLOW TCustomizeActionBars}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -implementation - -uses - ActnList, TntClasses; - -{TNT-IGNORE-UNIT} - -procedure TntBandActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntAction_AfterInherited_Assign(Action, Source); - // TCustomizeActionBars - if (Action is TCustomizeActionBars) and (Source is TCustomizeActionBars) then begin - TCustomizeActionBars(Action).ActionManager := TCustomizeActionBars(Source).ActionManager; - end; -end; - -//------------------------- -// TNT BAND ACTN -//------------------------- - -{ TTntCustomizeActionBars } - -procedure TTntCustomizeActionBars.Assign(Source: TPersistent); -begin - inherited; - TntBandActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntCustomizeActionBars.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomizeActionBars.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntCustomizeActionBars.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntCustomizeActionBars.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntCustomizeActionBars.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas deleted file mode 100644 index dd2ab6028c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas +++ /dev/null @@ -1,982 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntButtons; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, Messages, Classes, Controls, Graphics, StdCtrls, - ExtCtrls, CommCtrl, Buttons, - TntControls; - -type - ITntGlyphButton = interface - ['{15D7E501-1E33-4293-8B45-716FB3B14504}'] - function GetButtonGlyph: Pointer; - procedure UpdateInternalGlyphList; - end; - -{TNT-WARN TSpeedButton} - TTntSpeedButton = class(TSpeedButton {TNT-ALLOW TSpeedButton}, ITntGlyphButton) - private - FPaintInherited: Boolean; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - function GetButtonGlyph: Pointer; - procedure UpdateInternalGlyphList; dynamic; - procedure PaintButton; dynamic; - procedure Paint; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TBitBtn} - TTntBitBtn = class(TBitBtn {TNT-ALLOW TBitBtn}, ITntGlyphButton) - private - FPaintInherited: Boolean; - FMouseInControl: Boolean; - function IsCaptionStored: Boolean; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; - procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; - procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; - protected - function GetButtonGlyph: Pointer; - procedure UpdateInternalGlyphList; dynamic; - procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; - const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; - Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; - BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); - -function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; - const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; - Spacing: Integer; State: TButtonState; Transparent: Boolean; - BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; - -implementation - -uses - SysUtils, ActnList, TntForms, TntStdCtrls, TypInfo, RTLConsts, TntWindows, - {$IFDEF THEME_7_UP} Themes, {$ENDIF} TntClasses, TntActnList, TntSysUtils; - -type - EAbortPaint = class(EAbort); - -// Many routines in this unit are nearly the same as those found in Buttons.pas. They are -// included here because the VCL implementation of TButtonGlyph is completetly inaccessible. - -type - THackButtonGlyph_D6_D7_D9 = class - protected - FOriginal: TBitmap; - FGlyphList: TImageList; - FIndexs: array[TButtonState] of Integer; - FxxxxTransparentColor: TColor; - FNumGlyphs: TNumGlyphs; - end; - - THackBitBtn_D6_D7_D9 = class(TButton{TNT-ALLOW TButton}) - protected - FCanvas: TCanvas; - FGlyph: Pointer; - FxxxxStyle: TButtonStyle; - FxxxxKind: TBitBtnKind; - FxxxxLayout: TButtonLayout; - FxxxxSpacing: Integer; - FxxxxMargin: Integer; - IsFocused: Boolean; - end; - - THackSpeedButton_D6_D7_D9 = class(TGraphicControl) - protected - FxxxxGroupIndex: Integer; - FGlyph: Pointer; - FxxxxDown: Boolean; - FDragging: Boolean; - end; - - {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - THackButtonGlyph = THackButtonGlyph_D6_D7_D9; - THackBitBtn = THackBitBtn_D6_D7_D9; - THackSpeedButton = THackSpeedButton_D6_D7_D9; - {$ENDIF} - {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - THackButtonGlyph = THackButtonGlyph_D6_D7_D9; - THackBitBtn = THackBitBtn_D6_D7_D9; - THackSpeedButton = THackSpeedButton_D6_D7_D9; - {$ENDIF} - {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - THackButtonGlyph = THackButtonGlyph_D6_D7_D9; - THackBitBtn = THackBitBtn_D6_D7_D9; - THackSpeedButton = THackSpeedButton_D6_D7_D9; - {$ENDIF} - {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - THackButtonGlyph = THackButtonGlyph_D6_D7_D9; - THackBitBtn = THackBitBtn_D6_D7_D9; - THackSpeedButton = THackSpeedButton_D6_D7_D9; - {$ENDIF} - -function GetButtonGlyph(Control: TControl): THackButtonGlyph; -var - GlyphButton: ITntGlyphButton; -begin - if Control.GetInterface(ITntGlyphButton, GlyphButton) then - Result := GlyphButton.GetButtonGlyph - else - raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); -end; - -procedure UpdateInternalGlyphList(Control: TControl); -var - GlyphButton: ITntGlyphButton; -begin - if Control.GetInterface(ITntGlyphButton, GlyphButton) then - GlyphButton.UpdateInternalGlyphList - else - raise ETntInternalError.Create('Internal Error: Control does not support ITntGlyphButton.'); -end; - -function TButtonGlyph_CreateButtonGlyph(Control: TControl; State: TButtonState): Integer; -var - ButtonGlyph: THackButtonGlyph; - NumGlyphs: Integer; -begin - ButtonGlyph := GetButtonGlyph(Control); - NumGlyphs := ButtonGlyph.FNumGlyphs; - - if (State = bsDown) and (NumGlyphs < 3) then State := bsUp; - Result := ButtonGlyph.FIndexs[State]; - if (Result = -1) then begin - UpdateInternalGlyphList(Control); - Result := ButtonGlyph.FIndexs[State]; - end; -end; - -procedure TButtonGlyph_DrawButtonGlyph(Control: TControl; Canvas: TCanvas; const GlyphPos: TPoint; - State: TButtonState; Transparent: Boolean); -var - ButtonGlyph: THackButtonGlyph; - Glyph: TBitmap; - GlyphList: TImageList; - Index: Integer; - {$IFDEF THEME_7_UP} - Details: TThemedElementDetails; - R: TRect; - Button: TThemedButton; - {$ENDIF} -begin - ButtonGlyph := GetButtonGlyph(Control); - Glyph := ButtonGlyph.FOriginal; - GlyphList := ButtonGlyph.FGlyphList; - if Glyph = nil then Exit; - if (Glyph.Width = 0) or (Glyph.Height = 0) then Exit; - Index := TButtonGlyph_CreateButtonGlyph(Control, State); - with GlyphPos do - {$IFDEF THEME_7_UP} - if ThemeServices.ThemesEnabled then begin - R.TopLeft := GlyphPos; - R.Right := R.Left + Glyph.Width div ButtonGlyph.FNumGlyphs; - R.Bottom := R.Top + Glyph.Height; - case State of - bsDisabled: - Button := tbPushButtonDisabled; - bsDown, - bsExclusive: - Button := tbPushButtonPressed; - else - // bsUp - Button := tbPushButtonNormal; - end; - Details := ThemeServices.GetElementDetails(Button); - ThemeServices.DrawIcon(Canvas.Handle, Details, R, GlyphList.Handle, Index); - end else - {$ENDIF} - if Transparent or (State = bsExclusive) then - ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, - clNone, clNone, ILD_Transparent) - else - ImageList_DrawEx(GlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0, - ColorToRGB(clBtnFace), clNone, ILD_Normal); -end; - -procedure TButtonGlyph_DrawButtonText(Canvas: TCanvas; const Caption: WideString; - TextBounds: TRect; State: TButtonState; - BiDiFlags: LongInt {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); -begin - with Canvas do - begin - Brush.Style := bsClear; - if State = bsDisabled then - begin - OffsetRect(TextBounds, 1, 1); - Font.Color := clBtnHighlight; - - {$IFDEF COMPILER_7_UP} - if WordWrap then - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_VCENTER or BiDiFlags or DT_WORDBREAK) - else - {$ENDIF} - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_VCENTER or BiDiFlags); - - OffsetRect(TextBounds, -1, -1); - Font.Color := clBtnShadow; - - {$IFDEF COMPILER_7_UP} - if WordWrap then - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } - else - {$ENDIF} - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_VCENTER or BiDiFlags); - - end else - begin - {$IFDEF COMPILER_7_UP} - if WordWrap then - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_WORDBREAK or BiDiFlags) { TODO: Figure out why DT_VCENTER is not used } - else - {$ENDIF} - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds, - DT_CENTER or DT_VCENTER or BiDiFlags); - end; - end; -end; - -procedure TButtonGlyph_CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; - const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; - Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; - BiDiFlags: Integer {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}); -var - TextPos: TPoint; - ClientSize, - GlyphSize, - TextSize: TPoint; - TotalSize: TPoint; - Glyph: TBitmap; - NumGlyphs: Integer; - ButtonGlyph: THackButtonGlyph; -begin - ButtonGlyph := GetButtonGlyph(Control); - Glyph := ButtonGlyph.FOriginal; - NumGlyphs := ButtonGlyph.FNumGlyphs; - - if (BiDiFlags and DT_RIGHT) = DT_RIGHT then - if Layout = blGlyphLeft then - Layout := blGlyphRight - else - if Layout = blGlyphRight then - Layout := blGlyphLeft; - - // Calculate the item sizes. - ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top); - - if Assigned(Glyph) then - GlyphSize := Point(Glyph.Width div NumGlyphs, Glyph.Height) - else - GlyphSize := Point(0, 0); - - if Length(Caption) > 0 then - begin - {$IFDEF COMPILER_7_UP} - TextBounds := Rect(0, 0, Client.Right - Client.Left - GlyphSize.X - 3, 0); { TODO: Figure out why GlyphSize.X is in here. } - {$ELSE} - TextBounds := Rect(0, 0, Client.Right - Client.Left, 0); - {$ENDIF} - - {$IFDEF COMPILER_7_UP} - if WordWrap then - Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_WORDBREAK - or DT_CALCRECT or BiDiFlags) - else - {$ENDIF} - Tnt_DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_CALCRECT or BiDiFlags); - - TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top); - end - else - begin - TextBounds := Rect(0, 0, 0, 0); - TextSize := Point(0, 0); - end; - - // If the layout has the glyph on the right or the left, then both the text and the glyph are centered vertically. - // If the glyph is on the top or the bottom, then both the text and the glyph are centered horizontally. - if Layout in [blGlyphLeft, blGlyphRight] then - begin - GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2; - TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2; - end - else - begin - GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2; - TextPos.X := (ClientSize.X - TextSize.X + 1) div 2; - end; - - // If there is no text or no bitmap, then Spacing is irrelevant. - if (TextSize.X = 0) or (GlyphSize.X = 0) then - Spacing := 0; - - // Adjust Margin and Spacing. - if Margin = -1 then - begin - if Spacing = -1 then - begin - TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y); - if Layout in [blGlyphLeft, blGlyphRight] then - Margin := (ClientSize.X - TotalSize.X) div 3 - else - Margin := (ClientSize.Y - TotalSize.Y) div 3; - Spacing := Margin; - end - else - begin - TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y); - if Layout in [blGlyphLeft, blGlyphRight] then - Margin := (ClientSize.X - TotalSize.X + 1) div 2 - else - Margin := (ClientSize.Y - TotalSize.Y + 1) div 2; - end; - end - else - begin - if Spacing = -1 then - begin - TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y - (Margin + GlyphSize.Y)); - if Layout in [blGlyphLeft, blGlyphRight] then - Spacing := (TotalSize.X - TextSize.X) div 2 - else - Spacing := (TotalSize.Y - TextSize.Y) div 2; - end; - end; - - case Layout of - blGlyphLeft: - begin - GlyphPos.X := Margin; - TextPos.X := GlyphPos.X + GlyphSize.X + Spacing; - end; - blGlyphRight: - begin - GlyphPos.X := ClientSize.X - Margin - GlyphSize.X; - TextPos.X := GlyphPos.X - Spacing - TextSize.X; - end; - blGlyphTop: - begin - GlyphPos.Y := Margin; - TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing; - end; - blGlyphBottom: - begin - GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y; - TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y; - end; - end; - - // Fixup the Result variables. - with GlyphPos do - begin - Inc(X, Client.Left + Offset.X); - Inc(Y, Client.Top + Offset.Y); - end; - - {$IFDEF THEME_7_UP} - { Themed text is not shifted, but gets a different color. } - if ThemeServices.ThemesEnabled then - OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top) - else - {$ENDIF} - OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y); -end; - -function TButtonGlyph_Draw(Control: TControl; Canvas: TCanvas; const Client: TRect; - const Offset: TPoint; const Caption: WideString; Layout: TButtonLayout; Margin: Integer; - Spacing: Integer; State: TButtonState; Transparent: Boolean; - BiDiFlags: Longint {$IFDEF COMPILER_7_UP}; WordWrap: Boolean {$ENDIF}): TRect; -var - GlyphPos: TPoint; -begin - TButtonGlyph_CalcButtonLayout(Control, Canvas.Handle, Client, Offset, Caption, Layout, Margin, - Spacing, GlyphPos, Result, BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); - TButtonGlyph_DrawButtonGlyph(Control, Canvas, GlyphPos, State, Transparent); - TButtonGlyph_DrawButtonText(Canvas, Caption, Result, State, - BiDiFlags {$IFDEF COMPILER_7_UP}, WordWrap {$ENDIF}); -end; - -{ TTntSpeedButton } - -procedure TTntSpeedButton.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSpeedButton.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntSpeedButton.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntSpeedButton.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntSpeedButton.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntSpeedButton.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntSpeedButton.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntSpeedButton.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntSpeedButton.CMDialogChar(var Message: TCMDialogChar); -begin - with Message do - if IsWideCharAccel(CharCode, Caption) and Enabled and Visible and - (Parent <> nil) and Parent.Showing then - begin - Click; - Result := 1; - end else - inherited; -end; - -function TTntSpeedButton.GetButtonGlyph: Pointer; -begin - Result := THackSpeedButton(Self).FGlyph; -end; - -procedure TTntSpeedButton.UpdateInternalGlyphList; -begin - FPaintInherited := True; - try - Repaint; - finally - FPaintInherited := False; - end; - Invalidate; - raise EAbortPaint.Create(''); -end; - -procedure TTntSpeedButton.Paint; -begin - if FPaintInherited then - inherited - else - PaintButton; -end; - -procedure TTntSpeedButton.PaintButton; -const - DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER); - FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0); -var - PaintRect: TRect; - DrawFlags: Integer; - Offset: TPoint; - {$IFDEF THEME_7_UP} - Button: TThemedButton; - ToolButton: TThemedToolBar; - Details: TThemedElementDetails; - {$ENDIF} -begin - try - if not Enabled then - begin - FState := bsDisabled; - THackSpeedButton(Self).FDragging := False; - end - else if FState = bsDisabled then - if Down and (GroupIndex <> 0) then - FState := bsExclusive - else - FState := bsUp; - Canvas.Font := Self.Font; - - {$IFDEF THEME_7_UP} - if ThemeServices.ThemesEnabled then - begin - {$IFDEF COMPILER_7_UP} - PerformEraseBackground(Self, Canvas.Handle); - {$ENDIF} - SelectObject(Canvas.Handle, Canvas.Font.Handle); { For some reason, PerformEraseBackground sometimes messes the font up. } - - if not Enabled then - Button := tbPushButtonDisabled - else - if FState in [bsDown, bsExclusive] then - Button := tbPushButtonPressed - else - if MouseInControl then - Button := tbPushButtonHot - else - Button := tbPushButtonNormal; - - ToolButton := ttbToolbarDontCare; - if Flat then - begin - case Button of - tbPushButtonDisabled: - Toolbutton := ttbButtonDisabled; - tbPushButtonPressed: - Toolbutton := ttbButtonPressed; - tbPushButtonHot: - Toolbutton := ttbButtonHot; - tbPushButtonNormal: - Toolbutton := ttbButtonNormal; - end; - end; - - PaintRect := ClientRect; - if ToolButton = ttbToolbarDontCare then - begin - Details := ThemeServices.GetElementDetails(Button); - ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); - PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); - end - else - begin - Details := ThemeServices.GetElementDetails(ToolButton); - ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect); - PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect); - end; - - if Button = tbPushButtonPressed then - begin - // A pressed speed button has a white text. This applies however only to flat buttons. - if ToolButton <> ttbToolbarDontCare then - Canvas.Font.Color := clHighlightText; - Offset := Point(1, 0); - end - else - Offset := Point(0, 0); - TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, Layout, Margin, Spacing, FState, - Transparent, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); - end - else - {$ENDIF} - begin - PaintRect := Rect(0, 0, Width, Height); - if not Flat then - begin - DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; - if FState in [bsDown, bsExclusive] then - DrawFlags := DrawFlags or DFCS_PUSHED; - DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags); - end - else - begin - if (FState in [bsDown, bsExclusive]) or - (MouseInControl and (FState <> bsDisabled)) or - (csDesigning in ComponentState) then - DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]], - FillStyles[Transparent] or BF_RECT) - else if not Transparent then - begin - Canvas.Brush.Color := Color; - Canvas.FillRect(PaintRect); - end; - InflateRect(PaintRect, -1, -1); - end; - if FState in [bsDown, bsExclusive] then - begin - if (FState = bsExclusive) and (not Flat or not MouseInControl) then - begin - Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); - Canvas.FillRect(PaintRect); - end; - Offset.X := 1; - Offset.Y := 1; - end - else - begin - Offset.X := 0; - Offset.Y := 0; - end; - TButtonGlyph_Draw(Self, Canvas, PaintRect, Offset, Caption, - Layout, Margin, Spacing, FState, Transparent, - DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, False {$ENDIF}); - end; - except - on E: EAbortPaint do - ; - else - raise; - end; -end; - -function TTntSpeedButton.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{$IFDEF COMPILER_10_UP} -type - TAccessGraphicControl = class(TGraphicControl); -{$ENDIF} - -procedure TTntSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); -{$IFDEF COMPILER_10_UP} -// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. -type - CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; -var - M: TMethod; -{$ENDIF} -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - {$IFNDEF COMPILER_10_UP} - inherited; - {$ELSE} - // call TGraphicControl.ActionChange (bypass TSpeedButton.ActionChange) - M.Code := @TAccessGraphicControl.ActionChange; - M.Data := Self; - CallActionChange(M)(Sender, CheckDefaults); - // call Delphi2005's TSpeedButton.ActionChange - if Sender is TCustomAction{TNT-ALLOW TCustomAction} then - with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do - begin - if CheckDefaults or (Self.GroupIndex = 0) then - Self.GroupIndex := GroupIndex; - { Copy image from action's imagelist } - if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and - (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then - CopyImage(ActionList.Images, ImageIndex); - end; - {$ENDIF} -end; - -{ TTntBitBtn } - -procedure TTntBitBtn.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'BUTTON'); -end; - -procedure TTntBitBtn.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntBitBtn.IsCaptionStored: Boolean; -var - BaseClass: TClass; - PropInfo: PPropInfo; -begin - Assert(Self is TButton{TNT-ALLOW TButton}); - Assert(Self is TBitBtn{TNT-ALLOW TBitBtn}); - if Kind = bkCustom then - // don't use TBitBtn, it's broken for Kind <> bkCustom - BaseClass := TButton{TNT-ALLOW TButton} - else begin - //TBitBtn has it's own storage specifier, based upon the button kind - BaseClass := TBitBtn{TNT-ALLOW TBitBtn}; - end; - PropInfo := GetPropInfo(BaseClass, 'Caption'); - if PropInfo = nil then - raise EPropertyError.CreateResFmt(PResStringRec(@SUnknownProperty), ['Caption']); - Result := IsStoredProp(Self, PropInfo); -end; - -function TTntBitBtn.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntBitBtn.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntBitBtn.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntBitBtn.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntBitBtn.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntBitBtn.CMDialogChar(var Message: TCMDialogChar); -begin - TntButton_CMDialogChar(Self, Message); -end; - -function TTntBitBtn.GetButtonGlyph: Pointer; -begin - Result := THackBitBtn(Self).FGlyph; -end; - -procedure TTntBitBtn.UpdateInternalGlyphList; -begin - FPaintInherited := True; - try - Repaint; - finally - FPaintInherited := False; - end; - Invalidate; - raise EAbortPaint.Create(''); -end; - -procedure TTntBitBtn.CNDrawItem(var Message: TWMDrawItem); -begin - if FPaintInherited then - inherited - else - DrawItem(Message.DrawItemStruct^); -end; - -procedure TTntBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct); -var - IsDown, IsDefault: Boolean; - State: TButtonState; - R: TRect; - Flags: Longint; - FCanvas: TCanvas; - IsFocused: Boolean; - {$IFDEF THEME_7_UP} - Details: TThemedElementDetails; - Button: TThemedButton; - Offset: TPoint; - {$ENDIF} -begin - try - FCanvas := THackBitBtn(Self).FCanvas; - IsFocused := THackBitBtn(Self).IsFocused; - FCanvas.Handle := DrawItemStruct.hDC; - R := ClientRect; - - with DrawItemStruct do - begin - FCanvas.Handle := hDC; - FCanvas.Font := Self.Font; - IsDown := itemState and ODS_SELECTED <> 0; - IsDefault := itemState and ODS_FOCUS <> 0; - - if not Enabled then State := bsDisabled - else if IsDown then State := bsDown - else State := bsUp; - end; - - {$IFDEF THEME_7_UP} - if ThemeServices.ThemesEnabled then - begin - if not Enabled then - Button := tbPushButtonDisabled - else - if IsDown then - Button := tbPushButtonPressed - else - if FMouseInControl then - Button := tbPushButtonHot - else - if IsFocused or IsDefault then - Button := tbPushButtonDefaulted - else - Button := tbPushButtonNormal; - - Details := ThemeServices.GetElementDetails(Button); - // Parent background. - ThemeServices.DrawParentBackground(Handle, DrawItemStruct.hDC, @Details, True); - // Button shape. - ThemeServices.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem); - R := ThemeServices.ContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem); - - if Button = tbPushButtonPressed then - Offset := Point(1, 0) - else - Offset := Point(0, 0); - TButtonGlyph_Draw(Self, FCanvas, R, Offset, Caption, Layout, Margin, Spacing, State, False, - DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); - - if IsFocused and IsDefault then - begin - FCanvas.Pen.Color := clWindowFrame; - FCanvas.Brush.Color := clBtnFace; - DrawFocusRect(FCanvas.Handle, R); - end; - end - else - {$ENDIF} - begin - R := ClientRect; - - Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; - if IsDown then Flags := Flags or DFCS_PUSHED; - if DrawItemStruct.itemState and ODS_DISABLED <> 0 then - Flags := Flags or DFCS_INACTIVE; - - { DrawFrameControl doesn't allow for drawing a button as the - default button, so it must be done here. } - if IsFocused or IsDefault then - begin - FCanvas.Pen.Color := clWindowFrame; - FCanvas.Pen.Width := 1; - FCanvas.Brush.Style := bsClear; - FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); - - { DrawFrameControl must draw within this border } - InflateRect(R, -1, -1); - end; - - { DrawFrameControl does not draw a pressed button correctly } - if IsDown then - begin - FCanvas.Pen.Color := clBtnShadow; - FCanvas.Pen.Width := 1; - FCanvas.Brush.Color := clBtnFace; - FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); - InflateRect(R, -1, -1); - end - else - DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags); - - if IsFocused then - begin - R := ClientRect; - InflateRect(R, -1, -1); - end; - - FCanvas.Font := Self.Font; - if IsDown then - OffsetRect(R, 1, 1); - - TButtonGlyph_Draw(Self, FCanvas, R, Point(0, 0), Caption, Layout, Margin, Spacing, State, - False, DrawTextBiDiModeFlags(0) {$IFDEF COMPILER_7_UP}, Self.WordWrap {$ENDIF}); - - if IsFocused and IsDefault then - begin - R := ClientRect; - InflateRect(R, -4, -4); - FCanvas.Pen.Color := clWindowFrame; - FCanvas.Brush.Color := clBtnFace; - DrawFocusRect(FCanvas.Handle, R); - end; - end; - FCanvas.Handle := 0; - except - on E: EAbortPaint do - ; - else - raise; - end; -end; - -procedure TTntBitBtn.CMMouseEnter(var Message: TMessage); -begin - FMouseInControl := True; - inherited; -end; - -procedure TTntBitBtn.CMMouseLeave(var Message: TMessage); -begin - FMouseInControl := False; - inherited; -end; - -{$IFDEF COMPILER_10_UP} -type - TAccessButton = class(TButton{TNT-ALLOW TButton}); -{$ENDIF} - -procedure TTntBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean); -{$IFDEF COMPILER_10_UP} -// bug fix for VCL where ImageIndex on Action ALWAYS overrides the Glyph. -type - CallActionChange = procedure(Sender: TObject; CheckDefaults: Boolean) of object; -var - M: TMethod; -{$ENDIF} -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - {$IFNDEF COMPILER_10_UP} - inherited; - {$ELSE} - // call TButton.ActionChange (bypass TBitBtn.ActionChange) - M.Code := @TAccessButton.ActionChange; - M.Data := Self; - CallActionChange(M)(Sender, CheckDefaults); - // call Delphi2005's TBitBtn.ActionChange - if Sender is TCustomAction{TNT-ALLOW TCustomAction} then - with TCustomAction{TNT-ALLOW TCustomAction}(Sender) do - begin - { Copy image from action's imagelist } - if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and - (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then - CopyImage(ActionList.Images, ImageIndex); - end; - {$ENDIF} -end; - -function TTntBitBtn.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas deleted file mode 100644 index 9d1ae95aa3..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas +++ /dev/null @@ -1,184 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntCheckLst; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Messages, Windows, Controls, StdCtrls, CheckLst, - TntClasses, TntControls, TntStdCtrls; - -type -{TNT-WARN TCheckListBox} - TTntCheckListBox = class(TCheckListBox{TNT-ALLOW TCheckListBox}, IWideCustomListControl) - private - FItems: TTntStrings; - FSaveItems: TTntStrings; - FSaveTopIndex: Integer; - FSaveItemIndex: Integer; - FSaved_ItemEnabled: array of Boolean; - FSaved_State: array of TCheckBoxState; - FSaved_Header: array of Boolean; - FOnData: TLBGetWideDataEvent; - procedure SetItems(const Value: TTntStrings); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure LBGetText(var Message: TMessage); message LB_GETTEXT; - procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure CopySelection(Destination: TCustomListControl); override; - procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property Items: TTntStrings read FItems write SetItems; - property OnData: TLBGetWideDataEvent read FOnData write FOnData; - end; - -implementation - -uses - SysUtils, Math, TntActnList; - -{ TTntCheckListBox } - -constructor TTntCheckListBox.Create(AOwner: TComponent); -begin - inherited; - FItems := TTntListBoxStrings.Create; - TTntListBoxStrings(FItems).ListBox := Self; -end; - -destructor TTntCheckListBox.Destroy; -begin - FreeAndNil(FItems); - inherited; -end; - -procedure TTntCheckListBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'LISTBOX'); -end; - -procedure TTntCheckListBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCheckListBox.CreateWnd; -var - i: integer; -begin - inherited; - TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); - if Length(FSaved_ItemEnabled) > 0 then begin - for i := 0 to Min(Items.Count - 1, High(FSaved_ItemEnabled)) do begin - ItemEnabled[i] := FSaved_ItemEnabled[i]; - State[i] := FSaved_State[i]; - Header[i] := FSaved_Header[i]; - end; - SetLength(FSaved_ItemEnabled, 0); - SetLength(FSaved_State, 0); - SetLength(FSaved_Header, 0); - end; -end; - -procedure TTntCheckListBox.DestroyWnd; -var - i: integer; -begin - SetLength(FSaved_ItemEnabled, Items.Count); - SetLength(FSaved_State, Items.Count); - SetLength(FSaved_Header, Items.Count); - for i := 0 to Items.Count - 1 do begin - FSaved_ItemEnabled[i] := ItemEnabled[i]; - FSaved_State[i] := State[i]; - FSaved_Header[i] := Header[i]; - end; - TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); - inherited; -end; - -procedure TTntCheckListBox.SetItems(const Value: TTntStrings); -begin - FItems.Assign(Value); -end; - -procedure TTntCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); -begin - inherited; - if not Assigned(OnDrawItem) then - TntListBox_DrawItem_Text(Self, Items, Index, Rect); -end; - -function TTntCheckListBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCheckListBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCheckListBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCheckListBox.AddItem(const Item: WideString; AObject: TObject); -begin - TntListBox_AddItem(Items, Item, AObject); -end; - -procedure TTntCheckListBox.CopySelection(Destination: TCustomListControl); -begin - TntListBox_CopySelection(Self, Items, Destination); -end; - -procedure TTntCheckListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCheckListBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntCheckListBox.LBGetText(var Message: TMessage); -begin - if not TntCustomListBox_LBGetText(Self, OnData, Message) then - inherited; -end; - -procedure TTntCheckListBox.LBGetTextLen(var Message: TMessage); -begin - if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then - inherited; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas deleted file mode 100644 index e99c0fa3a5..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas +++ /dev/null @@ -1,1780 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntClasses; - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). } - -{***********************************************} -{ WideChar-streaming implemented by Maël Hörz } -{***********************************************} - -uses - Classes, SysUtils, Windows, - {$IFNDEF COMPILER_10_UP} - TntWideStrings, - {$ELSE} - WideStrings, - {$ENDIF} - ActiveX, Contnrs; - -// ......... introduced ......... -type - TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8); - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; - -//--------------------------------------------------------------------------------------------- -// Tnt - Classes -//--------------------------------------------------------------------------------------------- - -{TNT-WARN ExtractStrings} -{TNT-WARN LineStart} -{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream - -// A potential implementation of TWideStringStream can be found at: -// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); - -type -{TNT-WARN TFileStream} - TTntFileStream = class(THandleStream) - public - constructor Create(const FileName: WideString; Mode: Word); - destructor Destroy; override; - end; - -{TNT-WARN TMemoryStream} - TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream}) - public - procedure LoadFromFile(const FileName: WideString); - procedure SaveToFile(const FileName: WideString); - end; - -{TNT-WARN TResourceStream} - TTntResourceStream = class(TCustomMemoryStream) - private - HResInfo: HRSRC; - HGlobal: THandle; - procedure Initialize(Instance: THandle; Name, ResType: PWideChar); - public - constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar); - constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar); - destructor Destroy; override; - function Write(const Buffer; Count: Longint): Longint; override; - procedure SaveToFile(const FileName: WideString); - end; - - TTntStrings = class; - -{TNT-WARN TAnsiStrings} - TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings}) - public - procedure LoadFromFile(const FileName: WideString); reintroduce; - procedure SaveToFile(const FileName: WideString); reintroduce; - procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); - procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal); - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - end; - - TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings}) - private - FWideStrings: TTntStrings; - FAdapterCodePage: Cardinal; - protected - function Get(Index: Integer): AnsiString; override; - procedure Put(Index: Integer; const S: AnsiString); override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - function AdapterCodePage: Cardinal; dynamic; - public - constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0); - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: AnsiString); override; - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override; - end; - -{TNT-WARN TStrings} - TTntStrings = class(TWideStrings) - private - FLastFileCharSet: TTntStreamCharSet; - FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings}; - procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); - procedure ReadData(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure ReadDataUTF8(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - protected - procedure DefineProperties(Filer: TFiler); override; - public - constructor Create; - destructor Destroy; override; - - procedure LoadFromFile(const FileName: WideString); override; - procedure LoadFromStream(Stream: TStream); override; - procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - procedure SaveToFile(const FileName: WideString); override; - procedure SaveToStream(Stream: TStream); override; - procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet; - published - property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False; - end; - -{ TTntStringList class } - - TTntStringList = class; - TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer; - -{TNT-WARN TStringList} - TTntStringList = class(TTntStrings) - private - FUpdating: Boolean; - FList: PWideStringItemList; - FCount: Integer; - FCapacity: Integer; - FSorted: Boolean; - FDuplicates: TDuplicates; - FCaseSensitive: Boolean; - FOnChange: TNotifyEvent; - FOnChanging: TNotifyEvent; - procedure ExchangeItems(Index1, Index2: Integer); - procedure Grow; - procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); - procedure SetSorted(Value: Boolean); - procedure SetCaseSensitive(const Value: Boolean); - protected - procedure Changed; virtual; - procedure Changing; virtual; - function Get(Index: Integer): WideString; override; - function GetCapacity: Integer; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure Put(Index: Integer; const S: WideString); override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetCapacity(NewCapacity: Integer); override; - procedure SetUpdateState(Updating: Boolean); override; - function CompareStrings(const S1, S2: WideString): Integer; override; - procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; override; - function AddObject(const S: WideString; AObject: TObject): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Exchange(Index1, Index2: Integer); override; - function Find(const S: WideString; var Index: Integer): Boolean; virtual; - function IndexOf(const S: WideString): Integer; override; - function IndexOfName(const Name: WideString): Integer; override; - procedure Insert(Index: Integer; const S: WideString); override; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); override; - procedure Sort; virtual; - procedure CustomSort(Compare: TWideStringListSortCompare); virtual; - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - property Sorted: Boolean read FSorted write SetSorted; - property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; - end; - -// ......... introduced ......... -type - TListTargetCompare = function (Item, Target: Pointer): Integer; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; - -var - RuntimeUTFStreaming: Boolean; - -type - TBufferedAnsiString = class(TObject) - private - FStringBuffer: AnsiString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: AnsiChar); - procedure AddString(const s: AnsiString); - procedure AddBuffer(Buff: PAnsiChar; Chars: Integer); - function Value: AnsiString; - function BuffPtr: PAnsiChar; - end; - - TBufferedWideString = class(TObject) - private - FStringBuffer: WideString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: WideChar); - procedure AddString(const s: WideString); - procedure AddBuffer(Buff: PWideChar; Chars: Integer); - function Value: WideString; - function BuffPtr: PWideChar; - end; - - TBufferedStreamReader = class(TStream) - private - FStream: TStream; - FStreamSize: Integer; - FBuffer: array of Byte; - FBufferSize: Integer; - FBufferStartPosition: Integer; - FVirtualPosition: Integer; - procedure UpdateBufferFromPosition(StartPos: Integer); - public - constructor Create(Stream: TStream; BufferSize: Integer = 1024); - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - end; - -// "synced" wide string -type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object; -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); - -type - TWideComponentHelper = class(TComponent) - private - FComponent: TComponent; - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); - end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; - -implementation - -uses - RTLConsts, ComObj, Math, - Registry, TypInfo, TntSystem, TntSysUtils; - -{ TntPersistent } - -//=========================================================================== -// The Delphi 5 Classes.pas never supported the streaming of WideStrings. -// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that -// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text -// mode corrupts extended characters in WideStrings even under Delphi 6. -// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time -// to enable sharing source code with previous versions of Delphi. -// -// The purpose of this solution is to store WideString properties which contain -// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'. -// -// Special thanks go to Francisco Leong for helping to develop this solution. -// - -{ TTntWideStringPropertyFiler } -type - TTntWideStringPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - procedure ReadDataUTF8(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -function ReaderNeedsUtfHelp(Reader: TReader): Boolean; -begin - if Reader.Owner = nil then - Result := False { designtime - visual form inheritance ancestor } - else if csDesigning in Reader.Owner.ComponentState then - {$IFDEF COMPILER_7_UP} - Result := False { Delphi 7+: designtime - doesn't need UTF help. } - {$ELSE} - Result := True { Delphi 6: designtime - always needs UTF help. } - {$ENDIF} - else - Result := RuntimeUTFStreaming; { runtime } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter); -begin - Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo))); -end; - -procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent; - PropName: AnsiString); - - {$IFNDEF COMPILER_7_UP} - function HasData: Boolean; - var - CurrPropValue: WideString; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result - and (Filer.Ancestor <> nil) - and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result then begin - // must be non-blank and different than UTF8 (implies all ASCII <= 127) - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWString]); - if FPropInfo <> nil then begin - // must be published (and of type WideString) - Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData); - {$ENDIF} - end; - FInstance := nil; - FPropInfo := nil; -end; - -{ TTntWideCharPropertyFiler } -type - TTntWideCharPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - {$IFNDEF COMPILER_9_UP} - FWriter: TWriter; - procedure GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); - {$ENDIF} - procedure ReadData_W(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteData_W(Writer: TWriter); - function ReadChar(Reader: TReader): WideChar; - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -{$IFNDEF COMPILER_9_UP} -type - TGetLookupInfoEvent = procedure(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent) of object; - -function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean; -begin - Result := (Ancestor <> nil) and (RootAncestor <> nil) and - Root.InheritsFrom(RootAncestor.ClassType); -end; - -function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo; - OnGetLookupInfo: TGetLookupInfoEvent): Boolean; -var - Ancestor: TPersistent; - LookupRoot: TComponent; - RootAncestor: TComponent; - Root: TComponent; - AncestorValid: Boolean; - Value: Longint; - Default: LongInt; -begin - Ancestor := nil; - Root := nil; - LookupRoot := nil; - RootAncestor := nil; - - if Assigned(OnGetLookupInfo) then - OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor); - - AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor); - - Result := True; - if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then - begin - Value := GetOrdProp(Instance, PropInfo); - if AncestorValid then - Result := Value = GetOrdProp(Ancestor, PropInfo) - else - begin - Default := PPropInfo(PropInfo)^.Default; - Result := (Default <> LongInt($80000000)) and (Value = Default); - end; - end; -end; - -procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); -begin - Ancestor := FWriter.Ancestor; - Root := FWriter.Root; - LookupRoot := FWriter.LookupRoot; - RootAncestor := FWriter.RootAncestor; -end; -{$ENDIF} - -function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar; -var - Temp: WideString; -begin - case Reader.NextValue of - vaWString: - Temp := Reader.ReadWideString; - vaString: - Temp := Reader.ReadString; - else - raise EReadError.Create(SInvalidPropertyValue); - end; - - if Length(Temp) > 1 then - raise EReadError.Create(SInvalidPropertyValue); - Result := Temp[1]; -end; - -procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader); -begin - SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader))); -end; - -procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader); -var - S: WideString; -begin - S := UTF7ToWideString(Reader.ReadString); - if S = '' then - SetOrdProp(FInstance, FPropInfo, 0) - else - SetOrdProp(FInstance, FPropInfo, Ord(S[1])) -end; - -type TAccessWriter = class(TWriter); - -procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter); -var - L: Integer; - Temp: WideString; -begin - Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); - - TAccessWriter(Writer).WriteValue(vaWString); - L := Length(Temp); - Writer.Write(L, SizeOf(Integer)); - Writer.Write(Pointer(@Temp[1])^, L * 2); -end; - -procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler; - Instance: TPersistent; PropName: AnsiString); - - {$IFNDEF COMPILER_9_UP} - function HasData: Boolean; - var - CurrPropValue: Integer; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result and (Filer.Ancestor <> nil) and - (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetOrdProp(Instance, FPropInfo); - Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result and (Filer is TWriter) then - begin - FWriter := TWriter(Filer); - Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]); - if FPropInfo <> nil then - begin - // must be published (and of type WideChar) - {$IFDEF COMPILER_9_UP} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False); - {$ELSE} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData); - {$ENDIF} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False); - end; - FInstance := nil; - FPropInfo := nil; -end; - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); -var - I, Count: Integer; - PropInfo: PPropInfo; - PropList: PPropList; - WideStringFiler: TTntWideStringPropertyFiler; - WideCharFiler: TTntWideCharPropertyFiler; -begin - Count := GetTypeData(Instance.ClassInfo)^.PropCount; - if Count > 0 then - begin - WideStringFiler := TTntWideStringPropertyFiler.Create; - try - WideCharFiler := TTntWideCharPropertyFiler.Create; - try - GetMem(PropList, Count * SizeOf(Pointer)); - try - GetPropInfos(Instance.ClassInfo, PropList); - for I := 0 to Count - 1 do - begin - PropInfo := PropList^[I]; - if (PropInfo = nil) then - break; - if (PropInfo.PropType^.Kind = tkWString) then - WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name) - else if (PropInfo.PropType^.Kind = tkWChar) then - WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name) - end; - finally - FreeMem(PropList, Count * SizeOf(Pointer)); - end; - finally - WideCharFiler.Free; - end; - finally - WideStringFiler.Free; - end; - end; -end; - -{ TTntFileStream } - -constructor TTntFileStream.Create(const FileName: WideString; Mode: Word); -var - CreateHandle: Integer; - {$IFDEF DELPHI_7_UP} - ErrorMessage: WideString; - {$ENDIF} -begin - if Mode = fmCreate then - begin - CreateHandle := WideFileCreate(FileName); - if CreateHandle < 0 then begin - {$IFDEF DELPHI_7_UP} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end else - begin - CreateHandle := WideFileOpen(FileName, Mode); - if CreateHandle < 0 then begin - {$IFDEF DELPHI_7_UP} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end; - inherited Create(CreateHandle); -end; - -destructor TTntFileStream.Destroy; -begin - if Handle >= 0 then FileClose(Handle); -end; - -{ TTntMemoryStream } - -procedure TTntMemoryStream.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntMemoryStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TTntResourceStream } - -constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResName), ResType); -end; - -constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResID), ResType); -end; - -procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar); - - procedure Error; - begin - raise EResNotFound.CreateFmt(SResNotFound, [Name]); - end; - -begin - HResInfo := FindResourceW(Instance, Name, ResType); - if HResInfo = 0 then Error; - HGlobal := LoadResource(Instance, HResInfo); - if HGlobal = 0 then Error; - SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); -end; - -destructor TTntResourceStream.Destroy; -begin - UnlockResource(HGlobal); - FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) } - inherited Destroy; -end; - -function TTntResourceStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); -end; - -procedure TTntResourceStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TAnsiStrings } - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - if (CodePage = CP_UTF8) then - Stream.WriteBuffer(PAnsiChar(UTF8_BOM)^, Length(UTF8_BOM)); - SaveToStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -{ TAnsiStringsForWideStringsAdapter } - -constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal); -begin - inherited Create; - FWideStrings := AWideStrings; - FAdapterCodePage := _AdapterCodePage; -end; - -function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal; -begin - if FAdapterCodePage = 0 then - Result := TntSystem.DefaultSystemCodePage - else - Result := FAdapterCodePage; -end; - -procedure TAnsiStringsForWideStringsAdapter.Clear; -begin - FWideStrings.Clear; -end; - -procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer); -begin - FWideStrings.Delete(Index); -end; - -function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString; -begin - Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage); -end; - -procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString); -begin - FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetCount: Integer; -begin - Result := FWideStrings.GetCount; -end; - -procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString); -begin - FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject; -begin - Result := FWideStrings.GetObject(Index); -end; - -procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject); -begin - FWideStrings.PutObject(Index, AObject); -end; - -procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean); -begin - FWideStrings.SetUpdateState(Updating); -end; - -procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); -var - Size: Integer; - S: AnsiString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size); - Stream.Read(Pointer(S)^, Size); - FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage)); - finally - EndUpdate; - end; -end; - -procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal); -var - S: AnsiString; -begin - S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage); - Stream.WriteBuffer(Pointer(S)^, Length(S)); -end; - -{ TTntStrings } - -constructor TTntStrings.Create; -begin - inherited; - FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self); - FLastFileCharSet := csUnicode; -end; - -destructor TTntStrings.Destroy; -begin - FreeAndNil(FAnsiStrings); - inherited; -end; - -procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); -begin - FAnsiStrings.Assign(Value); -end; - -procedure TTntStrings.DefineProperties(Filer: TFiler); - - {$IFNDEF COMPILER_7_UP} - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - begin - Result := True; - if Filer.Ancestor is TWideStrings then - Result := not Equals(TWideStrings(Filer.Ancestor)) - end - else Result := Count > 0; - end; - - function DoWriteAsUTF7: Boolean; - var - i: integer; - begin - Result := False; - for i := 0 to Count - 1 do begin - if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin - Result := True; - break; { found a string with non-ASCII chars (> 127) } - end; - end; - end; - {$ENDIF} - -begin - inherited DefineProperties(Filer); { Handles main 'Strings' property.' } - Filer.DefineProperty('WideStrings', ReadData, nil, False); - Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7); - {$ENDIF} -end; - -procedure TTntStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - FLastFileCharSet := AutoDetectCharacterSet(Stream); - Stream.Position := 0; - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.LoadFromStream(Stream: TStream); -begin - LoadFromStream_BOM(Stream, True); -end; - -procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); -var - DataLeft: Integer; - StreamCharSet: TTntStreamCharSet; - SW: WideString; - SA: AnsiString; -begin - BeginUpdate; - try - if WithBOM then - StreamCharSet := AutoDetectCharacterSet(Stream) - else - StreamCharSet := csUnicode; - DataLeft := Stream.Size - Stream.Position; - if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then - begin - // BOM indicates Unicode text stream - if DataLeft < SizeOf(WideChar) then - SW := '' - else begin - SetLength(SW, DataLeft div SizeOf(WideChar)); - Stream.Read(PWideChar(SW)^, DataLeft); - if StreamCharSet = csUnicodeSwapped then - StrSwapByteOrder(PWideChar(SW)); - end; - SetTextStr(SW); - end - else if StreamCharSet = csUtf8 then - begin - // BOM indicates UTF-8 text stream - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(UTF8ToWideString(SA)); - end - else - begin - // without byte order mark it is assumed that we are loading ANSI text - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(SA); - end; - finally - EndUpdate; - end; -end; - -procedure TTntStrings.ReadData(Reader: TReader); -begin - if Reader.NextValue in [vaString, vaLString] then - SetTextStr(Reader.ReadString) {JCL compatiblity} - else if Reader.NextValue = vaWString then - SetTextStr(Reader.ReadWideString) {JCL compatiblity} - else begin - BeginUpdate; - try - Clear; - Reader.ReadListBegin; - while not Reader.EndOfList do - if Reader.NextValue in [vaString, vaLString] then - Add(Reader.ReadString) {TStrings compatiblity} - else - Add(Reader.ReadWideString); - Reader.ReadListEnd; - finally - EndUpdate; - end; - end; -end; - -procedure TTntStrings.ReadDataUTF7(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) then - begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF7ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.ReadDataUTF8(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) - or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW } - then begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF8ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.SaveToStream(Stream: TStream); -begin - SaveToStream_BOM(Stream, True); -end; - -procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); -// Saves the currently loaded text into the given stream. -// WithBOM determines whether to write a byte order mark or not. -var - SW: WideString; - BOM: WideChar; -begin - if WithBOM then begin - BOM := UNICODE_BOM; - Stream.WriteBuffer(BOM, SizeOf(WideChar)); - end; - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TTntStrings.WriteDataUTF7(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do - Writer.WriteString(WideStringToUTF7(Get(I))); - Writer.WriteListEnd; -end; - -{ TTntStringList } - -destructor TTntStringList.Destroy; -begin - FOnChange := nil; - FOnChanging := nil; - inherited Destroy; - if FCount <> 0 then Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); -end; - -function TTntStringList.Add(const S: WideString): Integer; -begin - Result := AddObject(S, nil); -end; - -function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer; -begin - if not Sorted then - Result := FCount - else - if Find(S, Result) then - case Duplicates of - dupIgnore: Exit; - dupError: Error(PResStringRec(@SDuplicateString), 0); - end; - InsertItem(Result, S, AObject); -end; - -procedure TTntStringList.Changed; -begin - if (not FUpdating) and Assigned(FOnChange) then - FOnChange(Self); -end; - -procedure TTntStringList.Changing; -begin - if (not FUpdating) and Assigned(FOnChanging) then - FOnChanging(Self); -end; - -procedure TTntStringList.Clear; -begin - if FCount <> 0 then - begin - Changing; - Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); - Changed; - end; -end; - -procedure TTntStringList.Delete(Index: Integer); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - Finalize(FList^[Index]); - Dec(FCount); - if Index < FCount then - System.Move(FList^[Index + 1], FList^[Index], - (FCount - Index) * SizeOf(TWideStringItem)); - Changed; -end; - -procedure TTntStringList.Exchange(Index1, Index2: Integer); -begin - if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1); - if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2); - Changing; - ExchangeItems(Index1, Index2); - Changed; -end; - -procedure TTntStringList.ExchangeItems(Index1, Index2: Integer); -var - Temp: Integer; - Item1, Item2: PWideStringItem; -begin - Item1 := @FList^[Index1]; - Item2 := @FList^[Index2]; - Temp := Integer(Item1^.FString); - Integer(Item1^.FString) := Integer(Item2^.FString); - Integer(Item2^.FString) := Temp; - Temp := Integer(Item1^.FObject); - Integer(Item1^.FObject) := Integer(Item2^.FObject); - Integer(Item2^.FObject) := Temp; -end; - -function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := FCount - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := CompareStrings(FList^[I].FString, S); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - if Duplicates <> dupAccept then L := I; - end; - end; - end; - Index := L; -end; - -function TTntStringList.Get(Index: Integer): WideString; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FString; -end; - -function TTntStringList.GetCapacity: Integer; -begin - Result := FCapacity; -end; - -function TTntStringList.GetCount: Integer; -begin - Result := FCount; -end; - -function TTntStringList.GetObject(Index: Integer): TObject; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FObject; -end; - -procedure TTntStringList.Grow; -var - Delta: Integer; -begin - if FCapacity > 64 then Delta := FCapacity div 4 else - if FCapacity > 8 then Delta := 16 else - Delta := 4; - SetCapacity(FCapacity + Delta); -end; - -function TTntStringList.IndexOf(const S: WideString): Integer; -begin - if not Sorted then Result := inherited IndexOf(S) else - if not Find(S, Result) then Result := -1; -end; - -function TTntStringList.IndexOfName(const Name: WideString): Integer; -var - NameKey: WideString; -begin - if not Sorted then - Result := inherited IndexOfName(Name) - else begin - // use sort to find index more quickly - NameKey := Name + NameValueSeparator; - Find(NameKey, Result); - if (Result < 0) or (Result > Count - 1) then - Result := -1 - else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then - Result := -1 - end; -end; - -procedure TTntStringList.Insert(Index: Integer; const S: WideString); -begin - InsertObject(Index, S, nil); -end; - -procedure TTntStringList.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index); - InsertItem(Index, S, AObject); -end; - -procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject); -begin - Changing; - if FCount = FCapacity then Grow; - if Index < FCount then - System.Move(FList^[Index], FList^[Index + 1], - (FCount - Index) * SizeOf(TWideStringItem)); - with FList^[Index] do - begin - Pointer(FString) := nil; - FObject := AObject; - FString := S; - end; - Inc(FCount); - Changed; -end; - -procedure TTntStringList.Put(Index: Integer; const S: WideString); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FString := S; - Changed; -end; - -procedure TTntStringList.PutObject(Index: Integer; AObject: TObject); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FObject := AObject; - Changed; -end; - -procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); -var - I, J, P: Integer; -begin - repeat - I := L; - J := R; - P := (L + R) shr 1; - repeat - while SCompare(Self, I, P) < 0 do Inc(I); - while SCompare(Self, J, P) > 0 do Dec(J); - if I <= J then - begin - ExchangeItems(I, J); - if P = I then - P := J - else if P = J then - P := I; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then QuickSort(L, J, SCompare); - L := I; - until I >= R; -end; - -procedure TTntStringList.SetCapacity(NewCapacity: Integer); -begin - ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem)); - FCapacity := NewCapacity; -end; - -procedure TTntStringList.SetSorted(Value: Boolean); -begin - if FSorted <> Value then - begin - if Value then Sort; - FSorted := Value; - end; -end; - -procedure TTntStringList.SetUpdateState(Updating: Boolean); -begin - FUpdating := Updating; - if Updating then Changing else Changed; -end; - -function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer; -begin - Result := List.CompareStrings(List.FList^[Index1].FString, - List.FList^[Index2].FString); -end; - -procedure TTntStringList.Sort; -begin - CustomSort(WideStringListCompareStrings); -end; - -procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare); -begin - if not Sorted and (FCount > 1) then - begin - Changing; - QuickSort(0, FCount - 1, Compare); - Changed; - end; -end; - -function TTntStringList.CompareStrings(const S1, S2: WideString): Integer; -begin - if CaseSensitive then - Result := WideCompareStr(S1, S2) - else - Result := WideCompareText(S1, S2); -end; - -procedure TTntStringList.SetCaseSensitive(const Value: Boolean); -begin - if Value <> FCaseSensitive then - begin - FCaseSensitive := Value; - if Sorted then Sort; - end; -end; - -//------------------------- TntClasses introduced procs ---------------------------------- - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; -var - ByteOrderMark: WideChar; - BytesRead: Integer; - Utf8Test: array[0..2] of AnsiChar; -begin - // Byte Order Mark - ByteOrderMark := #0; - if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin - BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); - if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin - ByteOrderMark := #0; - Stream.Seek(-BytesRead, soFromCurrent); - if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin - BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); - if Utf8Test <> UTF8_BOM then - Stream.Seek(-BytesRead, soFromCurrent); - end; - end; - end; - // Test Byte Order Mark - if ByteOrderMark = UNICODE_BOM then - Result := csUnicode - else if ByteOrderMark = UNICODE_BOM_SWAPPED then - Result := csUnicodeSwapped - else if Utf8Test = UTF8_BOM then - Result := csUtf8 - else - Result := csAnsi; -end; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := List.Count - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := TargetCompare(List[i], Target); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - L := I; - end; - end; - end; - Index := L; -end; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; -var - OleStr: POleStr; - Reg: TRegIniFile; - Key, Filename: WideString; -begin - // First, check to see if there is a ProgID. This will tell if the - // control is registered on the machine. No ProgID, control won't run - Result := ProgIDFromCLSID(clsid, OleStr) = S_OK; - if not Result then Exit; //Bail as soon as anything goes wrong. - - // Next, make sure that the file is actually there by rooting it out - // of the registry - Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]); - Reg := TRegIniFile.Create; - try - Reg.RootKey := HKEY_LOCAL_MACHINE; - Result := Reg.OpenKeyReadOnly(Key); - if not Result then Exit; // Bail as soon as anything goes wrong. - - FileName := Reg.ReadString('InProcServer32', '', EmptyStr); - if (Filename = EmptyStr) then // try another key for the file name - begin - FileName := Reg.ReadString('InProcServer', '', EmptyStr); - end; - Result := Filename <> EmptyStr; - if not Result then Exit; - Result := WideFileExists(Filename); - finally - Reg.Free; - end; -end; - -{ TBufferedAnsiString } - -procedure TBufferedAnsiString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0); -end; - -procedure TBufferedAnsiString.AddChar(const wc: AnsiChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedAnsiString.AddString(const s: AnsiString); -var - LenS: Integer; - BlockSize: Integer; - AllocSize: Integer; -begin - LenS := Length(s); - if LenS > 0 then begin - Inc(LastWriteIndex); - if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin - // determine optimum new allocation size - BlockSize := Length(FStringBuffer) div 2; - if BlockSize < 8 then - BlockSize := 8; - AllocSize := ((LenS div BlockSize) + 1) * BlockSize; - // realloc buffer - SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize); - FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0); - end; - CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar)); - Inc(LastWriteIndex, LenS - 1); - end; -end; - -procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedAnsiString.Value: AnsiString; -begin - Result := PAnsiChar(FStringBuffer); -end; - -function TBufferedAnsiString.BuffPtr: PAnsiChar; -begin - Result := PAnsiChar(FStringBuffer); -end; - -{ TBufferedWideString } - -procedure TBufferedWideString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0); -end; - -procedure TBufferedWideString.AddChar(const wc: WideChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedWideString.AddString(const s: WideString); -var - i: integer; -begin - for i := 1 to Length(s) do - AddChar(s[i]); -end; - -procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedWideString.Value: WideString; -begin - Result := PWideChar(FStringBuffer); -end; - -function TBufferedWideString.BuffPtr: PWideChar; -begin - Result := PWideChar(FStringBuffer); -end; - -{ TBufferedStreamReader } - -constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024); -begin - // init stream - FStream := Stream; - FStreamSize := Stream.Size; - // init buffer - FBufferSize := BufferSize; - SetLength(FBuffer, BufferSize); - FBufferStartPosition := -FBufferSize; { out of any useful range } - // init virtual position - FVirtualPosition := 0; -end; - -function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: FVirtualPosition := Offset; - soFromCurrent: Inc(FVirtualPosition, Offset); - soFromEnd: FVirtualPosition := FStreamSize + Offset; - end; - Result := FVirtualPosition; -end; - -procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer); -begin - try - FStream.Position := StartPos; - FStream.Read(FBuffer[0], FBufferSize); - FBufferStartPosition := StartPos; - except - FBufferStartPosition := -FBufferSize; { out of any useful range } - raise; - end; -end; - -function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint; -var - BytesLeft: Integer; - FirstBufferRead: Integer; - StreamDirectRead: Integer; - Buf: PAnsiChar; -begin - if (FVirtualPosition >= 0) and (Count >= 0) then - begin - Result := FStreamSize - FVirtualPosition; - if Result > 0 then - begin - if Result > Count then - Result := Count; - - Buf := @Buffer; - BytesLeft := Result; - - // try to read what is left in buffer - FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition; - if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then - FirstBufferRead := 0; - FirstBufferRead := Min(FirstBufferRead, Result); - if FirstBufferRead > 0 then begin - Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead); - Dec(BytesLeft, FirstBufferRead); - end; - - if BytesLeft > 0 then begin - // The first read in buffer was not enough - StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize; - FStream.Position := FVirtualPosition + FirstBufferRead; - FStream.Read(Buf[FirstBufferRead], StreamDirectRead); - Dec(BytesLeft, StreamDirectRead); - - if BytesLeft > 0 then begin - // update buffer, and read what is left - UpdateBufferFromPosition(FStream.Position); - Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft); - end; - end; - - Inc(FVirtualPosition, Result); - Exit; - end; - end; - Result := 0; -end; - -function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint; -begin - raise ETntInternalError.Create('Internal Error: class can not write.'); - Result := 0; -end; - -//-------- synced wide string ----------------- - -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -begin - if AnsiString(WideStr) <> (AnsiStr) then begin - WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.} - end; - Result := WideStr; -end; - -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); -begin - if Value <> GetSyncedWideString(WideStr, AnsiStr) then - begin - if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion} - and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change} - then begin - SetAnsiStr(''); {force the change} - end; - WideStr := Value; - SetAnsiStr(Value); - end; -end; - -{ TWideComponentHelper } - -function CompareComponentHelperToTarget(Item, Target: Pointer): Integer; -begin - if Integer(TWideComponentHelper(Item).FComponent) < Integer(Target) then - Result := -1 - else if Integer(TWideComponentHelper(Item).FComponent) > Integer(Target) then - Result := 1 - else - Result := 0; -end; - -function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean; -begin - // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent) - Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index); -end; - -constructor TWideComponentHelper.Create(AOwner: TComponent); -begin - raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.'); -end; - -constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); -var - Index: Integer; -begin - // don't use direct ownership for memory management - inherited Create(nil); - FComponent := AOwner; - FComponent.FreeNotification(Self); - - // insert into list according to sort - FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index); - ComponentHelperList.Insert(Index, Self); -end; - -procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (AComponent = FComponent) and (Operation = opRemove) then begin - FComponent := nil; - Free; - end; -end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; -var - Index: integer; -begin - if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin - Result := TWideComponentHelper(ComponentHelperList[Index]); - Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.'); - end else - Result := nil; -end; - -initialization - RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. } - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas deleted file mode 100644 index cf2c16e9f6..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas +++ /dev/null @@ -1,86 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntClipBrd; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, Clipbrd; - -type -{TNT-WARN TClipboard} - TTntClipboard = class(TClipboard{TNT-ALLOW TClipboard}) - private - function GetAsWideText: WideString; - procedure SetAsWideText(const Value: WideString); - public - property AsWideText: WideString read GetAsWideText write SetAsWideText; - property AsText: WideString read GetAsWideText write SetAsWideText; - end; - -{TNT-WARN Clipboard} -function TntClipboard: TTntClipboard; - -implementation - -{ TTntClipboard } - -function TTntClipboard.GetAsWideText: WideString; -var - Data: THandle; -begin - Open; - Data := GetClipboardData(CF_UNICODETEXT); - try - if Data <> 0 then - Result := PWideChar(GlobalLock(Data)) - else - Result := ''; - finally - if Data <> 0 then GlobalUnlock(Data); - Close; - end; - if (Data = 0) or (Result = '') then - Result := inherited AsText -end; - -procedure TTntClipboard.SetAsWideText(const Value: WideString); -begin - Open; - try - inherited AsText := Value; {Ensures ANSI compatiblity across platforms.} - SetBuffer(CF_UNICODETEXT, PWideChar(Value)^, (Length(Value) + 1) * SizeOf(WideChar)); - finally - Close; - end; -end; - -//------------------------------------------ - -var - GTntClipboard: TTntClipboard; - -function TntClipboard: TTntClipboard; -begin - if GTntClipboard = nil then - GTntClipboard := TTntClipboard.Create; - Result := GTntClipboard; -end; - -initialization - -finalization - GTntClipboard.Free; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas deleted file mode 100644 index 42bec4cd46..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas +++ /dev/null @@ -1,5058 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntComCtrls; - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: TTntCustomListView events - reintroduce ones that refer to ansi classes (ie. TListItem) } -{ TODO: Handle RichEdit CRLF emulation at the WndProc level. } -{ TODO: TTntCustomTreeView events - reintroduce ones that refer to ansi classes (ie. TTreeNode) } -{ TODO: THotKey, Tanimate, TCoolBar (TCoolBand) } -{ TODO: TToolBar: Unicode-enable TBN_GETBUTTONINFO/DoGetButton } -{ TODO: TToolBar: Unicode-enable handling of CN_DIALOGCHAR, WM_SYSCOMMAND, FindButtonFromAccel } - -uses - Classes, Controls, ListActns, Menus, ComCtrls, Messages, - Windows, CommCtrl, Contnrs, TntControls, TntClasses, Graphics, TntSysUtils; - -type - TTntCustomListView = class; - TTntListItems = class; - -{TNT-WARN TListColumn} - TTntListColumn = class(TListColumn{TNT-ALLOW TListColumn}) - private - FCaption: WideString; - procedure SetInheritedCaption(const Value: AnsiString); - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - end; - -{TNT-WARN TListColumns} - TTntListColumns = class(TListColumns{TNT-ALLOW TListColumns}) - private - function GetItem(Index: Integer): TTntListColumn; - procedure SetItem(Index: Integer; Value: TTntListColumn); - public - constructor Create(AOwner: TTntCustomListView); - function Add: TTntListColumn; - function Owner: TTntCustomListView; - property Items[Index: Integer]: TTntListColumn read GetItem write SetItem; default; - end; - -{TNT-WARN TListItem} - TTntListItem = class(TListItem{TNT-ALLOW TListItem}) - private - FCaption: WideString; - FSubItems: TTntStrings; - procedure SetInheritedCaption(const Value: AnsiString); - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - procedure SetSubItems(const Value: TTntStrings); - function GetListView: TTntCustomListView; - function GetTntOwner: TTntListItems; - public - constructor Create(AOwner: TListItems{TNT-ALLOW TListItems}); virtual; - destructor Destroy; override; - property Owner: TTntListItems read GetTntOwner; - property ListView: TTntCustomListView read GetListView; - procedure Assign(Source: TPersistent); override; - property Caption: WideString read GetCaption write SetCaption; - property SubItems: TTntStrings read FSubItems write SetSubItems; - end; - - TTntListItemsEnumerator = class - private - FIndex: Integer; - FListItems: TTntListItems; - public - constructor Create(AListItems: TTntListItems); - function GetCurrent: TTntListItem; - function MoveNext: Boolean; - property Current: TTntListItem read GetCurrent; - end; - -{TNT-WARN TListItems} - TTntListItems = class(TListItems{TNT-ALLOW TListItems}) - private - function GetItem(Index: Integer): TTntListItem; - procedure SetItem(Index: Integer; const Value: TTntListItem); - public - function Owner: TTntCustomListView; - property Item[Index: Integer]: TTntListItem read GetItem write SetItem; default; - function Add: TTntListItem; - function AddItem(Item: TTntListItem; Index: Integer = -1): TTntListItem; - function GetEnumerator: TTntListItemsEnumerator; - function Insert(Index: Integer): TTntListItem; - end; - - TTntLVEditedEvent = procedure(Sender: TObject; Item: TTntListItem; var S: WideString) of object; - TTntLVOwnerDataFindEvent = procedure(Sender: TObject; Find: TItemFind; - const FindString: WideString; const FindPosition: TPoint; FindData: Pointer; - StartIndex: Integer; Direction: TSearchDirection; Wrap: Boolean; - var Index: Integer) of object; - -{TNT-WARN TCustomListView} - _TntInternalCustomListView = class(TCustomListView{TNT-ALLOW TCustomListView}) - private - PWideFindString: PWideChar; - CurrentDispInfo: PLVDispInfoW; - OriginalDispInfoMask: Cardinal; - function OwnerDataFindW(Find: TItemFind; const FindString: WideString; - const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; - Direction: TSearchDirection; Wrap: Boolean): Integer; virtual; abstract; - function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; virtual; abstract; - protected - function OwnerDataFind(Find: TItemFind; const FindString: AnsiString; - const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; - Direction: TSearchDirection; Wrap: Boolean): Integer; override; - function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; - end; - - TTntCustomListView = class(_TntInternalCustomListView, IWideCustomListControl) - private - FEditHandle: THandle; - FEditInstance: Pointer; - FDefEditProc: Pointer; - FOnEdited: TTntLVEditedEvent; - FOnDataFind: TTntLVOwnerDataFindEvent; - procedure EditWndProcW(var Message: TMessage); - procedure BeginChangingWideItem; - procedure EndChangingWideItem; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - function GetListColumns: TTntListColumns; - procedure SetListColumns(const Value: TTntListColumns); - function ColumnFromIndex(Index: Integer): TTntListColumn; - function GetColumnFromTag(Tag: Integer): TTntListColumn; - function OwnerDataFindW(Find: TItemFind; const FindString: WideString; - const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; - Direction: TSearchDirection; Wrap: Boolean): Integer; override; - function OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; override; - function GetDropTarget: TTntListItem; - procedure SetDropTarget(const Value: TTntListItem); - function GetItemFocused: TTntListItem; - procedure SetItemFocused(const Value: TTntListItem); - function GetSelected: TTntListItem; - procedure SetSelected(const Value: TTntListItem); - function GetTopItem: TTntListItem; - private - FSavedItems: TObjectList; - FTestingForSortProc: Boolean; - FChangingWideItemCount: Integer; - FTempItem: TTntListItem; - function AreItemsStored: Boolean; - function GetItems: TTntListItems; - procedure SetItems(Value: TTntListItems); - procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; - function GetItemW(Value: TLVItemW): TTntListItem; - procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - procedure WndProc(var Message: TMessage); override; - function OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; reintroduce; virtual; - function CreateListItem: TListItem{TNT-ALLOW TListItem}; override; - function CreateListItems: TListItems{TNT-ALLOW TListItems}; override; - property Items: TTntListItems read GetItems write SetItems stored AreItemsStored; - procedure Edit(const Item: TLVItem); override; - function OwnerDataFind(Find: TItemFind; const FindString: WideString; - const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; - Direction: TSearchDirection; Wrap: Boolean): Integer; reintroduce; virtual; - property Columns: TTntListColumns read GetListColumns write SetListColumns; - procedure DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; State: TOwnerDrawState); override; - property OnEdited: TTntLVEditedEvent read FOnEdited write FOnEdited; - property OnDataFind: TTntLVOwnerDataFindEvent read FOnDataFind write FOnDataFind; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Column[Index: Integer]: TTntListColumn read ColumnFromIndex; - procedure CopySelection(Destination: TCustomListControl); override; - procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; - function FindCaption(StartIndex: Integer; Value: WideString; Partial, - Inclusive, Wrap: Boolean): TTntListItem; - function GetSearchString: WideString; - function StringWidth(S: WideString): Integer; - public - property DropTarget: TTntListItem read GetDropTarget write SetDropTarget; - property ItemFocused: TTntListItem read GetItemFocused write SetItemFocused; - property Selected: TTntListItem read GetSelected write SetSelected; - property TopItem: TTntListItem read GetTopItem; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TListView} - TTntListView = class(TTntCustomListView) - published - property Action; - property Align; - property AllocBy; - property Anchors; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind default bkNone; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property BorderWidth; - property Checkboxes; - property Color; - property Columns; - property ColumnClick; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property FlatScrollBars; - property FullDrag; - property GridLines; - property HideSelection; - property HotTrack; - property HotTrackStyles; - property HoverTime; - property IconOptions; - property Items; - property LargeImages; - property MultiSelect; - property OwnerData; - property OwnerDraw; - property ReadOnly default False; - property RowSelect; - property ParentBiDiMode; - property ParentColor default False; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowColumnHeaders; - property ShowWorkAreas; - property ShowHint; - property SmallImages; - property SortType; - property StateImages; - property TabOrder; - property TabStop default True; - property ViewStyle; - property Visible; - property OnAdvancedCustomDraw; - property OnAdvancedCustomDrawItem; - property OnAdvancedCustomDrawSubItem; - property OnChange; - property OnChanging; - property OnClick; - property OnColumnClick; - property OnColumnDragged; - property OnColumnRightClick; - property OnCompare; - property OnContextPopup; - property OnCustomDraw; - property OnCustomDrawItem; - property OnCustomDrawSubItem; - property OnData; - property OnDataFind; - property OnDataHint; - property OnDataStateChange; - property OnDblClick; - property OnDeletion; - property OnDrawItem; - property OnEdited; - property OnEditing; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetImageIndex; - property OnGetSubItemImage; - property OnDragDrop; - property OnDragOver; - property OnInfoTip; - property OnInsert; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnResize; - property OnSelectItem; - property OnStartDock; - property OnStartDrag; - end; - -type -{TNT-WARN TToolButton} - TTntToolButton = class(TToolButton{TNT-ALLOW TToolButton}) - private - procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function IsCaptionStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - function GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; - procedure SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); - protected - procedure DefineProperties(Filer: TFiler); override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function GetActionLinkClass: TControlActionLinkClass; override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property MenuItem: TMenuItem{TNT-ALLOW TMenuItem} read GetMenuItem write SetMenuItem; - end; - -type -{TNT-WARN TToolBar} - TTntToolBar = class(TToolBar{TNT-ALLOW TToolBar}) - private - FCaption: WideString; - procedure TBInsertButtonA(var Message: TMessage); message TB_INSERTBUTTONA; - procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT; - procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; - procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; - function GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; - procedure SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); - private - function GetCaption: WideString; - function GetHint: WideString; - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure SetCaption(const Value: WideString); - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function GetActionLinkClass: TControlActionLinkClass; override; - published - property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property Menu: TMainMenu{TNT-ALLOW TMainMenu} read GetMenu write SetMenu; - end; - -type -{TNT-WARN TCustomRichEdit} - TTntCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}) - private - FRichEditStrings: TTntStrings; - FPrintingTextLength: Integer; - procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; - procedure SetRichEditStrings(const Value: TTntStrings); - function GetWideSelText: WideString; - function GetText: WideString; - procedure SetWideSelText(const Value: WideString); - procedure SetText(const Value: WideString); - function GetHint: WideString; - function IsHintStored: Boolean; - procedure SetHint(const Value: WideString); - procedure SetRTFText(Flags: DWORD; const Value: AnsiString); - protected - procedure CreateParams(var Params: TCreateParams); override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure KeyDown(var Key: Word; Shift: TShiftState); override; - function GetSelText: string{TNT-ALLOW string}; override; - function CharPosToGet(RawWin32CharPos: Integer): Integer; deprecated; // use EmulatedCharPos() - function CharPosToSet(EmulatedCharPos: Integer): Integer; deprecated; // use RawWin32CharPos() - function GetSelStart: Integer; reintroduce; virtual; - procedure SetSelStart(const Value: Integer); reintroduce; virtual; - function GetSelLength: Integer; reintroduce; virtual; - procedure SetSelLength(const Value: Integer); reintroduce; virtual; - function LineBreakStyle: TTntTextLineBreakStyle; - property Lines: TTntStrings read FRichEditStrings write SetRichEditStrings; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - // - function EmulatedCharPos(RawWin32CharPos: Integer): Integer; - function RawWin32CharPos(EmulatedCharPos: Integer): Integer; - // - procedure Print(const Caption: string{TNT-ALLOW string}); override; - property SelText: WideString read GetWideSelText write SetWideSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - function FindText(const SearchStr: WideString; StartPos, - Length: Integer; Options: TSearchTypes): Integer; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TRichEdit} - TTntRichEdit = class(TTntCustomRichEdit) - published - property Align; - property Alignment; - property Anchors; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind default bkNone; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property BorderWidth; - property Color; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property HideScrollBars; - property ImeMode; - property ImeName; - property Constraints; - property Lines; - property MaxLength; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PlainText; - property PopupMenu; - property ReadOnly; - property ScrollBars; - property ShowHint; - property TabOrder; - property TabStop default True; - property Visible; - property WantTabs; - property WantReturns; - property WordWrap; - property OnChange; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnMouseWheelDown; - property OnMouseWheelUp; - property OnProtectChange; - property OnResizeRequest; - property OnSaveClipboard; - property OnSelectionChange; - property OnStartDock; - property OnStartDrag; - end; - -type -{TNT-WARN TCustomTabControl} - TTntCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}) - private - FTabs: TTntStrings; - FSaveTabIndex: Integer; - FSaveTabs: TTntStrings; - function GetTabs: TTntStrings; - procedure SetTabs(const Value: TTntStrings); - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - function GetHint: WideString; - function IsHintStored: Boolean; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - property Tabs: TTntStrings read GetTabs write SetTabs; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TTabControl} - TTntTabControl = class(TTntCustomTabControl) - public - property DisplayRect; - published - property Align; - property Anchors; - property BiDiMode; - property Constraints; - property DockSite; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HotTrack; - property Images; - property MultiLine; - property MultiSelect; - property OwnerDraw; - property ParentBiDiMode; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property RaggedRight; - property ScrollOpposite; - property ShowHint; - property Style; - property TabHeight; - property TabOrder; - property TabPosition; - property Tabs; - property TabIndex; // must be after Tabs - property TabStop; - property TabWidth; - property Visible; - property OnChange; - property OnChanging; - property OnContextPopup; - property OnDockDrop; - property OnDockOver; - property OnDragDrop; - property OnDragOver; - property OnDrawTab; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetImageIndex; - property OnGetSiteInfo; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnResize; - property OnStartDock; - property OnStartDrag; - property OnUnDock; - end; - -type -{TNT-WARN TTabSheet} - TTntTabSheet = class(TTabSheet{TNT-ALLOW TTabSheet}) - private - Force_Inherited_WMSETTEXT: Boolean; - function IsCaptionStored: Boolean; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; - function GetHint: WideString; - function IsHintStored: Boolean; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TPageControl} - TTntPageControl = class(TPageControl{TNT-ALLOW TPageControl}) - private - FNewDockSheet: TTntTabSheet; - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION; - procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure WndProc(var Message: TMessage); override; - procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TTrackBar} - TTntTrackBar = class(TTrackBar{TNT-ALLOW TTrackBar}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TProgressBar} - TTntProgressBar = class(TProgressBar{TNT-ALLOW TProgressBar}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCustomUpDown} - TTntCustomUpDown = class(TCustomUpDown{TNT-ALLOW TCustomUpDown}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TUpDown} - TTntUpDown = class(TTntCustomUpDown) - published - property AlignButton; - property Anchors; - property Associate; - property ArrowKeys; - property Enabled; - property Hint; - property Min; - property Max; - property Increment; - property Constraints; - property Orientation; - property ParentShowHint; - property PopupMenu; - property Position; - property ShowHint; - property TabOrder; - property TabStop; - property Thousands; - property Visible; - property Wrap; - property OnChanging; - property OnChangingEx; - property OnContextPopup; - property OnClick; - property OnEnter; - property OnExit; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - end; - -{TNT-WARN TDateTimePicker} - TTntDateTimePicker = class(TDateTimePicker{TNT-ALLOW TDateTimePicker}) - private - FHadFirstMouseClick: Boolean; - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TMonthCalendar} - TTntMonthCalendar = class(TMonthCalendar{TNT-ALLOW TMonthCalendar}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function GetDate: TDate; - procedure SetDate(const Value: TDate); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - procedure ForceGetMonthInfo; - published - property Date: TDate read GetDate write SetDate; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TPageScroller} - TTntPageScroller = class(TPageScroller{TNT-ALLOW TPageScroller}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -type -{TNT-WARN TStatusPanel} - TTntStatusPanel = class(TStatusPanel{TNT-ALLOW TStatusPanel}) - private - FText: WideString; - function GetText: Widestring; - procedure SetText(const Value: Widestring); - procedure SetInheritedText(const Value: AnsiString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Text: Widestring read GetText write SetText; - end; - -{TNT-WARN TStatusPanels} - TTntStatusPanels = class(TStatusPanels{TNT-ALLOW TStatusPanels}) - private - function GetItem(Index: Integer): TTntStatusPanel; - procedure SetItem(Index: Integer; Value: TTntStatusPanel); - public - function Add: TTntStatusPanel; - function AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; - function Insert(Index: Integer): TTntStatusPanel; - property Items[Index: Integer]: TTntStatusPanel read GetItem write SetItem; default; - end; - -{TNT-WARN TCustomStatusBar} - TTntCustomStatusBar = class(TCustomStatusBar{TNT-ALLOW TCustomStatusBar}) - private - FSimpleText: WideString; - function GetSimpleText: WideString; - procedure SetSimpleText(const Value: WideString); - procedure SetInheritedSimpleText(const Value: AnsiString); - function SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; - function GetHint: WideString; - function IsHintStored: Boolean; - procedure SetHint(const Value: WideString); - procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH; - function GetPanels: TTntStatusPanels; - procedure SetPanels(const Value: TTntStatusPanels); - protected - procedure DefineProperties(Filer: TFiler); override; - function CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; override; - function GetPanelClass: TStatusPanelClass; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure WndProc(var Msg: TMessage); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - function ExecuteAction(Action: TBasicAction): Boolean; override; - property Panels: TTntStatusPanels read GetPanels write SetPanels; - property SimpleText: WideString read GetSimpleText write SetSimpleText; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TStatusBar} - TTntStatusBar = class(TTntCustomStatusBar) - private - function GetOnDrawPanel: TDrawPanelEvent; - procedure SetOnDrawPanel(const Value: TDrawPanelEvent); - published - property Action; - property AutoHint default False; - property Align default alBottom; - property Anchors; - property BiDiMode; - property BorderWidth; - property Color default clBtnFace; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font stored IsFontStored; - property Constraints; - property Panels; - property ParentBiDiMode; - property ParentColor default False; - property ParentFont default False; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property SimplePanel {$IFDEF COMPILER_7_UP} default False {$ENDIF}; - property SimpleText; - property SizeGrip default True; - property UseSystemFont default True; - property Visible; - property OnClick; - property OnContextPopup; - property OnCreatePanelClass; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnHint; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - // Required for backwards compatibility with the old event signature - property OnDrawPanel: TDrawPanelEvent read GetOnDrawPanel write SetOnDrawPanel; - property OnResize; - property OnStartDock; - property OnStartDrag; - end; - -type - TTntTreeNodes = class; - TTntCustomTreeView = class; - -{TNT-WARN TTreeNode} - TTntTreeNode = class(TTreeNode{TNT-ALLOW TTreeNode}) - private - FText: WideString; - procedure SetText(const Value: WideString); - procedure SetInheritedText(const Value: AnsiString); - function GetText: WideString; - function GetItem(Index: Integer): TTntTreeNode; - function GetNodeOwner: TTntTreeNodes; - function GetParent: TTntTreeNode; - function GetTreeView: TTntCustomTreeView; - procedure SetItem(Index: Integer; const Value: TTntTreeNode); - function IsEqual(Node: TTntTreeNode): Boolean; - procedure ReadData(Stream: TStream; Info: PNodeInfo); - procedure WriteData(Stream: TStream; Info: PNodeInfo); - public - procedure Assign(Source: TPersistent); override; - function getFirstChild: TTntTreeNode; {GetFirstChild conflicts with C++ macro} - function GetLastChild: TTntTreeNode; - function GetNext: TTntTreeNode; - function GetNextChild(Value: TTntTreeNode): TTntTreeNode; - function getNextSibling: TTntTreeNode; {GetNextSibling conflicts with C++ macro} - function GetNextVisible: TTntTreeNode; - function GetPrev: TTntTreeNode; - function GetPrevChild(Value: TTntTreeNode): TTntTreeNode; - function getPrevSibling: TTntTreeNode; {GetPrevSibling conflicts with a C++ macro} - function GetPrevVisible: TTntTreeNode; - property Item[Index: Integer]: TTntTreeNode read GetItem write SetItem; default; - property Owner: TTntTreeNodes read GetNodeOwner; - property Parent: TTntTreeNode read GetParent; - property Text: WideString read GetText write SetText; - property TreeView: TTntCustomTreeView read GetTreeView; - end; - - TTntTreeNodeClass = class of TTntTreeNode; - - TTntTreeNodesEnumerator = class - private - FIndex: Integer; - FTreeNodes: TTntTreeNodes; - public - constructor Create(ATreeNodes: TTntTreeNodes); - function GetCurrent: TTntTreeNode; - function MoveNext: Boolean; - property Current: TTntTreeNode read GetCurrent; - end; - -{TNT-WARN TTreeNodes} - TTntTreeNodes = class(TTreeNodes{TNT-ALLOW TTreeNodes}) - private - function GetNodeFromIndex(Index: Integer): TTntTreeNode; - function GetNodesOwner: TTntCustomTreeView; - procedure ClearCache; - procedure ReadData(Stream: TStream); - procedure WriteData(Stream: TStream); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - function Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; - function AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; - function AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; - function AddChildObject(Parent: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; - function AddObject(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; - function InsertObject(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; - function AddNode(Node, Relative: TTntTreeNode; const S: WideString; - Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; - public - function GetFirstNode: TTntTreeNode; - function GetEnumerator: TTntTreeNodesEnumerator; - function GetNode(ItemId: HTreeItem): TTntTreeNode; - property Item[Index: Integer]: TTntTreeNode read GetNodeFromIndex; default; - property Owner: TTntCustomTreeView read GetNodesOwner; - end; - - TTntTVEditedEvent = procedure(Sender: TObject; Node: TTntTreeNode; var S: WideString) of object; - -{TNT-WARN TCustomTreeView} - _TntInternalCustomTreeView = class(TCustomTreeView{TNT-ALLOW TCustomTreeView}) - private - function Wide_FindNextToSelect: TTntTreeNode; virtual; abstract; - function Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; - public - function FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; override; - end; - - TTntCustomTreeView = class(_TntInternalCustomTreeView) - private - FSavedNodeText: TTntStrings; - FSavedSortType: TSortType; - FOnEdited: TTntTVEditedEvent; - FTestingForSortProc: Boolean; - FEditHandle: THandle; - FEditInstance: Pointer; - FDefEditProc: Pointer; - function GetTreeNodes: TTntTreeNodes; - procedure SetTreeNodes(const Value: TTntTreeNodes); - procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; - procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY; - function GetNodeFromItem(const Item: TTVItem): TTntTreeNode; - procedure EditWndProcW(var Message: TMessage); - function Wide_FindNextToSelect: TTntTreeNode; override; - function GetDropTarget: TTntTreeNode; - function GetSelected: TTntTreeNode; - function GetSelection(Index: Integer): TTntTreeNode; - function GetTopItem: TTntTreeNode; - procedure SetDropTarget(const Value: TTntTreeNode); - procedure SetSelected(const Value: TTntTreeNode); - procedure SetTopItem(const Value: TTntTreeNode); - function GetHint: WideString; - function IsHintStored: Boolean; - procedure SetHint(const Value: WideString); - protected - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - procedure DefineProperties(Filer: TFiler); override; - procedure WndProc(var Message: TMessage); override; - procedure Edit(const Item: TTVItem); override; - function CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; override; - function CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; override; - property Items: TTntTreeNodes read GetTreeNodes write SetTreeNodes; - property OnEdited: TTntTVEditedEvent read FOnEdited write FOnEdited; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure LoadFromFile(const FileName: WideString); - procedure LoadFromStream(Stream: TStream); - procedure SaveToFile(const FileName: WideString); - procedure SaveToStream(Stream: TStream); - function GetNodeAt(X, Y: Integer): TTntTreeNode; - property DropTarget: TTntTreeNode read GetDropTarget write SetDropTarget; - property Selected: TTntTreeNode read GetSelected write SetSelected; - property TopItem: TTntTreeNode read GetTopItem write SetTopItem; - property Selections[Index: Integer]: TTntTreeNode read GetSelection; - function GetSelections(AList: TList): TTntTreeNode; - function FindNextToSelect: TTntTreeNode; reintroduce; virtual; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TTreeView} - TTntTreeView = class(TTntCustomTreeView) - published - property Align; - property Anchors; - property AutoExpand; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind default bkNone; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property BorderWidth; - property ChangeDelay; - property Color; - property Ctl3D; - property Constraints; - property DragKind; - property DragCursor; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property HotTrack; - property Images; - property Indent; - property MultiSelect; - property MultiSelectStyle; - property ParentBiDiMode; - property ParentColor default False; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ReadOnly; - property RightClickSelect; - property RowSelect; - property ShowButtons; - property ShowHint; - property ShowLines; - property ShowRoot; - property SortType; - property StateImages; - property TabOrder; - property TabStop default True; - property ToolTips; - property Visible; - property OnAddition; - property OnAdvancedCustomDraw; - property OnAdvancedCustomDrawItem; - property OnChange; - property OnChanging; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnCompare; - property OnContextPopup; - property OnCreateNodeClass; - property OnCustomDraw; - property OnCustomDrawItem; - property OnDblClick; - property OnDeletion; - property OnDragDrop; - property OnDragOver; - property OnEdited; - property OnEditing; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnExpanding; - property OnExpanded; - property OnGetImageIndex; - property OnGetSelectedIndex; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - { Items must be published after OnGetImageIndex and OnGetSelectedIndex } - property Items; - end; - -implementation - -uses - Forms, SysUtils, TntGraphics, ImgList, TntSystem, TntStdCtrls, StdCtrls, - RichEdit, ActiveIMM_TLB, TntForms, ComStrs, TntMenus, - TntActnList, TntStdActns, TntWindows, - {$IFNDEF COMPILER_10_UP} - TntWideStrings, - {$ELSE} - WideStrings, - {$ENDIF} - {$IFDEF COMPILER_9_UP} WideStrUtils {$ELSE} TntWideStrUtils {$ENDIF}; - -procedure CreateUnicodeHandle_ComCtl(Control: TWinControl; const Params: TCreateParams; - const SubClass: WideString); -begin - Assert(SubClass <> '', 'TNT Internal Error: Only call CreateUnicodeHandle_ComCtl for Common Controls.'); - CreateUnicodeHandle(Control, Params, SubClass); - if Win32PlatformIsUnicode then - SendMessageW(Control.Handle, CCM_SETUNICODEFORMAT, Integer(True), 0); -end; - -{ TTntListColumn } - -procedure TTntListColumn.Assign(Source: TPersistent); -begin - inherited; - if Source is TTntListColumn then - Caption := TTntListColumn(Source).Caption - else if Source is TListColumn{TNT-ALLOW TListColumn} then - FCaption := TListColumn{TNT-ALLOW TListColumn}(Source).Caption; -end; - -procedure TTntListColumn.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntListColumn.SetInheritedCaption(const Value: AnsiString); -begin - inherited Caption := Value; -end; - -function TTntListColumn.GetCaption: WideString; -begin - Result := GetSyncedWideString(FCaption, inherited Caption); -end; - -procedure TTntListColumn.SetCaption(const Value: WideString); -begin - SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); -end; - -{ TTntListColumns } - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackCollection = class(TPersistent) - protected - FItemClass: TCollectionItemClass; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackCollection = class(TPersistent) - protected - FItemClass: TCollectionItemClass; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackCollection = class(TPersistent) - protected - FItemClass: TCollectionItemClass; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackCollection = class(TPersistent) - protected - FItemClass: TCollectionItemClass; - end; -{$ENDIF} - -constructor TTntListColumns.Create(AOwner: TTntCustomListView); -begin - inherited Create(AOwner); - Assert(THackCollection(Self).FItemClass = Self.ItemClass, 'Internal Error in TTntListColumns.Create().'); - THackCollection(Self).FItemClass := TTntListColumn -end; - -function TTntListColumns.Owner: TTntCustomListView; -begin - Result := inherited Owner as TTntCustomListView; -end; - -function TTntListColumns.Add: TTntListColumn; -begin - Result := (inherited Add) as TTntListColumn; -end; - -function TTntListColumns.GetItem(Index: Integer): TTntListColumn; -begin - Result := inherited Items[Index] as TTntListColumn; -end; - -procedure TTntListColumns.SetItem(Index: Integer; Value: TTntListColumn); -begin - inherited SetItem(Index, Value); -end; - -{ TWideSubItems } -type - TWideSubItems = class(TTntStringList) - private - FIgnoreInherited: Boolean; - FInheritedOwner: TListItem{TNT-ALLOW TListItem}; - FOwner: TTntListItem; - protected - procedure Put(Index: Integer; const S: WideString); override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - public - procedure Insert(Index: Integer; const S: WideString); override; - function AddObject(const S: WideString; AObject: TObject): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - public - constructor Create(AOwner: TTntListItem); - end; - -constructor TWideSubItems.Create(AOwner: TTntListItem); -begin - inherited Create; - FInheritedOwner := AOwner; - FOwner := AOwner; -end; - -function TWideSubItems.AddObject(const S: WideString; AObject: TObject): Integer; -begin - FOwner.ListView.BeginChangingWideItem; - try - Result := inherited AddObject(S, AObject); - if (not FIgnoreInherited) then - FInheritedOwner.SubItems.AddObject(S, AObject); - finally - FOwner.ListView.EndChangingWideItem; - end; -end; - -procedure TWideSubItems.Clear; -begin - FOwner.ListView.BeginChangingWideItem; - try - inherited; - if (not FIgnoreInherited) then - FInheritedOwner.SubItems.Clear; - finally - FOwner.ListView.EndChangingWideItem; - end; -end; - -procedure TWideSubItems.Delete(Index: Integer); -begin - FOwner.ListView.BeginChangingWideItem; - try - inherited; - if (not FIgnoreInherited) then - FInheritedOwner.SubItems.Delete(Index); - finally - FOwner.ListView.EndChangingWideItem; - end; -end; - -procedure TWideSubItems.Insert(Index: Integer; const S: WideString); -begin - FOwner.ListView.BeginChangingWideItem; - try - inherited; - if (not FIgnoreInherited) then - FInheritedOwner.SubItems.Insert(Index, S); - finally - FOwner.ListView.EndChangingWideItem; - end; -end; - -procedure TWideSubItems.Put(Index: Integer; const S: WideString); -begin - FOwner.ListView.BeginChangingWideItem; - try - inherited; - if (not FIgnoreInherited) then - FInheritedOwner.SubItems[Index] := S; - finally - FOwner.ListView.EndChangingWideItem; - end; -end; - -function TWideSubItems.GetObject(Index: Integer): TObject; -begin - Result := FInheritedOwner.SubItems.Objects[Index]; -end; - -procedure TWideSubItems.PutObject(Index: Integer; AObject: TObject); -begin - FInheritedOwner.SubItems.Objects[Index] := AObject; -end; - -type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); - -procedure TWideSubItems.SetUpdateState(Updating: Boolean); -begin - inherited; - TAccessStrings(FInheritedOwner.SubItems).SetUpdateState(Updating); -end; - -{ TTntListItem } - -constructor TTntListItem.Create(AOwner: TListItems{TNT-ALLOW TListItems}); -begin - inherited Create(AOwner); - FSubItems := TWideSubItems.Create(Self); -end; - -destructor TTntListItem.Destroy; -begin - inherited; - FreeAndNil(FSubItems); -end; - -function TTntListItem.GetCaption: WideString; -begin - Result := GetSyncedWideString(FCaption, inherited Caption); -end; - -procedure TTntListItem.SetInheritedCaption(const Value: AnsiString); -begin - inherited Caption := Value; -end; - -procedure TTntListItem.SetCaption(const Value: WideString); -begin - ListView.BeginChangingWideItem; - try - SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); - finally - ListView.EndChangingWideItem; - end; -end; - -procedure TTntListItem.Assign(Source: TPersistent); -begin - if Source is TTntListItem then - with Source as TTntListItem do - begin - Self.Caption := Caption; - Self.Data := Data; - Self.ImageIndex := ImageIndex; - Self.Indent := Indent; - Self.OverlayIndex := OverlayIndex; - Self.StateIndex := StateIndex; - Self.SubItems := SubItems; - Self.Checked := Checked; - end - else inherited Assign(Source); -end; - -procedure TTntListItem.SetSubItems(const Value: TTntStrings); -begin - if Value <> nil then - FSubItems.Assign(Value); -end; - -function TTntListItem.GetTntOwner: TTntListItems; -begin - Result := ListView.Items; -end; - -function TTntListItem.GetListView: TTntCustomListView; -begin - Result := ((inherited Owner).Owner as TTntCustomListView); -end; - -{ TTntListItemsEnumerator } - -constructor TTntListItemsEnumerator.Create(AListItems: TTntListItems); -begin - inherited Create; - FIndex := -1; - FListItems := AListItems; -end; - -function TTntListItemsEnumerator.GetCurrent: TTntListItem; -begin - Result := FListItems[FIndex]; -end; - -function TTntListItemsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FListItems.Count - 1; - if Result then - Inc(FIndex); -end; - -{ TTntListItems } - -function TTntListItems.Add: TTntListItem; -begin - Result := (inherited Add) as TTntListItem; -end; - -function TTntListItems.AddItem(Item: TTntListItem; Index: Integer): TTntListItem; -begin - Result := (inherited AddItem(Item, Index)) as TTntListItem; -end; - -function TTntListItems.Insert(Index: Integer): TTntListItem; -begin - Result := (inherited Insert(Index)) as TTntListItem; -end; - -function TTntListItems.GetItem(Index: Integer): TTntListItem; -begin - Result := (inherited Item[Index]) as TTntListItem; -end; - -function TTntListItems.Owner: TTntCustomListView; -begin - Result := (inherited Owner) as TTntCustomListView; -end; - -procedure TTntListItems.SetItem(Index: Integer; const Value: TTntListItem); -begin - inherited Item[Index] := Value; -end; - -function TTntListItems.GetEnumerator: TTntListItemsEnumerator; -begin - Result := TTntListItemsEnumerator.Create(Self); -end; - -{ TSavedListItem } -type - TSavedListItem = class - FCaption: WideString; - FSubItems: TTntStrings; - constructor Create; - destructor Destroy; override; - end; - -constructor TSavedListItem.Create; -begin - inherited; - FSubItems := TTntStringList.Create; -end; - -destructor TSavedListItem.Destroy; -begin - FSubItems.Free; - inherited; -end; - -{ _TntInternalCustomListView } - -function _TntInternalCustomListView.OwnerDataFind(Find: TItemFind; - const FindString: AnsiString; const FindPosition: TPoint; - FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; - Wrap: Boolean): Integer; -var - WideFindString: WideString; -begin - if Assigned(PWideFindString) then - WideFindString := PWideFindString - else - WideFindString := FindString; - Result := OwnerDataFindW(Find, WideFindString, FindPosition, FindData, StartIndex, Direction, Wrap); -end; - -function _TntInternalCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; - Request: TItemRequest): Boolean; -begin - if (CurrentDispInfo <> nil) - and (OriginalDispInfoMask and LVIF_TEXT <> 0) then begin - (Item as TTntListItem).FCaption := CurrentDispInfo.item.pszText - end; - (Item as TTntListItem).FSubItems.Clear; - Result := OwnerDataFetchW(Item, Request); -end; - -{ TTntCustomListView } - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackCustomListView = class(TCustomMultiSelectListControl) - protected - FxxxCanvas: TCanvas; - FxxxBorderStyle: TBorderStyle; - FxxxViewStyle: TViewStyle; - FxxxReadOnly: Boolean; - FxxxLargeImages: TCustomImageList; - FxxxSmallImages: TCustomImageList; - FxxxStateImages: TCustomImageList; - FxxxDragImage: TDragImageList; - FxxxMultiSelect: Boolean; - FxxxSortType: TSortType; - FxxxColumnClick: Boolean; - FxxxShowColumnHeaders: Boolean; - FxxxListItems: TListItems{TNT-ALLOW TListItems}; - FxxxClicked: Boolean; - FxxxRClicked: Boolean; - FxxxIconOptions: TIconOptions; - FxxxHideSelection: Boolean; - FListColumns: TListColumns{TNT-ALLOW TListColumns}; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackCustomListView = class(TCustomMultiSelectListControl) - protected - FxxxCanvas: TCanvas; - FxxxBorderStyle: TBorderStyle; - FxxxViewStyle: TViewStyle; - FxxxReadOnly: Boolean; - FxxxLargeImages: TCustomImageList; - FxxxSmallImages: TCustomImageList; - FxxxStateImages: TCustomImageList; - FxxxDragImage: TDragImageList; - FxxxMultiSelect: Boolean; - FxxxSortType: TSortType; - FxxxColumnClick: Boolean; - FxxxShowColumnHeaders: Boolean; - FxxxListItems: TListItems{TNT-ALLOW TListItems}; - FxxxClicked: Boolean; - FxxxRClicked: Boolean; - FxxxIconOptions: TIconOptions; - FxxxHideSelection: Boolean; - FListColumns: TListColumns{TNT-ALLOW TListColumns}; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackCustomListView = class(TCustomMultiSelectListControl) - protected - FxxxCanvas: TCanvas; - FxxxBorderStyle: TBorderStyle; - FxxxViewStyle: TViewStyle; - FxxxReadOnly: Boolean; - FxxxLargeImages: TCustomImageList; - FxxxSmallImages: TCustomImageList; - FxxxStateImages: TCustomImageList; - FxxxDragImage: TDragImageList; - FxxxMultiSelect: Boolean; - FxxxSortType: TSortType; - FxxxColumnClick: Boolean; - FxxxShowColumnHeaders: Boolean; - FxxxListItems: TListItems{TNT-ALLOW TListItems}; - FxxxClicked: Boolean; - FxxxRClicked: Boolean; - FxxxIconOptions: TIconOptions; - FxxxHideSelection: Boolean; - FListColumns: TListColumns{TNT-ALLOW TListColumns}; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackCustomListView = class(TCustomMultiSelectListControl) - protected - FxxxCanvas: TCanvas; - FxxxBorderStyle: TBorderStyle; - FxxxViewStyle: TViewStyle; - FxxxReadOnly: Boolean; - FxxxLargeImages: TCustomImageList; - FxxxSaveSelectedIndex: Integer; - FxxxSmallImages: TCustomImageList; - FxxxStateImages: TCustomImageList; - FxxxDragImage: TDragImageList; - FxxxMultiSelect: Boolean; - FxxxSortType: TSortType; - FxxxColumnClick: Boolean; - FxxxShowColumnHeaders: Boolean; - FxxxListItems: TListItems{TNT-ALLOW TListItems}; - FxxxClicked: Boolean; - FxxxRClicked: Boolean; - FxxxIconOptions: TIconOptions; - FxxxHideSelection: Boolean; - FListColumns: TListColumns{TNT-ALLOW TListColumns}; - end; -{$ENDIF} - -var - ComCtrls_DefaultListViewSort: TLVCompare = nil; - -constructor TTntCustomListView.Create(AOwner: TComponent); -begin - inherited; - FEditInstance := Classes.MakeObjectInstance(EditWndProcW); - // create list columns - Assert(THackCustomListView(Self).FListColumns = inherited Columns, 'Internal Error in TTntCustomListView.Create().'); - FreeAndNil(THackCustomListView(Self).FListColumns); - THackCustomListView(Self).FListColumns := TTntListColumns.Create(Self); -end; - -destructor TTntCustomListView.Destroy; -begin - inherited; - Classes.FreeObjectInstance(FEditInstance); - FreeAndNil(FSavedItems); -end; - -procedure TTntCustomListView.CreateWindowHandle(const Params: TCreateParams); - - procedure Capture_ComCtrls_DefaultListViewSort; - begin - FTestingForSortProc := True; - try - AlphaSort; - finally - FTestingForSortProc := False; - end; - end; - -var - Column: TLVColumn; -begin - CreateUnicodeHandle_ComCtl(Self, Params, WC_LISTVIEW); - if (Win32PlatformIsUnicode) then begin - if not Assigned(ComCtrls_DefaultListViewSort) then - Capture_ComCtrls_DefaultListViewSort; - // the only way I could get editing to work is after a column had been inserted - Column.mask := 0; - ListView_InsertColumn(Handle, 0, Column); - ListView_DeleteColumn(Handle, 0); - end; -end; - -procedure TTntCustomListView.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomListView.CreateWnd; -begin - inherited; - FreeAndNil(FSavedItems); -end; - -procedure TTntCustomListView.DestroyWnd; -var - i: integer; - FSavedItem: TSavedListItem; - Item: TTntListItem; -begin - if (not (csDestroying in ComponentState)) and (not OwnerData) then begin - FreeAndNil(FSavedItems); // fixes a bug on Windows 95. - FSavedItems := TObjectList.Create(True); - for i := 0 to Items.Count - 1 do begin - FSavedItem := TSavedListItem.Create; - Item := Items[i]; - FSavedItem.FCaption := Item.FCaption; - FSavedItem.FSubItems.Assign(Item.FSubItems); - FSavedItems.Add(FSavedItem) - end; - end; - inherited; -end; - -function TTntCustomListView.GetDropTarget: TTntListItem; -begin - Result := inherited DropTarget as TTntListItem; -end; - -procedure TTntCustomListView.SetDropTarget(const Value: TTntListItem); -begin - inherited DropTarget := Value; -end; - -function TTntCustomListView.GetItemFocused: TTntListItem; -begin - Result := inherited ItemFocused as TTntListItem; -end; - -procedure TTntCustomListView.SetItemFocused(const Value: TTntListItem); -begin - inherited ItemFocused := Value; -end; - -function TTntCustomListView.GetSelected: TTntListItem; -begin - Result := inherited Selected as TTntListItem; -end; - -procedure TTntCustomListView.SetSelected(const Value: TTntListItem); -begin - inherited Selected := Value; -end; - -function TTntCustomListView.GetTopItem: TTntListItem; -begin - Result := inherited TopItem as TTntListItem; -end; - -function TTntCustomListView.GetListColumns: TTntListColumns; -begin - Result := inherited Columns as TTntListColumns; -end; - -procedure TTntCustomListView.SetListColumns(const Value: TTntListColumns); -begin - inherited Columns := Value; -end; - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackListColumn = class(TCollectionItem) - protected - FxxxAlignment: TAlignment; - FxxxAutoSize: Boolean; - FxxxCaption: AnsiString; - FxxxMaxWidth: TWidth; - FxxxMinWidth: TWidth; - FxxxImageIndex: TImageIndex; - FxxxPrivateWidth: TWidth; - FxxxWidth: TWidth; - FOrderTag: Integer; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackListColumn = class(TCollectionItem) - protected - FxxxAlignment: TAlignment; - FxxxAutoSize: Boolean; - FxxxCaption: AnsiString; - FxxxMaxWidth: TWidth; - FxxxMinWidth: TWidth; - FxxxImageIndex: TImageIndex; - FxxxPrivateWidth: TWidth; - FxxxWidth: TWidth; - FOrderTag: Integer; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackListColumn = class(TCollectionItem) - protected - FxxxxxxxxAlignment: TAlignment; - FxxxxAutoSize: Boolean; - FxxxxCaption: AnsiString; - FxxxxMaxWidth: TWidth; - FxxxxMinWidth: TWidth; - FxxxxImageIndex: TImageIndex; - FxxxxPrivateWidth: TWidth; - FxxxxWidth: TWidth; - FOrderTag: Integer; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackListColumn = class(TCollectionItem) - protected - FxxxxxxxxAlignment: TAlignment; - FxxxxAutoSize: Boolean; - FxxxxCaption: AnsiString; - FxxxxMaxWidth: TWidth; - FxxxxMinWidth: TWidth; - FxxxxImageIndex: TImageIndex; - FxxxxPrivateWidth: TWidth; - FxxxxWidth: TWidth; - FOrderTag: Integer; - end; -{$ENDIF} - -function TTntCustomListView.GetColumnFromTag(Tag: Integer): TTntListColumn; -var - I: Integer; -begin - for I := 0 to Columns.Count - 1 do - begin - Result := Columns[I]; - if THackListColumn(Result).FOrderTag = Tag then Exit; - end; - Result := nil; -end; - -function TTntCustomListView.ColumnFromIndex(Index: Integer): TTntListColumn; -begin - Result := inherited Column[Index] as TTntListColumn; -end; - -function TTntCustomListView.AreItemsStored: Boolean; -begin - if Assigned(Action) then - begin - if Action is TCustomListAction{TNT-ALLOW TCustomListAction} then - Result := False - else - Result := True; - end - else - Result := not OwnerData; -end; - -function TTntCustomListView.GetItems: TTntListItems; -begin - Result := inherited Items as TTntListItems; -end; - -procedure TTntCustomListView.SetItems(Value: TTntListItems); -begin - inherited Items := Value; -end; - -type TTntListItemClass = class of TTntListItem; - -function TTntCustomListView.CreateListItem: TListItem{TNT-ALLOW TListItem}; -var - LClass: TClass; - TntLClass: TTntListItemClass; -begin - LClass := TTntListItem; - if Assigned(OnCreateItemClass) then - OnCreateItemClass(Self, TListItemClass(LClass)); - if not LClass.InheritsFrom(TTntListItem) then - raise ETntInternalError.Create('Internal Error: OnCreateItemClass.ItemClass must inherit from TTntListItem.'); - TntLClass := TTntListItemClass(LClass); - Result := TntLClass.Create(inherited Items); - if FTempItem = nil then - FTempItem := Result as TTntListItem; { In Delphi 5/6/7/9/10, the first item created is the temp item } - { TODO: Verify that D11 creates a temp item in its constructor. } -end; - -function TTntCustomListView.CreateListItems: TListItems{TNT-ALLOW TListItems}; -begin - Result := TTntListItems.Create(Self); -end; - -function TTntCustomListView.GetItemW(Value: TLVItemW): TTntListItem; -begin - with Value do begin - if (mask and LVIF_PARAM) <> 0 then - Result := TListItem{TNT-ALLOW TListItem}(lParam) as TTntListItem - else if iItem >= 0 then - Result := Items[IItem] - else if OwnerData then - Result := FTempItem - else - Result := nil - end; -end; - -function TTntCustomListView.OwnerDataFetchW(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; -begin - Result := OwnerDataFetch(Item, Request); -end; - -function TTntCustomListView.OwnerDataFetch(Item: TListItem{TNT-ALLOW TListItem}; Request: TItemRequest): Boolean; -begin - if Assigned(OnData) then - begin - OnData(Self, Item); - Result := True; - end - else Result := False; -end; - -function TntDefaultListViewSort(Item1, Item2: TTntListItem; lParam: Integer): Integer; stdcall; -begin - Assert(Win32PlatformIsUnicode); - with Item1 do - if Assigned(ListView.OnCompare) then - ListView.OnCompare(ListView, Item1, Item2, lParam, Result) - else Result := lstrcmpw(PWideChar(Item1.Caption), PWideChar(Item2.Caption)); -end; - -procedure TTntCustomListView.WndProc(var Message: TMessage); -var - Item: TTntListItem; - InheritedItem: TListItem{TNT-ALLOW TListItem}; - SubItem: Integer; - SavedItem: TSavedListItem; - PCol: PLVColumn; - Col: TTntListColumn; -begin - with Message do begin - // restore previous values (during CreateWnd) - if (FSavedItems <> nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin - Item := Items[wParam]; - SavedItem := TSavedListItem(FSavedItems[wParam]); - if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then - Item.FCaption := SavedItem.FCaption - else begin - SubItem := PLVItem(lParam).iSubItem - 1; - TWideSubItems(Item.SubItems).FIgnoreInherited := True; - try - if SubItem < Item.SubItems.Count then begin - Item.SubItems[SubItem] := SavedItem.FSubItems[SubItem]; - Item.SubItems.Objects[SubItem] := SavedItem.FSubItems.Objects[SubItem] - end else if SubItem = Item.SubItems.Count then - Item.SubItems.AddObject(SavedItem.FSubItems[SubItem], SavedItem.FSubItems.Objects[SubItem]) - else - Item.SubItems.Assign(SavedItem.FSubItems) - finally - TWideSubItems(Item.SubItems).FIgnoreInherited := False; - end; - end; - end; - - // sync wide with ansi - if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_UPDATE) then begin - Item := Items[wParam]; - InheritedItem := Item; - TWideSubItems(Item.SubItems).FIgnoreInherited := True; - try - Item.SubItems.Assign(InheritedItem.SubItems) - finally - TWideSubItems(Item.SubItems).FIgnoreInherited := False; - end; - end; - - if (FSavedItems = nil) and (FChangingWideItemCount = 0) and (Msg = LVM_SETITEMTEXTA) then begin - if OwnerData then - Item := FTempItem - else - Item := Items[wParam]; - InheritedItem := Item; - if (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).iSubItem = 0) then - Item.FCaption := InheritedItem.Caption - else begin - SubItem := PLVItem(lParam).iSubItem - 1; - TWideSubItems(Item.SubItems).FIgnoreInherited := True; - try - if SubItem < Item.SubItems.Count then begin - Item.SubItems[SubItem] := InheritedItem.SubItems[SubItem]; - Item.SubItems.Objects[SubItem] := InheritedItem.SubItems.Objects[SubItem] - end else if SubItem = Item.SubItems.Count then - Item.SubItems.AddObject(InheritedItem.SubItems[SubItem], InheritedItem.SubItems.Objects[SubItem]) - else - Item.SubItems.Assign(InheritedItem.SubItems) - finally - TWideSubItems(Item.SubItems).FIgnoreInherited := False; - end; - end; - end; - - // capture ANSI version of DefaultListViewSort from ComCtrls - if (FTestingForSortProc) - and (Msg = LVM_SORTITEMS) then begin - ComCtrls_DefaultListViewSort := Pointer(lParam); - exit; - end; - - if (Msg = LVM_SETCOLUMNA) then begin - // make sure that wide column caption stays in sync with ANSI - PCol := PLVColumn(lParam); - if (PCol.mask and LVCF_TEXT) <> 0 then begin - Col := GetColumnFromTag(wParam); - if (Col <> nil) and (AnsiString(Col.Caption) <> PCol.pszText) then begin - Col.FCaption := PCol.pszText; - end; - end; - end; - - if (Win32PlatformIsUnicode) - and (Msg = LVM_SETITEMTEXTA) and (PLVItem(lParam).pszText = LPSTR_TEXTCALLBACK) then - // Unicode:: call wide version of text call back instead - Result := SendMessageW(Handle, LVM_SETITEMTEXTW, WParam, LParam) - else if (Win32PlatformIsUnicode) - and (Msg = LVM_SORTITEMS) and (Pointer(lParam) = @ComCtrls_DefaultListViewSort) then - // Unicode:: call wide version of sort proc instead - Result := SendMessageW(Handle, LVM_SORTITEMS, wParam, Integer(@TntDefaultListViewSort)) - else if (Win32PlatformIsUnicode) - and (Msg = LVM_SETCOLUMNA) and ((PLVColumn(lParam).mask and LVCF_TEXT) <> 0) - and (GetColumnFromTag(wParam) <> nil) then begin - PLVColumn(lParam).pszText := PAnsiChar(PWideChar(GetColumnFromTag(wParam).FCaption)); - Result := SendMessageW(Handle, LVM_SETCOLUMNW, wParam, lParam); - end else begin - if (Msg = LVM_SETEXTENDEDLISTVIEWSTYLE) and CheckBoxes then begin - { fix a bug in TCustomListView.ResetExStyles } - lParam := lParam or LVS_EX_SUBITEMIMAGES or LVS_EX_INFOTIP; - end; - inherited; - end; - end; -end; - -procedure TTntCustomListView.WMNotify(var Message: TWMNotify); -begin - inherited; - // capture updated info after inherited - with Message.NMHdr^ do - case code of - HDN_ENDTRACKW: - begin - Message.NMHdr^.code := HDN_ENDTRACKA; - try - inherited - finally - Message.NMHdr^.code := HDN_ENDTRACKW; - end; - end; - HDN_DIVIDERDBLCLICKW: - begin - Message.NMHdr^.code := HDN_DIVIDERDBLCLICKA; - try - inherited - finally - Message.NMHdr^.code := HDN_DIVIDERDBLCLICKW; - end; - end; - end; -end; - -procedure TTntCustomListView.CNNotify(var Message: TWMNotify); -var - Item: TTntListItem; -begin - if (not Win32PlatformIsUnicode) then - inherited - else begin - with Message do - begin - case NMHdr^.code of - HDN_TRACKW: - begin - NMHdr^.code := HDN_TRACKA; - try - inherited; - finally - NMHdr^.code := HDN_TRACKW; - end; - end; - LVN_GETDISPINFOW: - begin - // call inherited without the LVIF_TEXT flag - CurrentDispInfo := PLVDispInfoW(NMHdr); - try - OriginalDispInfoMask := PLVDispInfoW(NMHdr)^.item.mask; - - PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask and (not LVIF_TEXT); - try - NMHdr^.code := LVN_GETDISPINFOA; - try - inherited; - finally - NMHdr^.code := LVN_GETDISPINFOW; - end; - finally - if (OriginalDispInfoMask and LVIF_TEXT <> 0) then - PLVDispInfoW(NMHdr)^.item.mask := PLVDispInfoW(NMHdr)^.item.mask or LVIF_TEXT; - end; - finally - CurrentDispInfo := nil; - end; - - // handle any text info - with PLVDispInfoW(NMHdr)^.item do - begin - if (mask and LVIF_TEXT) <> 0 then - begin - Item := GetItemW(PLVDispInfoW(NMHdr)^.item); - if iSubItem = 0 then - WStrLCopy(pszText, PWideChar(Item.Caption), cchTextMax - 1) - else begin - with Item.SubItems do begin - if iSubItem <= Count then - WStrLCopy(pszText, PWideChar(Strings[iSubItem - 1]), cchTextMax - 1) - else pszText[0] := #0; - end; - end; - end; - end; - end; - LVN_ODFINDITEMW: - with PNMLVFindItem(NMHdr)^ do - begin - if ((lvfi.flags and LVFI_PARTIAL) <> 0) or ((lvfi.flags and LVFI_STRING) <> 0) then - PWideFindString := TLVFindInfoW(lvfi).psz - else - PWideFindString := nil; - lvfi.psz := nil; - NMHdr^.code := LVN_ODFINDITEMA; - try - inherited; {will Result in call to OwnerDataFind} - finally - TLVFindInfoW(lvfi).psz := PWideFindString; - NMHdr^.code := LVN_ODFINDITEMW; - PWideFindString := nil; - end; - end; - LVN_BEGINLABELEDITW: - begin - Item := GetItemW(PLVDispInfoW(NMHdr)^.item); - if not CanEdit(Item) then Result := 1; - if Result = 0 then - begin - FEditHandle := ListView_GetEditControl(Handle); - FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); - SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); - end; - end; - LVN_ENDLABELEDITW: - with PLVDispInfoW(NMHdr)^ do - if (item.pszText <> nil) and (item.IItem <> -1) then - Edit(TLVItemA(item)); - LVN_GETINFOTIPW: - begin - NMHdr^.code := LVN_GETINFOTIPA; - try - inherited; - finally - NMHdr^.code := LVN_GETINFOTIPW; - end; - end; - else - inherited; - end; - end; - end; -end; - -function TTntCustomListView.OwnerDataFindW(Find: TItemFind; - const FindString: WideString; const FindPosition: TPoint; - FindData: Pointer; StartIndex: Integer; Direction: TSearchDirection; - Wrap: Boolean): Integer; -begin - Result := OwnerDataFind(Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap); -end; - -function TTntCustomListView.OwnerDataFind(Find: TItemFind; const FindString: WideString; - const FindPosition: TPoint; FindData: Pointer; StartIndex: Integer; - Direction: TSearchDirection; Wrap: Boolean): Integer; -var - AnsiEvent: TLVOwnerDataFindEvent; -begin - Result := -1; - if Assigned(OnDataFind) then - OnDataFind(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, Wrap, Result) - else if Assigned(inherited OnDataFind) then begin - AnsiEvent := inherited OnDataFind; - AnsiEvent(Self, Find, FindString, FindPosition, FindData, StartIndex, Direction, - Wrap, Result); - end; -end; - -procedure TTntCustomListView.Edit(const Item: TLVItem); -var - S: WideString; - AnsiS: AnsiString; - EditItem: TTntListItem; - AnsiEvent: TLVEditedEvent; -begin - if (not Win32PlatformIsUnicode) then - S := Item.pszText - else - S := TLVItemW(Item).pszText; - EditItem := GetItemW(TLVItemW(Item)); - if Assigned(OnEdited) then - OnEdited(Self, EditItem, S) - else if Assigned(inherited OnEdited) then - begin - AnsiEvent := inherited OnEdited; - AnsiS := S; - AnsiEvent(Self, EditItem, AnsiS); - S := AnsiS; - end; - if EditItem <> nil then - EditItem.Caption := S; -end; - -procedure TTntCustomListView.EditWndProcW(var Message: TMessage); -begin - Assert(Win32PlatformIsUnicode); - try - with Message do - begin - case Msg of - WM_KEYDOWN, - WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; - WM_CHAR: - begin - MakeWMCharMsgSafeForAnsi(Message); - try - if DoKeyPress(TWMKey(Message)) then Exit; - finally - RestoreWMCharMsg(Message); - end; - end; - WM_KEYUP, - WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; - CN_KEYDOWN, - CN_CHAR, CN_SYSKEYDOWN, - CN_SYSCHAR: - begin - WndProc(Message); - Exit; - end; - end; - Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); - end; - except - Application.HandleException(Self); - end; -end; - -procedure TTntCustomListView.BeginChangingWideItem; -begin - Inc(FChangingWideItemCount); -end; - -procedure TTntCustomListView.EndChangingWideItem; -begin - if FChangingWideItemCount > 0 then - Dec(FChangingWideItemCount); -end; - -procedure TTntCustomListView.DrawItem(Item: TListItem{TNT-ALLOW TListItem}; Rect: TRect; - State: TOwnerDrawState); -begin - TControlCanvas(Canvas).UpdateTextFlags; - if Assigned(OnDrawItem) then OnDrawItem(Self, Item, Rect, State) - else - begin - Canvas.FillRect(Rect); - WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Item.Caption); - end; -end; - -procedure TTntCustomListView.CopySelection(Destination: TCustomListControl); -var - I: Integer; -begin - for I := 0 to Items.Count - 1 do - if Items[I].Selected then - WideListControl_AddItem(Destination, Items[I].Caption, Items[I].Data); -end; - -procedure TTntCustomListView.AddItem(const Item: WideString; AObject: TObject); -begin - with Items.Add do - begin - Caption := Item; - Data := AObject; - end; -end; - -//------------- - -function TTntCustomListView.FindCaption(StartIndex: Integer; Value: WideString; - Partial, Inclusive, Wrap: Boolean): TTntListItem; -const - FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL); - Wraps: array[Boolean] of Integer = (0, LVFI_WRAP); -var - Info: TLVFindInfoW; - Index: Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := inherited FindCaption(StartIndex, Value, Partial, Inclusive, Wrap) as TTntListItem - else begin - with Info do - begin - flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap]; - psz := PWideChar(Value); - end; - if Inclusive then Dec(StartIndex); - Index := SendMessageW(Handle, LVM_FINDITEMW, StartIndex, Longint(@Info)); - if Index <> -1 then Result := Items[Index] - else Result := nil; - end; -end; - -function TTntCustomListView.StringWidth(S: WideString): Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := inherited StringWidth(S) - else - Result := SendMessageW(Handle, LVM_GETSTRINGWIDTHW, 0, Longint(PWideChar(S))) -end; - -function TTntCustomListView.GetSearchString: WideString; -var - Buffer: array[0..1023] of WideChar; -begin - if (not Win32PlatformIsUnicode) then - Result := inherited GetSearchString - else begin - Result := ''; - if HandleAllocated - and Bool(SendMessageW(Handle, LVM_GETISEARCHSTRINGW, 0, Longint(PWideChar(@Buffer[0])))) then - Result := Buffer; - end; -end; - -function TTntCustomListView.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomListView.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomListView.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomListView.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomListView.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntToolButton } - -procedure TTntToolButton.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntToolButton.CMVisibleChanged(var Message: TMessage); -begin - inherited; - RefreshControl; -end; - -function TTntToolButton.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntToolButton.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); - RefreshControl; { causes button to be removed and reinserted with TB_INSERTBUTTON } -end; - -function TTntToolButton.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntToolButton.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntToolButton.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntToolButton.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -procedure TTntToolButton.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntToolButton.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -function TTntToolButton.GetMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; -begin - Result := inherited MenuItem; -end; - -procedure TTntToolButton.SetMenuItem(const Value: TMenuItem{TNT-ALLOW TMenuItem}); -begin - inherited MenuItem := Value; - if Value is TTntMenuItem then begin - Caption := TTntMenuItem(Value).Caption; - Hint := TTntMenuItem(Value).Hint; - end; -end; - -{ TTntToolBar } - -procedure TTntToolBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, TOOLBARCLASSNAME); -end; - -procedure TTntToolBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntToolBar.TBInsertButtonA(var Message: TMessage); -var - Button: TTntToolButton; - Buffer: WideString; -begin - if Win32PlatformIsUnicode - and (PTBButton(Message.LParam).iString <> -1) - and (Buttons[Message.WParam] is TTntToolButton) then - begin - Button := TTntToolButton(Buttons[Message.WParam]); - Buffer := Button.Caption + WideChar(#0); - PTBButton(Message.LParam).iString := - SendMessage(Handle, TB_ADDSTRINGW, 0, Integer(PWideChar(Buffer))); - end; - inherited; -end; - -{ Need to read/write caption ourselves - default wndproc seems to discard it. } - -procedure TTntToolBar.WMGetText(var Message: TWMGetText); -begin - if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then - inherited - else - with Message do - Result := WStrLen(WStrLCopy(PWideChar(Text), PWideChar(FCaption), TextMax - 1)); -end; - -procedure TTntToolBar.WMGetTextLength(var Message: TWMGetTextLength); -begin - if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then - inherited - else - Message.Result := Length(FCaption); -end; - -procedure TTntToolBar.WMSetText(var Message: TWMSetText); -begin - if (not Win32PlatformIsUnicode) or (WindowHandle = 0) then - inherited - else - with Message do - SetString(FCaption, PWideChar(Text), WStrLen(PWideChar(Text))); -end; - -function TTntToolBar.GetCaption: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntToolBar.SetCaption(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -function TTntToolBar.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntToolBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntToolBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntToolBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -procedure TTntToolBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntToolBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -function TTntToolBar.GetMenu: TMainMenu{TNT-ALLOW TMainMenu}; -begin - Result := inherited Menu; -end; - -procedure TTntToolBar.SetMenu(const Value: TMainMenu{TNT-ALLOW TMainMenu}); -var - I: Integer; -begin - if (Menu <> Value) then begin - inherited Menu := Value; - if Assigned(Menu) then begin - // get rid of TToolButton(s) - for I := ButtonCount - 1 downto 0 do - Buttons[I].Free; - // add TTntToolButton(s) - for I := Menu.Items.Count - 1 downto 0 do - begin - with TTntToolButton.Create(Self) do - try - AutoSize := True; - Grouped := True; - Parent := Self; - MenuItem := Menu.Items[I]; - except - Free; - raise; - end; - end; - end; - end; -end; - -{ TTntRichEditStrings } -type - TTntRichEditStrings = class(TTntMemoStrings) - private - RichEdit: TCustomRichEdit{TNT-ALLOW TCustomRichEdit}; - procedure EnableChange(const Value: Boolean); - protected - procedure SetTextStr(const Value: WideString); override; - public - constructor Create; - procedure AddStrings(Strings: TWideStrings); overload; override; - //-- - procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); override; - procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); override; - procedure LoadFromFile(const FileName: WideString); override; - procedure SaveToFile(const FileName: WideString); override; - end; - -constructor TTntRichEditStrings.Create; -begin - inherited Create; - FRichEditMode := True; -end; - -procedure TTntRichEditStrings.AddStrings(Strings: TWideStrings); -var - SelChange: TNotifyEvent; -begin - SelChange := TTntCustomRichEdit(RichEdit).OnSelectionChange; - TTntCustomRichEdit(RichEdit).OnSelectionChange := nil; - try - inherited; - finally - TTntCustomRichEdit(RichEdit).OnSelectionChange := SelChange; - end; -end; - -procedure TTntRichEditStrings.EnableChange(const Value: Boolean); -var - EventMask: Longint; -begin - with RichEdit do - begin - if Value then - EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE - else - EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE; - SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask); - end; -end; - -procedure TTntRichEditStrings.SetTextStr(const Value: WideString); -begin - EnableChange(False); - try - inherited; - finally - EnableChange(True); - end; -end; - -type TAccessCustomRichEdit = class(TCustomRichEdit{TNT-ALLOW TCustomRichEdit}); - -procedure TTntRichEditStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); -begin - if TAccessCustomRichEdit(RichEdit).PlainText then - inherited LoadFromStream_BOM(Stream, WithBOM) - else - TAccessCustomRichEdit(RichEdit).Lines.LoadFromStream(Stream); -end; - -procedure TTntRichEditStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); -begin - if TAccessCustomRichEdit(RichEdit).PlainText then - inherited SaveToStream_BOM(Stream, WithBOM) - else - TAccessCustomRichEdit(RichEdit).Lines.SaveToStream(Stream); -end; - -procedure TTntRichEditStrings.LoadFromFile(const FileName: WideString); -begin - if TAccessCustomRichEdit(RichEdit).PlainText then - inherited LoadFromFile(FileName) - else - TAccessCustomRichEdit(RichEdit).Lines.LoadFromFile(FileName); -end; - -procedure TTntRichEditStrings.SaveToFile(const FileName: WideString); -begin - if TAccessCustomRichEdit(RichEdit).PlainText then - inherited SaveToFile(FileName) - else - TAccessCustomRichEdit(RichEdit).Lines.SaveToFile(FileName); -end; - -{ TTntCustomRichEdit } - -constructor TTntCustomRichEdit.Create(AOwner: TComponent); -begin - inherited; - FRichEditStrings := TTntRichEditStrings.Create; - TTntRichEditStrings(FRichEditStrings).FMemo := Self; - TTntRichEditStrings(FRichEditStrings).FMemoLines := TAccessCustomRichEdit(Self).Lines; - TTntRichEditStrings(FRichEditStrings).FLineBreakStyle := Self.LineBreakStyle; - TTntRichEditStrings(FRichEditStrings).RichEdit := Self; -end; - -var - FRichEdit20Module: THandle = 0; - -function IsRichEdit20Available: Boolean; -const - RICHED20_DLL = 'RICHED20.DLL'; -begin - if FRichEdit20Module = 0 then - FRichEdit20Module := Tnt_LoadLibraryW(RICHED20_DLL); - Result := FRichEdit20Module <> 0; -end; - -{function IsRichEdit30Available: Boolean; -begin - Result := False; - exit; - Result := IsRichEdit20Available and (Win32MajorVersion >= 5); -end;} - -procedure TTntCustomRichEdit.CreateParams(var Params: TCreateParams); -begin - inherited CreateParams(Params); - if WordWrap then - Params.Style := Params.Style and not WS_HSCROLL; // more compatible with RichEdit 1.0 -end; - -procedure TTntCustomRichEdit.CreateWindowHandle(const Params: TCreateParams); -begin - if Win32PlatformIsUnicode and IsRichEdit20Available then - CreateUnicodeHandle(Self, Params, RICHEDIT_CLASSW) - else - inherited -end; - -var - AIMM: IActiveIMMApp = nil; - -function EnableActiveIMM: Boolean; -begin - if AIMM <> nil then - Result := True - else begin - Result := False; - try - if ClassIsRegistered(CLASS_CActiveIMM) then begin - AIMM := CoCActiveIMM.Create; - AIMM.Activate(1); - Result := True; - end; - except - AIMM := nil; - end; - end; -end; - -procedure TTntCustomRichEdit.CreateWnd; -const - EM_SETEDITSTYLE = WM_USER + 204; - SES_USEAIMM = 64; -begin - inherited; - // Only supported in RichEdit 3.0, but this flag is harmless to RichEdit1.0 or RichEdit 2.0 - if EnableActiveIMM then - SendMessage(Handle, EM_SETEDITSTYLE, SES_USEAIMM, SES_USEAIMM); -end; - -procedure TTntCustomRichEdit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -destructor TTntCustomRichEdit.Destroy; -begin - FreeAndNil(FRichEditStrings); - inherited; -end; - -procedure TTntCustomRichEdit.KeyDown(var Key: Word; Shift: TShiftState); -begin - inherited; - if (not WantReturns) and (Key = VK_RETURN) and (Shift <> [ssCtrl]) then - Key := 0; -end; - -function TTntCustomRichEdit.LineBreakStyle: TTntTextLineBreakStyle; -begin - if Win32PlatformIsUnicode and IsRichEdit20Available then - Result := tlbsCR - else - Result := tlbsCRLF; -end; - -procedure TTntCustomRichEdit.SetRichEditStrings(const Value: TTntStrings); -begin - FRichEditStrings.Assign(Value); -end; - -function TTntCustomRichEdit.GetSelText: string{TNT-ALLOW string}; -begin - Result := GetWideSelText; -end; - -function TTntCustomRichEdit.GetWideSelText: WideString; -var - CharRange: TCharRange; - Length: Integer; -begin - if (not IsWindowUnicode(Handle)) then - Result := inherited GetSelText - else begin - SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); - SetLength(Result, CharRange.cpMax - CharRange.cpMin + 1); - Length := SendMessageW(Handle, EM_GETSELTEXT, 0, Longint(PWideChar(Result))); - SetLength(Result, Length); - end; - if LineBreakStyle <> tlbsCRLF then - Result := TntAdjustLineBreaks(Result, tlbsCRLF) -end; - -type - TSetTextEx = record - flags:dword; - codepage:uint; - end; - -procedure TTntCustomRichEdit.SetRTFText(Flags: DWORD; const Value: AnsiString); -const - EM_SETTEXTEX = (WM_USER + 97); -var - Info: TSetTextEx; -begin - Info.flags := Flags; - Info.codepage := CP_ACP{TNT-ALLOW CP_ACP}; - SendMessage(Handle, EM_SETTEXTEX, Integer(@Info), Integer(PAnsiChar(Value))); -end; - -procedure TTntCustomRichEdit.SetWideSelText(const Value: WideString); -const - ST_SELECTION = 2; -begin - if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin - // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) - SetRTFText(ST_SELECTION, Value) - end else - TntCustomEdit_SetSelText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); -end; - -function TTntCustomRichEdit.GetText: WideString; -begin - Result := TntControl_GetText(Self); - if (LineBreakStyle <> tlbsCRLF) then - Result := TntAdjustLineBreaks(Result, tlbsCRLF); -end; - -procedure TTntCustomRichEdit.SetText(const Value: WideString); -const - ST_DEFAULT = 0; -begin - if Win32PlatformIsUnicode and IsRichEdit20Available and IsRTF(Value) then begin - // emulate RichEdit 1.0 so that RTF code is inserted as RTF (not plain text) - SetRTFText(ST_DEFAULT, Value) - end else if Value <> Text then - TntControl_SetText(Self, TntAdjustLineBreaks(Value, LineBreakStyle)); -end; - -function TTntCustomRichEdit.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomRichEdit.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomRichEdit.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomRichEdit.WMGetTextLength(var Message: TWMGetTextLength); -begin - if FPrintingTextLength <> 0 then - Message.Result := FPrintingTextLength - else - inherited; -end; - -procedure TTntCustomRichEdit.Print(const Caption: string{TNT-ALLOW string}); -begin - if (LineBreakStyle <> tlbsCRLF) then - FPrintingTextLength := TntAdjustLineBreaksLength(Text, LineBreakStyle) - else - FPrintingTextLength := 0; - try - inherited - finally - FPrintingTextLength := 0; - end; -end; - -{$WARN SYMBOL_DEPRECATED OFF} - -function TTntCustomRichEdit.CharPosToGet(RawWin32CharPos: Integer): Integer; -begin - Result := EmulatedCharPos(RawWin32CharPos); -end; - -function TTntCustomRichEdit.CharPosToSet(EmulatedCharPos: Integer): Integer; -begin - Result := RawWin32CharPos(EmulatedCharPos); -end; -{$WARN SYMBOL_DEPRECATED ON} - -function TTntCustomRichEdit.EmulatedCharPos(RawWin32CharPos: Integer): Integer; -var - i: Integer; - ThisLine: Integer; - CharCount: Integer; - Line_Start: Integer; - NumLineBreaks: Integer; -begin - if (LineBreakStyle = tlbsCRLF) or (RawWin32CharPos <= 0) then - Result := RawWin32CharPos - else begin - Assert(Win32PlatformIsUnicode); - ThisLine := SendMessageW(Handle, EM_EXLINEFROMCHAR, 0, RawWin32CharPos); - if (not WordWrap) then - NumLineBreaks := ThisLine - else begin - CharCount := 0; - for i := 0 to ThisLine - 1 do - Inc(CharCount, TntMemo_LineLength(Handle, i)); - Line_Start := TntMemo_LineStart(Handle, ThisLine); - NumLineBreaks := Line_Start - CharCount; - end; - Result := RawWin32CharPos + NumLineBreaks; {inflate CR -> CR/LF} - end; -end; - -function TTntCustomRichEdit.RawWin32CharPos(EmulatedCharPos: Integer): Integer; -var - Line: Integer; - NumLineBreaks: Integer; - CharCount: Integer; - Line_Start: Integer; - LineLength: Integer; -begin - if (LineBreakStyle = tlbsCRLF) or (EmulatedCharPos <= 0) then - Result := EmulatedCharPos - else begin - Assert(Win32PlatformIsUnicode); - NumLineBreaks := 0; - CharCount := 0; - for Line := 0 to Lines.Count do begin - Line_Start := TntMemo_LineStart(Handle, Line); - if EmulatedCharPos < (Line_Start + NumLineBreaks) then - break; {found it (it must have been the line separator)} - if Line_Start > CharCount then begin - Inc(NumLineBreaks); - Inc(CharCount); - end; - LineLength := TntMemo_LineLength(Handle, Line, Line_Start); - Inc(CharCount, LineLength); - if (EmulatedCharPos >= (Line_Start + NumLineBreaks)) - and (EmulatedCharPos < (Line_Start + LineLength + NumLineBreaks)) then - break; {found it} - end; - Result := EmulatedCharPos - NumLineBreaks; {deflate CR/LF -> CR} - end; -end; - -function TTntCustomRichEdit.FindText(const SearchStr: WideString; - StartPos, Length: Integer; Options: TSearchTypes): Integer; -const - EM_FINDTEXTEXW = WM_USER + 124; -const - FR_DOWN = $00000001; - FR_WHOLEWORD = $00000002; - FR_MATCHCASE = $00000004; -var - Find: TFindTextW; - Flags: Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := inherited FindText(SearchStr, StartPos, Length, Options) - else begin - with Find.chrg do - begin - cpMin := RawWin32CharPos(StartPos); - cpMax := RawWin32CharPos(StartPos + Length); - end; - Flags := FR_DOWN; { RichEdit 2.0 and later needs this } - if stWholeWord in Options then Flags := Flags or FR_WHOLEWORD; - if stMatchCase in Options then Flags := Flags or FR_MATCHCASE; - Find.lpstrText := PWideChar(SearchStr); - Result := SendMessageW(Handle, EM_FINDTEXT, Flags, LongInt(@Find)); - Result := EmulatedCharPos(Result); - end; -end; - -function TTntCustomRichEdit.GetSelStart: Integer; -begin - Result := TntCustomEdit_GetSelStart(Self); - Result := EmulatedCharPos(Result); -end; - -procedure TTntCustomRichEdit.SetSelStart(const Value: Integer); -begin - TntCustomEdit_SetSelStart(Self, RawWin32CharPos(Value)); -end; - -function TTntCustomRichEdit.GetSelLength: Integer; -var - CharRange: TCharRange; -begin - if (LineBreakStyle = tlbsCRLF) then - Result := TntCustomEdit_GetSelLength(Self) - else begin - Assert(Win32PlatformIsUnicode); - SendMessageW(Handle, EM_EXGETSEL, 0, Longint(@CharRange)); - Result := EmulatedCharPos(CharRange.cpMax) - EmulatedCharPos(CharRange.cpMin); - end; -end; - -procedure TTntCustomRichEdit.SetSelLength(const Value: Integer); -var - StartPos: Integer; - SelEnd: Integer; -begin - if (LineBreakStyle = tlbsCRLF) then - TntCustomEdit_SetSelLength(Self, Value) - else begin - StartPos := Self.SelStart; - SelEnd := StartPos + Value; - inherited SetSelLength(RawWin32CharPos(SelEnd) - RawWin32CharPos(StartPos)); - end; -end; - -procedure TTntCustomRichEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomRichEdit.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntTabStrings } - -type TAccessCustomTabControl = class(TCustomTabControl{TNT-ALLOW TCustomTabControl}); - -type - TTntTabStrings = class(TTntStrings) - private - FTabControl: TCustomTabControl{TNT-ALLOW TCustomTabControl}; - FAnsiTabs: TStrings{TNT-ALLOW TStrings}; - protected - function Get(Index: Integer): WideString; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure Put(Index: Integer; const S: WideString); override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - public - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: WideString); override; - end; - -procedure TabControlError(const S: WideString); -begin - raise EListError.Create(S); -end; - -procedure TTntTabStrings.Clear; -begin - FAnsiTabs.Clear; -end; - -procedure TTntTabStrings.Delete(Index: Integer); -begin - FAnsiTabs.Delete(Index); -end; - -function TTntTabStrings.GetCount: Integer; -begin - Result := FAnsiTabs.Count; -end; - -function TTntTabStrings.GetObject(Index: Integer): TObject; -begin - Result := FAnsiTabs.Objects[Index]; -end; - -procedure TTntTabStrings.PutObject(Index: Integer; AObject: TObject); -begin - FAnsiTabs.Objects[Index] := AObject; -end; - -procedure TTntTabStrings.SetUpdateState(Updating: Boolean); -begin - inherited; - TAccessStrings(FAnsiTabs).SetUpdateState(Updating); -end; - -function TTntTabStrings.Get(Index: Integer): WideString; -const - RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); -var - TCItem: TTCItemW; - Buffer: array[0..4095] of WideChar; -begin - if (not Win32PlatformIsUnicode) then - Result := FAnsiTabs[Index] - else begin - TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading]; - TCItem.pszText := Buffer; - TCItem.cchTextMax := SizeOf(Buffer); - if SendMessageW(FTabControl.Handle, TCM_GETITEMW, Index, Longint(@TCItem)) = 0 then - TabControlError(WideFormat(sTabFailRetrieve, [Index])); - Result := Buffer; - end; -end; - -function GetTabControlImageIndex(Self: TCustomTabControl{TNT-ALLOW TCustomTabControl}; TabIndex: Integer): Integer; -begin - Result := TabIndex; - with TAccessCustomTabControl(Self) do - if Assigned(OnGetImageIndex) then OnGetImageIndex(Self, TabIndex, Result); -end; - -procedure TTntTabStrings.Put(Index: Integer; const S: WideString); -const - RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); -var - TCItem: TTCItemW; -begin - if (not Win32PlatformIsUnicode) then - FAnsiTabs[Index] := S - else begin - TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; - TCItem.pszText := PWideChar(S); - TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); - if SendMessageW(FTabControl.Handle, TCM_SETITEMW, Index, Longint(@TCItem)) = 0 then - TabControlError(WideFormat(sTabFailSet, [S, Index])); - TAccessCustomTabControl(FTabControl).UpdateTabImages; - end; -end; - -procedure TTntTabStrings.Insert(Index: Integer; const S: WideString); -const - RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING); -var - TCItem: TTCItemW; -begin - if (not Win32PlatformIsUnicode) then - FAnsiTabs.Insert(Index, S) - else begin - TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE; - TCItem.pszText := PWideChar(S); - TCItem.iImage := GetTabControlImageIndex(FTabControl, Index); - if SendMessageW(FTabControl.Handle, TCM_INSERTITEMW, Index, Longint(@TCItem)) < 0 then - TabControlError(WideFormat(sTabFailSet, [S, Index])); - TAccessCustomTabControl(FTabControl).UpdateTabImages; - end; -end; - -{ TTntCustomTabControl } - -constructor TTntCustomTabControl.Create(AOwner: TComponent); -begin - inherited; - FTabs := TTntTabStrings.Create; - TTntTabStrings(FTabs).FTabControl := Self; - TTntTabStrings(FTabs).FAnsiTabs := inherited Tabs; -end; - -destructor TTntCustomTabControl.Destroy; -begin - TTntTabStrings(FTabs).FTabControl := nil; - TTntTabStrings(FTabs).FAnsiTabs := nil; - FreeAndNil(FTabs); - FreeAndNil(FSaveTabs); - inherited; -end; - -procedure TTntCustomTabControl.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); -end; - -procedure TTntCustomTabControl.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomTabControl.CreateWnd; -begin - inherited; - if FSaveTabs <> nil then - begin - FTabs.Assign(FSaveTabs); - FreeAndNil(FSaveTabs); - TabIndex := FSaveTabIndex; - end; -end; - -procedure TTntCustomTabControl.DestroyWnd; -begin - if (FTabs <> nil) and (FTabs.Count > 0) then - begin - FSaveTabs := TTntStringList.Create; - FSaveTabs.Assign(FTabs); - FSaveTabIndex := TabIndex; - end; - inherited; -end; - -function TTntCustomTabControl.GetTabs: TTntStrings; -begin - if FSaveTabs <> nil then - Result := FSaveTabs // Use FSaveTabs while the window is deallocated - else - Result := FTabs; -end; - -procedure TTntCustomTabControl.SetTabs(const Value: TTntStrings); -begin - FTabs.Assign(Value); -end; - -function TTntCustomTabControl.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomTabControl.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomTabControl.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomTabControl.CMDialogChar(var Message: TCMDialogChar); -var - I: Integer; -begin - for I := 0 to Tabs.Count - 1 do - if IsWideCharAccel(Message.CharCode, Tabs[I]) and CanShowTab(I) and CanFocus then - begin - Message.Result := 1; - if CanChange then - begin - TabIndex := I; - Change; - end; - Exit; - end; - Broadcast(Message); -end; - -procedure TTntCustomTabControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomTabControl.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntTabSheet } - -procedure TTntTabSheet.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -function TTntTabSheet.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntTabSheet.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntTabSheet.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntTabSheet.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntTabSheet.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntTabSheet.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntTabSheet.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntTabSheet.WMSetText(var Message: TWMSetText); -begin - if (not Win32PlatformIsUnicode) - or (HandleAllocated) - or (Message.Text = AnsiString(TntControl_GetText(Self))) - or (Force_Inherited_WMSETTEXT) then - inherited - else begin - // NT, handle not allocated and text is different - Force_Inherited_WMSETTEXT := True; - try - TntControl_SetText(Self, Message.Text) { sync WideCaption with ANSI Caption } - finally - Force_Inherited_WMSETTEXT := FALSE; - end; - end; -end; - -procedure TTntTabSheet.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntTabSheet.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntPageControl } - -procedure TTntPageControl.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, WC_TABCONTROL); -end; - -procedure TTntPageControl.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntPageControl.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntPageControl.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntPageControl.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntPageControl.WndProc(var Message: TMessage); -const - RTL: array[Boolean] of Cardinal = (0, TCIF_RTLREADING); -var - TCItemA: PTCItemA; - TabSheet: TTabSheet{TNT-ALLOW TTabSheet}; - Text: WideString; -begin - if (not Win32PlatformIsUnicode) then - inherited - else begin - case Message.Msg of - TCM_SETITEMA: - begin - TCItemA := PTCItemA(Message.lParam); - if ((TCItemA.mask and TCIF_PARAM) = TCIF_PARAM) then - TabSheet := TObject(TCItemA.lParam) as TTabSheet{TNT-ALLOW TTabSheet} - else if ((TCItemA.mask and TCIF_TEXT) = TCIF_TEXT) - and (Message.wParam >= 0) and (Message.wParam <= Tabs.Count - 1) then - TabSheet := Tabs.Objects[Message.wParam] as TTabSheet{TNT-ALLOW TTabSheet} - else - TabSheet := nil; - - if TabSheet = nil then begin - // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present - TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); - end else begin - // convert message to unicode, add text - Message.Msg := TCM_SETITEMW; - TCItemA.mask := TCItemA.mask or TCIF_TEXT or RTL[UseRightToLeftReading]; - if TabSheet is TTntTabSheet then - Text := TTntTabSheet(TabSheet).Caption - else - Text := TabSheet.Caption; - TCItemA.pszText := PAnsiChar(PWideChar(Text)); - end; - end; - TCM_INSERTITEMA: - begin - TCItemA := PTCItemA(Message.lParam); - // will always be followed by TCM_SETITEMA(TCIF_PARAM) if TCIF_TEXT is present - TCItemA.mask := TCItemA.mask and (not TCIF_TEXT); - end; - end; - inherited; - end; -end; - -procedure TTntPageControl.CMDialogChar(var Message: TCMDialogChar); -var - I: Integer; - TabText: WideString; -begin - for I := 0 to PageCount - 1 do begin - if Pages[i] is TTntTabSheet then - TabText := TTntTabSheet(Pages[i]).Caption - else - TabText := Pages[i].Caption; - if IsWideCharAccel(Message.CharCode, TabText) and CanShowTab(Pages[i].TabIndex) and CanFocus then - begin - Message.Result := 1; - if CanChange then - begin - TabIndex := Pages[i].TabIndex; - Change; - end; - Exit; - end; - end; - Broadcast(Message); -end; - -procedure TTntPageControl.CMDockClient(var Message: TCMDockClient); -var - IsVisible: Boolean; - DockCtl: TControl; -begin - Message.Result := 0; - FNewDockSheet := TTntTabSheet.Create(Self); - try - try - DockCtl := Message.DockSource.Control; - if DockCtl is TCustomForm then - FNewDockSheet.Caption := TntControl_GetText(DockCtl); - FNewDockSheet.PageControl := Self; - DockCtl.Dock(Self, Message.DockSource.DockRect); - except - FNewDockSheet.Free; - raise; - end; - IsVisible := DockCtl.Visible; - FNewDockSheet.TabVisible := IsVisible; - if IsVisible then ActivePage := FNewDockSheet; - DockCtl.Align := alClient; - finally - FNewDockSheet := nil; - end; -end; - -procedure TTntPageControl.DoAddDockClient(Client: TControl; const ARect: TRect); -begin - if FNewDockSheet <> nil then - Client.Parent := FNewDockSheet; -end; - -procedure TTntPageControl.CMDockNotification(var Message: TCMDockNotification); -var - I: Integer; - S: WideString; - Page: TTabSheet{TNT-ALLOW TTabSheet}; -begin - Page := GetPageFromDockClient(Message.Client); - if (Message.NotifyRec.ClientMsg <> WM_SETTEXT) - or (Page = nil) or (not (Page is TTntTabSheet)) then - inherited - else begin - if (Message.Client is TWinControl) - and (TWinControl(Message.Client).HandleAllocated) - and IsWindowUnicode(TWinControl(Message.Client).Handle) then - S := PWideChar(Message.NotifyRec.MsgLParam) - else - S := PAnsiChar(Message.NotifyRec.MsgLParam); - { Search for first CR/LF and end string there } - for I := 1 to Length(S) do - if S[I] in [CR, LF] then - begin - SetLength(S, I - 1); - Break; - end; - TTntTabSheet(Page).Caption := S; - end; -end; - -procedure TTntPageControl.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntPageControl.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntTrackBar } - -procedure TTntTrackBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, TRACKBAR_CLASS); -end; - -procedure TTntTrackBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntTrackBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntTrackBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntTrackBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntTrackBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntTrackBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntProgressBar } - -procedure TTntProgressBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, PROGRESS_CLASS); -end; - -procedure TTntProgressBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntProgressBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntProgressBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntProgressBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntProgressBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntProgressBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomUpDown } - -procedure TTntCustomUpDown.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, UPDOWN_CLASS); -end; - -procedure TTntCustomUpDown.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomUpDown.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomUpDown.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomUpDown.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomUpDown.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomUpDown.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntDateTimePicker } - -procedure TTntDateTimePicker.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, DATETIMEPICK_CLASS); -end; - -procedure TTntDateTimePicker.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDateTimePicker.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntDateTimePicker.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntDateTimePicker.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntDateTimePicker.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntDateTimePicker.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntDateTimePicker.CreateWnd; -var - SaveChecked: Boolean; -begin - FHadFirstMouseClick := False; - SaveChecked := Checked; - inherited; - // This fixes an issue where TDateTimePicker.CNNotify causes "FChecked := True" to occur - // during window creation. This issue results in .Checked to read True even though - // it is not visually checked. - Checked := SaveChecked; -end; - -procedure TTntDateTimePicker.WMLButtonDown(var Message: TWMLButtonDown); - - procedure UpdateValues; - var - Hdr: TNMDateTimeChange; - begin - Hdr.nmhdr.hwndFrom := Handle; - Hdr.nmhdr.idFrom := 0; - Hdr.nmhdr.code := DTN_DATETIMECHANGE; - Hdr.dwFlags := DateTime_GetSystemTime(Handle, Hdr.st); - if (Hdr.dwFlags <> Cardinal(GDT_ERROR)) then begin - if Hdr.dwFlags = GDT_NONE then - ZeroMemory(@Hdr.st, SizeOf(Hdr.st)); - Perform(CN_NOTIFY, Integer(Handle), Integer(@Hdr)); - end; - end; - -begin - inherited; - if ShowCheckBox and (not FHadFirstMouseClick) then begin - FHadFirstMouseClick := True; - UpdateValues; // Sometimes the first mouse click doesn't result in WM_NOTIFY. - end; -end; - -{ TTntMonthCalendar } - -procedure TTntMonthCalendar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, MONTHCAL_CLASS); - if Win32PlatformIsUnicode then begin - { For some reason WM_NOTIFY:MCN_GETDAYSTATE never gets called. } - ForceGetMonthInfo; - end; -end; - -procedure TTntMonthCalendar.ForceGetMonthInfo; -var - Hdr: TNMDayState; - Days: array of TMonthDayState; - Range: array[1..2] of TSystemTime; -begin - // populate Days array - Hdr.nmhdr.hwndFrom := Handle; - Hdr.nmhdr.idFrom := 0; - Hdr.nmhdr.code := MCN_GETDAYSTATE; - Hdr.cDayState := MonthCal_GetMonthRange(Handle, GMR_DAYSTATE, @Range[1]); - Hdr.stStart := Range[1]; - SetLength(Days, Hdr.cDayState); - Hdr.prgDayState := @Days[0]; - SendMessage(Handle, CN_NOTIFY, Integer(Handle), Integer(@Hdr)); - // update day state - SendMessage(Handle, MCM_SETDAYSTATE, Hdr.cDayState, Longint(Hdr.prgDayState)) -end; - -procedure TTntMonthCalendar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntMonthCalendar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntMonthCalendar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntMonthCalendar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntMonthCalendar.GetDate: TDate; -begin - Result := Trunc(inherited Date); { Fixes issue where Date always reflects time of saving dfm. } -end; - -procedure TTntMonthCalendar.SetDate(const Value: TDate); -begin - inherited Date := Trunc(Value); -end; - -procedure TTntMonthCalendar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntMonthCalendar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntPageScroller } - -procedure TTntPageScroller.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, WC_PAGESCROLLER); -end; - -procedure TTntPageScroller.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntPageScroller.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntPageScroller.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntPageScroller.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntPageScroller.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntPageScroller.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntStatusPanel } - -procedure TTntStatusPanel.Assign(Source: TPersistent); -begin - inherited; - if Source is TTntStatusPanel then - Text := TTntStatusPanel(Source).Text; -end; - -procedure TTntStatusPanel.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntStatusPanel.GetText: Widestring; -begin - Result := GetSyncedWideString(FText, inherited Text); -end; - -procedure TTntStatusPanel.SetInheritedText(const Value: AnsiString); -begin - inherited Text := Value; -end; - -procedure TTntStatusPanel.SetText(const Value: Widestring); -begin - SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); -end; - -{ TTntStatusPanels } - -function TTntStatusPanels.GetItem(Index: Integer): TTntStatusPanel; -begin - Result := (inherited GetItem(Index)) as TTntStatusPanel; -end; - -procedure TTntStatusPanels.SetItem(Index: Integer; Value: TTntStatusPanel); -begin - inherited SetItem(Index, Value); -end; - -function TTntStatusPanels.Add: TTntStatusPanel; -begin - Result := (inherited Add) as TTntStatusPanel; -end; - -function TTntStatusPanels.AddItem(Item: TTntStatusPanel; Index: Integer): TTntStatusPanel; -begin - Result := (inherited AddItem(Item, Index)) as TTntStatusPanel; -end; - -function TTntStatusPanels.Insert(Index: Integer): TTntStatusPanel; -begin - Result := (inherited Insert(Index)) as TTntStatusPanel; -end; - -{ TTntCustomStatusBar } - -function TTntCustomStatusBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomStatusBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntCustomStatusBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomStatusBar.CreatePanels: TStatusPanels{TNT-ALLOW TStatusPanels}; -begin - Result := TTntStatusPanels.Create(Self); -end; - -function TTntCustomStatusBar.GetPanelClass: TStatusPanelClass; -begin - Result := TTntStatusPanel; -end; - -function TTntCustomStatusBar.SyncLeadingTabs(const WideVal: WideString; const AnsiVal: AnsiString): WideString; - - function CountLeadingTabs(const Val: WideString): Integer; - var - i: integer; - begin - Result := 0; - for i := 1 to Length(Val) do begin - if Val[i] <> #9 then break; - Inc(Result); - end; - end; - -var - AnsiTabCount: Integer; - WideTabCount: Integer; -begin - AnsiTabCount := CountLeadingTabs(AnsiVal); - WideTabCount := CountLeadingTabs(WideVal); - Result := WideVal; - while WideTabCount < AnsiTabCount do begin - Insert(#9, Result, 1); - Inc(WideTabCount); - end; - while WideTabCount > AnsiTabCount do begin - Delete(Result, 1, 1); - Dec(WideTabCount); - end; -end; - -function TTntCustomStatusBar.GetSimpleText: WideString; -begin - FSimpleText := SyncLeadingTabs(FSimpleText, inherited SimpleText); - Result := GetSyncedWideString(FSimpleText, inherited SimpleText); -end; - -procedure TTntCustomStatusBar.SetInheritedSimpleText(const Value: AnsiString); -begin - inherited SimpleText := Value; -end; - -procedure TTntCustomStatusBar.SetSimpleText(const Value: WideString); -begin - SetSyncedWideString(Value, FSimpleText, inherited SimpleText, SetInheritedSimpleText); -end; - -procedure TTntCustomStatusBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomStatusBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle_ComCtl(Self, Params, STATUSCLASSNAME); -end; - -procedure TTntCustomStatusBar.WndProc(var Msg: TMessage); -const - SB_SIMPLEID = Integer($FF); -var - iPart: Integer; - szText: PAnsiChar; - WideText: WideString; -begin - if Win32PlatformIsUnicode and (Msg.Msg = SB_SETTEXTA) and ((Msg.WParam and SBT_OWNERDRAW) = 0) - then begin - // convert SB_SETTEXTA message to Unicode - iPart := (Msg.WParam and SB_SIMPLEID); - szText := PAnsiChar(Msg.LParam); - if iPart = SB_SIMPLEID then - WideText := SimpleText - else if Panels.Count > 0 then - WideText := Panels[iPart].Text - else begin - WideText := szText; - end; - WideText := SyncLeadingTabs(WideText, szText); - Msg.Result := SendMessageW(Handle, SB_SETTEXTW, Msg.wParam, Integer(PWideChar(WideText))); - end else - inherited; -end; - -procedure TTntCustomStatusBar.WMGetTextLength(var Message: TWMGetTextLength); -begin - Message.Result := Length(SimpleText); -end; - -procedure TTntCustomStatusBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomStatusBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -function TTntCustomStatusBar.GetPanels: TTntStatusPanels; -begin - Result := inherited Panels as TTntStatusPanels; -end; - -procedure TTntCustomStatusBar.SetPanels(const Value: TTntStatusPanels); -begin - inherited Panels := Value; -end; - -function TTntCustomStatusBar.ExecuteAction(Action: TBasicAction): Boolean; -begin - if AutoHint and (Action is TTntHintAction) and not DoHint then - begin - if SimplePanel or (Panels.Count = 0) then - SimpleText := TTntHintAction(Action).Hint else - Panels[0].Text := TTntHintAction(Action).Hint; - Result := True; - end - else Result := inherited ExecuteAction(Action); -end; - -{ TTntStatusBar } - -function TTntStatusBar.GetOnDrawPanel: TDrawPanelEvent; -begin - Result := TDrawPanelEvent(inherited OnDrawPanel); -end; - -procedure TTntStatusBar.SetOnDrawPanel(const Value: TDrawPanelEvent); -begin - inherited OnDrawPanel := TCustomDrawPanelEvent(Value); -end; - -{ TTntTreeNode } - -function TTntTreeNode.IsEqual(Node: TTntTreeNode): Boolean; -begin - Result := (Text = Node.Text) and (Data = Node.Data); -end; - -procedure TTntTreeNode.ReadData(Stream: TStream; Info: PNodeInfo); -var - I, Size, ItemCount: Integer; - LNode: TTntTreeNode; - Utf8Text: AnsiString; -begin - Owner.ClearCache; - Stream.ReadBuffer(Size, SizeOf(Size)); - Stream.ReadBuffer(Info^, Size); - - if Pos(UTF8_BOM, Info^.Text) = 1 then begin - Utf8Text := Copy(Info^.Text, Length(UTF8_BOM) + 1, MaxInt); - try - Text := UTF8ToWideString(Utf8Text); - except - Text := Utf8Text; - end; - end else - Text := Info^.Text; - - ImageIndex := Info^.ImageIndex; - SelectedIndex := Info^.SelectedIndex; - StateIndex := Info^.StateIndex; - OverlayIndex := Info^.OverlayIndex; - Data := Info^.Data; - ItemCount := Info^.Count; - for I := 0 to ItemCount - 1 do - begin - LNode := Owner.AddChild(Self, ''); - LNode.ReadData(Stream, Info); - Owner.Owner.Added(LNode); - end; -end; - -procedure TTntTreeNode.WriteData(Stream: TStream; Info: PNodeInfo); -var - I, Size, L, ItemCount: Integer; - WideLen: Integer; Utf8Text: AnsiString; -begin - WideLen := 255; - repeat - Utf8Text := UTF8_BOM + WideStringToUTF8(Copy(Text, 1, WideLen)); - L := Length(Utf8Text); - Dec(WideLen); - until - L <= 255; - - Size := SizeOf(TNodeInfo) + L - 255; - Info^.Text := Utf8Text; - Info^.ImageIndex := ImageIndex; - Info^.SelectedIndex := SelectedIndex; - Info^.OverlayIndex := OverlayIndex; - Info^.StateIndex := StateIndex; - Info^.Data := Data; - ItemCount := Count; - Info^.Count := ItemCount; - Stream.WriteBuffer(Size, SizeOf(Size)); - Stream.WriteBuffer(Info^, Size); - for I := 0 to ItemCount - 1 do - Item[I].WriteData(Stream, Info); -end; - -procedure TTntTreeNode.Assign(Source: TPersistent); -var - Node: TTntTreeNode; -begin - inherited; - if (not Deleting) and (Source is TTntTreeNode) then - begin - Node := TTntTreeNode(Source); - Text := Node.Text; - end; -end; - -function TTntTreeNode.GetText: WideString; -begin - Result := GetSyncedWideString(FText, inherited Text); -end; - -procedure TTntTreeNode.SetInheritedText(const Value: AnsiString); -begin - inherited Text := Value; -end; - -procedure TTntTreeNode.SetText(const Value: WideString); -begin - SetSyncedWideString(Value, FText, inherited Text, SetInheritedText); -end; - -function TTntTreeNode.getFirstChild: TTntTreeNode; -begin - Result := inherited getFirstChild as TTntTreeNode; -end; - -function TTntTreeNode.GetItem(Index: Integer): TTntTreeNode; -begin - Result := inherited Item[Index] as TTntTreeNode; -end; - -procedure TTntTreeNode.SetItem(Index: Integer; const Value: TTntTreeNode); -begin - inherited Item[Index] := Value; -end; - -function TTntTreeNode.GetLastChild: TTntTreeNode; -begin - Result := inherited GetLastChild as TTntTreeNode; -end; - -function TTntTreeNode.GetNext: TTntTreeNode; -begin - Result := inherited GetNext as TTntTreeNode; -end; - -function TTntTreeNode.GetNextChild(Value: TTntTreeNode): TTntTreeNode; -begin - Result := inherited GetNextChild(Value) as TTntTreeNode; -end; - -function TTntTreeNode.getNextSibling: TTntTreeNode; -begin - Result := inherited getNextSibling as TTntTreeNode; -end; - -function TTntTreeNode.GetNextVisible: TTntTreeNode; -begin - Result := inherited GetNextVisible as TTntTreeNode; -end; - -function TTntTreeNode.GetNodeOwner: TTntTreeNodes; -begin - Result := inherited Owner as TTntTreeNodes; -end; - -function TTntTreeNode.GetParent: TTntTreeNode; -begin - Result := inherited Parent as TTntTreeNode; -end; - -function TTntTreeNode.GetPrev: TTntTreeNode; -begin - Result := inherited GetPrev as TTntTreeNode; -end; - -function TTntTreeNode.GetPrevChild(Value: TTntTreeNode): TTntTreeNode; -begin - Result := inherited GetPrevChild(Value) as TTntTreeNode; -end; - -function TTntTreeNode.getPrevSibling: TTntTreeNode; -begin - Result := inherited getPrevSibling as TTntTreeNode; -end; - -function TTntTreeNode.GetPrevVisible: TTntTreeNode; -begin - Result := inherited GetPrevVisible as TTntTreeNode; -end; - -function TTntTreeNode.GetTreeView: TTntCustomTreeView; -begin - Result := inherited TreeView as TTntCustomTreeView; -end; - -{ TTntTreeNodesEnumerator } - -constructor TTntTreeNodesEnumerator.Create(ATreeNodes: TTntTreeNodes); -begin - inherited Create; - FIndex := -1; - FTreeNodes := ATreeNodes; -end; - -function TTntTreeNodesEnumerator.GetCurrent: TTntTreeNode; -begin - Result := FTreeNodes[FIndex]; -end; - -function TTntTreeNodesEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FTreeNodes.Count - 1; - if Result then - Inc(FIndex); -end; - -{ TTntTreeNodes } - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackTreeNodes = class(TPersistent) - protected - FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; - FxxxUpdateCount: Integer; - FNodeCache: TNodeCache; - FReading: Boolean; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackTreeNodes = class(TPersistent) - protected - FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; - FxxxUpdateCount: Integer; - FNodeCache: TNodeCache; - FReading: Boolean; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackTreeNodes = class(TPersistent) - protected - FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; - FxxxUpdateCount: Integer; - FNodeCache: TNodeCache; - FReading: Boolean; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackTreeNodes = class(TPersistent) - protected - FxxxOwner: TCustomTreeView{TNT-ALLOW TCustomTreeView}; - FxxxUpdateCount: Integer; - FNodeCache: TNodeCache; - FReading: Boolean; - end; -{$ENDIF} - -procedure SaveNodeTextToStrings(Nodes: TTntTreeNodes; sList: TTntStrings); -var - ANode: TTntTreeNode; -begin - sList.Clear; - if Nodes.Count > 0 then - begin - ANode := Nodes[0]; - while ANode <> nil do - begin - sList.Add(ANode.Text); - ANode := ANode.GetNext; - end; - end; -end; - -procedure TTntTreeNodes.Assign(Source: TPersistent); -var - TreeNodes: TTntTreeNodes; - MemStream: TTntMemoryStream; -begin - ClearCache; - if Source is TTntTreeNodes then - begin - TreeNodes := TTntTreeNodes(Source); - Clear; - MemStream := TTntMemoryStream.Create; - try - TreeNodes.WriteData(MemStream); - MemStream.Position := 0; - ReadData(MemStream); - finally - MemStream.Free; - end; - end else - inherited Assign(Source); -end; - -function TTntTreeNodes.GetNodeFromIndex(Index: Integer): TTntTreeNode; -begin - Result := inherited Item[Index] as TTntTreeNode; -end; - -function TTntTreeNodes.AddChildFirst(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; -begin - Result := AddNode(nil, Parent, S, nil, naAddChildFirst); -end; - -function TTntTreeNodes.AddChildObjectFirst(Parent: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(nil, Parent, S, Ptr, naAddChildFirst); -end; - -function TTntTreeNodes.AddChild(Parent: TTntTreeNode; const S: WideString): TTntTreeNode; -begin - Result := AddNode(nil, Parent, S, nil, naAddChild); -end; - -function TTntTreeNodes.AddChildObject(Parent: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(nil, Parent, S, Ptr, naAddChild); -end; - -function TTntTreeNodes.AddFirst(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, nil, naAddFirst); -end; - -function TTntTreeNodes.AddObjectFirst(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, Ptr, naAddFirst); -end; - -function TTntTreeNodes.Add(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, nil, naAdd); -end; - -function TTntTreeNodes.AddObject(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, Ptr, naAdd); -end; - -function TTntTreeNodes.Insert(Sibling: TTntTreeNode; const S: WideString): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, nil, naInsert); -end; - -function TTntTreeNodes.InsertObject(Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(nil, Sibling, S, Ptr, naInsert); -end; - -function TTntTreeNodes.InsertNode(Node, Sibling: TTntTreeNode; const S: WideString; - Ptr: Pointer): TTntTreeNode; -begin - Result := AddNode(Node, Sibling, S, Ptr, naInsert); -end; - -function TTntTreeNodes.AddNode(Node, Relative: TTntTreeNode; const S: WideString; - Ptr: Pointer; Method: TNodeAttachMode): TTntTreeNode; -begin - Result := inherited AddNode(Node, Relative, '', Ptr, Method) as TTntTreeNode; - Result.Text := S; -end; - -function TTntTreeNodes.GetNode(ItemId: HTreeItem): TTntTreeNode; -begin - Result := inherited GetNode(ItemID) as TTntTreeNode; -end; - -function TTntTreeNodes.GetFirstNode: TTntTreeNode; -begin - Result := inherited GetFirstNode as TTntTreeNode; -end; - -function TTntTreeNodes.GetEnumerator: TTntTreeNodesEnumerator; -begin - Result := TTntTreeNodesEnumerator.Create(Self); -end; - -function TTntTreeNodes.GetNodesOwner: TTntCustomTreeView; -begin - Result := inherited Owner as TTntCustomTreeView; -end; - -procedure TTntTreeNodes.ClearCache; -begin - THackTreeNodes(Self).FNodeCache.CacheNode := nil; -end; - -procedure TTntTreeNodes.DefineProperties(Filer: TFiler); - - function WriteNodes: Boolean; - var - I: Integer; - Nodes: TTntTreeNodes; - begin - Nodes := TTntTreeNodes(Filer.Ancestor); - if Nodes = nil then - Result := Count > 0 - else if Nodes.Count <> Count then - Result := True - else - begin - Result := False; - for I := 0 to Count - 1 do - begin - Result := not Item[I].IsEqual(Nodes[I]); - if Result then - Break; - end - end; - end; - -begin - inherited DefineProperties(Filer); - Filer.DefineBinaryProperty('Utf8Data', ReadData, WriteData, WriteNodes); -end; - -procedure TTntTreeNodes.ReadData(Stream: TStream); -var - I, Count: Integer; - NodeInfo: TNodeInfo; - LNode: TTntTreeNode; - LHandleAllocated: Boolean; -begin - LHandleAllocated := Owner.HandleAllocated; - if LHandleAllocated then - BeginUpdate; - THackTreeNodes(Self).FReading := True; - try - Clear; - Stream.ReadBuffer(Count, SizeOf(Count)); - for I := 0 to Count - 1 do - begin - LNode := Add(nil, ''); - LNode.ReadData(Stream, @NodeInfo); - Owner.Added(LNode); - end; - finally - THackTreeNodes(Self).FReading := False; - if LHandleAllocated then - EndUpdate; - end; -end; - -procedure TTntTreeNodes.WriteData(Stream: TStream); -var - I: Integer; - Node: TTntTreeNode; - NodeInfo: TNodeInfo; -begin - I := 0; - Node := GetFirstNode; - while Node <> nil do - begin - Inc(I); - Node := Node.GetNextSibling; - end; - Stream.WriteBuffer(I, SizeOf(I)); - Node := GetFirstNode; - while Node <> nil do - begin - Node.WriteData(Stream, @NodeInfo); - Node := Node.GetNextSibling; - end; -end; - -{ TTntTreeStrings } - -type - TTntTreeStrings = class(TTntStringList) - protected - function GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; - public - procedure SaveToTree(Tree: TTntCustomTreeView); - procedure LoadFromTree(Tree: TTntCustomTreeView); - end; - -function TTntTreeStrings.GetBufStart(Buffer: PWideChar; var Level: Integer): PWideChar; -begin - Level := 0; - while Buffer^ in [WideChar(' '), WideChar(#9)] do - begin - Inc(Buffer); - Inc(Level); - end; - Result := Buffer; -end; - -procedure TTntTreeStrings.SaveToTree(Tree: TTntCustomTreeView); -var - ANode, NextNode: TTntTreeNode; - ALevel, i: Integer; - CurrStr: WideString; - Owner: TTntTreeNodes; -begin - Owner := Tree.Items; - Owner.BeginUpdate; - try - try - Owner.Clear; - ANode := nil; - for i := 0 to Count - 1 do - begin - CurrStr := GetBufStart(PWideChar(Strings[i]), ALevel); - if ANode = nil then - ANode := Owner.AddChild(nil, CurrStr) - else if ANode.Level = ALevel then - ANode := Owner.AddChild(ANode.Parent, CurrStr) - else if ANode.Level = (ALevel - 1) then - ANode := Owner.AddChild(ANode, CurrStr) - else if ANode.Level > ALevel then - begin - NextNode := ANode.Parent; - while NextNode.Level > ALevel do - NextNode := NextNode.Parent; - ANode := Owner.AddChild(NextNode.Parent, CurrStr); - end - else - raise ETreeViewError.CreateFmt(sInvalidLevelEx, [ALevel, CurrStr]); - end; - finally - Owner.EndUpdate; - end; - except - Owner.Owner.Invalidate; // force repaint on exception - raise; - end; -end; - -procedure TTntTreeStrings.LoadFromTree(Tree: TTntCustomTreeView); -const - TabChar = #9; -var - i: Integer; - ANode: TTntTreeNode; - NodeStr: WideString; - Owner: TTntTreeNodes; -begin - Clear; - Owner := Tree.Items; - if Owner.Count > 0 then - begin - ANode := Owner[0]; - while ANode <> nil do - begin - NodeStr := ''; - for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar; - NodeStr := NodeStr + ANode.Text; - Add(NodeStr); - ANode := ANode.GetNext; - end; - end; -end; - -{ _TntInternalCustomTreeView } - -function _TntInternalCustomTreeView.FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; -begin - Result := Wide_FindNextToSelect; -end; - -function _TntInternalCustomTreeView.Inherited_FindNextToSelect: TTreeNode{TNT-ALLOW TTreeNode}; -begin - Result := inherited FindNextToSelect; -end; - -{ TTntCustomTreeView } - -function TntDefaultTreeViewSort(Node1, Node2: TTntTreeNode; lParam: Integer): Integer; stdcall; -begin - with Node1 do - if Assigned(TreeView.OnCompare) then - TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result) - else Result := lstrcmpw(PWideChar(Node1.Text), PWideChar(Node2.Text)); -end; - -constructor TTntCustomTreeView.Create(AOwner: TComponent); -begin - inherited; - FEditInstance := Classes.MakeObjectInstance(EditWndProcW); -end; - -destructor TTntCustomTreeView.Destroy; -begin - Destroying; - Classes.FreeObjectInstance(FEditInstance); - FreeAndNil(FSavedNodeText); - inherited; -end; - -var - ComCtrls_DefaultTreeViewSort: TTVCompare = nil; - -procedure TTntCustomTreeView.CreateWindowHandle(const Params: TCreateParams); - - procedure Capture_ComCtrls_DefaultTreeViewSort; - begin - FTestingForSortProc := True; - try - AlphaSort; - finally - FTestingForSortProc := False; - end; - end; - -begin - CreateUnicodeHandle_ComCtl(Self, Params, WC_TREEVIEW); - if (Win32PlatformIsUnicode) then begin - if not Assigned(ComCtrls_DefaultTreeViewSort) then - Capture_ComCtrls_DefaultTreeViewSort; - end; -end; - -procedure TTntCustomTreeView.CreateWnd; -begin - inherited; - if FSavedNodeText <> nil then begin - FreeAndNil(FSavedNodeText); - SortType := FSavedSortType; - end; -end; - -procedure TTntCustomTreeView.DestroyWnd; -begin - if (not (csDestroying in ComponentState)) then begin - FSavedNodeText := TTntStringList.Create; - FSavedSortType := SortType; - SortType := stNone; // when recreating window, we are expecting items to come back in same order - SaveNodeTextToStrings(Items, FSavedNodeText); - end; - inherited; -end; - -procedure TTntCustomTreeView.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomTreeView.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomTreeView.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomTreeView.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomTreeView.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomTreeView.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -function TTntCustomTreeView.CreateNode: TTreeNode{TNT-ALLOW TTreeNode}; -var - LClass: TClass; - TntLClass: TTntTreeNodeClass; -begin - LClass := TTntTreeNode; - if Assigned(OnCreateNodeClass) then - OnCreateNodeClass(Self, TTreeNodeClass(LClass)); - if not LClass.InheritsFrom(TTntTreeNode) then - raise ETntInternalError.Create('Internal Error: OnCreateNodeClass.ItemClass must inherit from TTntTreeNode.'); - TntLClass := TTntTreeNodeClass(LClass); - Result := TntLClass.Create(inherited Items); -end; - -function TTntCustomTreeView.CreateNodes: TTreeNodes{TNT-ALLOW TTreeNodes}; -begin - Result := TTntTreeNodes.Create(Self); -end; - -function TTntCustomTreeView.GetTreeNodes: TTntTreeNodes; -begin - Result := inherited Items as TTntTreeNodes; -end; - -procedure TTntCustomTreeView.SetTreeNodes(const Value: TTntTreeNodes); -begin - Items.Assign(Value); -end; - -function TTntCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTntTreeNode; -begin - Result := nil; - if Items <> nil then - with Item do - if (state and TVIF_PARAM) <> 0 then - Result := Pointer(lParam) - else - Result := Items.GetNode(hItem); -end; - -function TTntCustomTreeView.Wide_FindNextToSelect: TTntTreeNode; -begin - Result := FindNextToSelect; -end; - -function TTntCustomTreeView.FindNextToSelect: TTntTreeNode; -begin - Result := Inherited_FindNextToSelect as TTntTreeNode; -end; - -function TTntCustomTreeView.GetDropTarget: TTntTreeNode; -begin - Result := inherited DropTarget as TTntTreeNode; -end; - -function TTntCustomTreeView.GetNodeAt(X, Y: Integer): TTntTreeNode; -begin - Result := inherited GetNodeAt(X, Y) as TTntTreeNode; -end; - -function TTntCustomTreeView.GetSelected: TTntTreeNode; -begin - Result := inherited Selected as TTntTreeNode; -end; - -function TTntCustomTreeView.GetSelection(Index: Integer): TTntTreeNode; -begin - Result := inherited Selections[Index] as TTntTreeNode; -end; - -function TTntCustomTreeView.GetSelections(AList: TList): TTntTreeNode; -begin - Result := inherited GetSelections(AList) as TTntTreeNode; -end; - -function TTntCustomTreeView.GetTopItem: TTntTreeNode; -begin - Result := inherited TopItem as TTntTreeNode; -end; - -procedure TTntCustomTreeView.SetDropTarget(const Value: TTntTreeNode); -begin - inherited DropTarget := Value; -end; - -procedure TTntCustomTreeView.SetSelected(const Value: TTntTreeNode); -begin - inherited Selected := Value; -end; - -procedure TTntCustomTreeView.SetTopItem(const Value: TTntTreeNode); -begin - inherited TopItem := Value; -end; - -procedure TTntCustomTreeView.WndProc(var Message: TMessage); -type - PTVSortCB = ^TTVSortCB; -begin - with Message do begin - // capture ANSI version of DefaultTreeViewSort from ComCtrls - if (FTestingForSortProc) - and (Msg = TVM_SORTCHILDRENCB) then begin - ComCtrls_DefaultTreeViewSort := PTVSortCB(lParam).lpfnCompare; - exit; - end; - - if (Win32PlatformIsUnicode) - and (Msg = TVM_SORTCHILDRENCB) - and (@PTVSortCB(lParam).lpfnCompare = @ComCtrls_DefaultTreeViewSort) then - begin - // Unicode:: call wide version of sort proc instead - PTVSortCB(lParam)^.lpfnCompare := TTVCompare(@TntDefaultTreeViewSort); - Result := SendMessageW(Handle, TVM_SORTCHILDRENCB, wParam, lParam); - end else - inherited; - end; -end; - -procedure TTntCustomTreeView.CNNotify(var Message: TWMNotify); -var - Node: TTntTreeNode; -begin - if (not Win32PlatformIsUnicode) then - inherited - else begin - with Message do begin - case NMHdr^.code of - TVN_BEGINDRAGW: - begin - NMHdr^.code := TVN_BEGINDRAGA; - try - inherited; - finally - NMHdr^.code := TVN_BEGINDRAGW; - end; - end; - TVN_BEGINLABELEDITW: - begin - with PTVDispInfo(NMHdr)^ do - if Dragging or not CanEdit(GetNodeFromItem(item)) then - Result := 1; - if Result = 0 then - begin - FEditHandle := TreeView_GetEditControl(Handle); - FDefEditProc := Pointer(GetWindowLongW(FEditHandle, GWL_WNDPROC)); - SetWindowLongW(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance)); - end; - end; - TVN_ENDLABELEDITW: - Edit(PTVDispInfo(NMHdr)^.item); - TVN_ITEMEXPANDINGW: - begin - NMHdr^.code := TVN_ITEMEXPANDINGA; - try - inherited; - finally - NMHdr^.code := TVN_ITEMEXPANDINGW; - end; - end; - TVN_ITEMEXPANDEDW: - begin - NMHdr^.code := TVN_ITEMEXPANDEDA; - try - inherited; - finally - NMHdr^.code := TVN_ITEMEXPANDEDW; - end; - end; - TVN_DELETEITEMW: - begin - NMHdr^.code := TVN_DELETEITEMA; - try - inherited; - finally - NMHdr^.code := TVN_DELETEITEMW; - end; - end; - TVN_SETDISPINFOW: - with PTVDispInfo(NMHdr)^ do - begin - Node := GetNodeFromItem(item); - if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then - Node.Text := TTVItemW(item).pszText; - end; - TVN_GETDISPINFOW: - with PTVDispInfo(NMHdr)^ do - begin - Node := GetNodeFromItem(item); - if Node <> nil then - begin - if (item.mask and TVIF_TEXT) <> 0 then begin - if (FSavedNodeText <> nil) - and (FSavedNodeText.Count > 0) - and (AnsiString(FSavedNodeText[0]) = AnsiString(Node.Text)) then - begin - Node.FText := FSavedNodeText[0]; // recover saved text - FSavedNodeText.Delete(0); - end; - WStrLCopy(TTVItemW(item).pszText, PWideChar(Node.Text), item.cchTextMax - 1); - end; - - if (item.mask and TVIF_IMAGE) <> 0 then - begin - GetImageIndex(Node); - item.iImage := Node.ImageIndex; - end; - if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then - begin - GetSelectedIndex(Node); - item.iSelectedImage := Node.SelectedIndex; - end; - end; - end; - else - inherited; - end; - end; - end; -end; - -procedure TTntCustomTreeView.WMNotify(var Message: TWMNotify); -var - Node: TTntTreeNode; - FWideText: WideString; - MaxTextLen: Integer; - Pt: TPoint; -begin - with Message do - if NMHdr^.code = TTN_NEEDTEXTW then - begin - // Work around NT COMCTL32 problem with tool tips >= 80 characters - GetCursorPos(Pt); - Pt := ScreenToClient(Pt); - Node := GetNodeAt(Pt.X, Pt.Y); - if (Node = nil) or (Node.Text = '') or - (PToolTipTextW(NMHdr)^.uFlags and TTF_IDISHWND = 0) then Exit; - if (GetComCtlVersion >= ComCtlVersionIE4) - or {Borland's VCL wrongly uses "and"} (Length(Node.Text) < 80) then - begin - DefaultHandler(Message); - Exit; - end; - FWideText := Node.Text; - MaxTextLen := SizeOf(PToolTipTextW(NMHdr)^.szText) div SizeOf(WideChar); - if Length(FWideText) >= MaxTextLen then - SetLength(FWideText, MaxTextLen - 1); - PToolTipTextW(NMHdr)^.lpszText := PWideChar(FWideText); - FillChar(PToolTipTextW(NMHdr)^.szText, MaxTextLen, 0); - Move(Pointer(FWideText)^, PToolTipTextW(NMHdr)^.szText, Length(FWideText) * SizeOf(WideChar)); - PToolTipTextW(NMHdr)^.hInst := 0; - SetWindowPos(NMHdr^.hwndFrom, HWND_TOP, 0, 0, 0, 0, SWP_NOACTIVATE or - SWP_NOSIZE or SWP_NOMOVE or SWP_NOOWNERZORDER); - Result := 1; - end - else inherited; -end; - -procedure TTntCustomTreeView.Edit(const Item: TTVItem); -var - S: WideString; - AnsiS: AnsiString; - Node: TTntTreeNode; - AnsiEvent: TTVEditedEvent; -begin - with Item do - begin - Node := GetNodeFromItem(Item); - if pszText <> nil then - begin - if Win32PlatformIsUnicode then - S := TTVItemW(Item).pszText - else - S := pszText; - - if Assigned(FOnEdited) then - FOnEdited(Self, Node, S) - else if Assigned(inherited OnEdited) then - begin - AnsiEvent := inherited OnEdited; - AnsiS := S; - AnsiEvent(Self, Node, AnsiS); - S := AnsiS; - end; - - if Node <> nil then Node.Text := S; - end - else if Assigned(OnCancelEdit) then - OnCancelEdit(Self, Node); - end; -end; - -procedure TTntCustomTreeView.EditWndProcW(var Message: TMessage); -begin - Assert(Win32PlatformIsUnicode); - try - with Message do - begin - case Msg of - WM_KEYDOWN, - WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit; - WM_CHAR: - begin - MakeWMCharMsgSafeForAnsi(Message); - try - if DoKeyPress(TWMKey(Message)) then Exit; - finally - RestoreWMCharMsg(Message); - end; - end; - WM_KEYUP, - WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit; - CN_KEYDOWN, - CN_CHAR, CN_SYSKEYDOWN, - CN_SYSCHAR: - begin - WndProc(Message); - Exit; - end; - end; - Result := CallWindowProcW(FDefEditProc, FEditHandle, Msg, WParam, LParam); - end; - except - Application.HandleException(Self); - end; -end; - -procedure TTntCustomTreeView.LoadFromFile(const FileName: WideString); -var - TreeStrings: TTntTreeStrings; -begin - TreeStrings := TTntTreeStrings.Create; - try - TreeStrings.LoadFromFile(FileName); - TreeStrings.SaveToTree(Self); - finally - TreeStrings.Free; - end; -end; - -procedure TTntCustomTreeView.LoadFromStream(Stream: TStream); -var - TreeStrings: TTntTreeStrings; -begin - TreeStrings := TTntTreeStrings.Create; - try - TreeStrings.LoadFromStream(Stream); - TreeStrings.SaveToTree(Self); - finally - TreeStrings.Free; - end; -end; - -procedure TTntCustomTreeView.SaveToFile(const FileName: WideString); -var - TreeStrings: TTntTreeStrings; -begin - TreeStrings := TTntTreeStrings.Create; - try - TreeStrings.LoadFromTree(Self); - TreeStrings.SaveToFile(FileName); - finally - TreeStrings.Free; - end; -end; - -procedure TTntCustomTreeView.SaveToStream(Stream: TStream); -var - TreeStrings: TTntTreeStrings; -begin - TreeStrings := TTntTreeStrings.Create; - try - TreeStrings.LoadFromTree(Self); - TreeStrings.SaveToStream(Stream); - finally - TreeStrings.Free; - end; -end; - -initialization - -finalization - if Assigned(AIMM) then - AIMM.Deactivate; - if FRichEdit20Module <> 0 then - FreeLibrary(FRichEdit20Module); - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc deleted file mode 100644 index 5ab13901ba..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc +++ /dev/null @@ -1,356 +0,0 @@ -//---------------------------------------------------------------------------------------------------------------------- -// Include file to determine which compiler is currently being used to build the project/component. -// This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). -// -// Portions created by Mike Lischke are Copyright -// (C) 1999-2002 Dipl. Ing. Mike Lischke. All Rights Reserved. -//---------------------------------------------------------------------------------------------------------------------- -// The following symbols are defined: -// -// COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. -// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. -// COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. -// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. -// COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. -// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. -// COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. -// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. -// COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. -// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. -// COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. -// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. -// COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. -// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. -// -// Only defined if Windows is the target: -// CPPB : Any version of BCB is being used. -// CPPB_1 : BCB v1.x is being used. -// CPPB_3 : BCB v3.x is being used. -// CPPB_3_UP : BCB v3.x or higher is being used. -// CPPB_4 : BCB v4.x is being used. -// CPPB_4_UP : BCB v4.x or higher is being used. -// CPPB_5 : BCB v5.x is being used. -// CPPB_5_UP : BCB v5.x or higher is being used. -// CPPB_6 : BCB v6.x is being used. -// CPPB_6_UP : BCB v6.x or higher is being used. -// -// Only defined if Windows is the target: -// DELPHI : Any version of Delphi is being used. -// DELPHI_1 : Delphi v1.x is being used. -// DELPHI_2 : Delphi v2.x is being used. -// DELPHI_2_UP : Delphi v2.x or higher is being used. -// DELPHI_3 : Delphi v3.x is being used. -// DELPHI_3_UP : Delphi v3.x or higher is being used. -// DELPHI_4 : Delphi v4.x is being used. -// DELPHI_4_UP : Delphi v4.x or higher is being used. -// DELPHI_5 : Delphi v5.x is being used. -// DELPHI_5_UP : Delphi v5.x or higher is being used. -// DELPHI_6 : Delphi v6.x is being used. -// DELPHI_6_UP : Delphi v6.x or higher is being used. -// DELPHI_7 : Delphi v7.x is being used. -// DELPHI_7_UP : Delphi v7.x or higher is being used. -// -// Only defined if Linux is the target: -// KYLIX : Any version of Kylix is being used. -// KYLIX_1 : Kylix 1.x is being used. -// KYLIX_1_UP : Kylix 1.x or higher is being used. -// KYLIX_2 : Kylix 2.x is being used. -// KYLIX_2_UP : Kylix 2.x or higher is being used. -// KYLIX_3 : Kylix 3.x is being used. -// KYLIX_3_UP : Kylix 3.x or higher is being used. -// -// Only defined if Linux is the target: -// QT_CLX : Trolltech's QT library is being used. -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef Win32} - - {$ifdef VER180} - {$define COMPILER_10} - {$define DELPHI} - {$define DELPHI_10} - {$endif} - - {$ifdef VER170} - {$define COMPILER_9} - {$define DELPHI} - {$define DELPHI_9} - {$endif} - - {$ifdef VER150} - {$define COMPILER_7} - {$define DELPHI} - {$define DELPHI_7} - {$endif} - - {$ifdef VER140} - {$define COMPILER_6} - {$ifdef BCB} - {$define CPPB} - {$define CPPB_6} - {$else} - {$define DELPHI} - {$define DELPHI_6} - {$endif} - {$endif} - - {$ifdef VER130} - {$define COMPILER_5} - {$ifdef BCB} - {$define CPPB} - {$define CPPB_5} - {$else} - {$define DELPHI} - {$define DELPHI_5} - {$endif} - {$endif} - - {$ifdef VER125} - {$define COMPILER_4} - {$define CPPB} - {$define CPPB_4} - {$endif} - - {$ifdef VER120} - {$define COMPILER_4} - {$define DELPHI} - {$define DELPHI_4} - {$endif} - - {$ifdef VER110} - {$define COMPILER_3} - {$define CPPB} - {$define CPPB_3} - {$endif} - - {$ifdef VER100} - {$define COMPILER_3} - {$define DELPHI} - {$define DELPHI_3} - {$endif} - - {$ifdef VER93} - {$define COMPILER_2} // C++ Builder v1 compiler is really v2 - {$define CPPB} - {$define CPPB_1} - {$endif} - - {$ifdef VER90} - {$define COMPILER_2} - {$define DELPHI} - {$define DELPHI_2} - {$endif} - - {$ifdef VER80} - {$define COMPILER_1} - {$define DELPHI} - {$define DELPHI_1} - {$endif} - - {$ifdef DELPHI_2} - {$define DELPHI_2_UP} - {$endif} - - {$ifdef DELPHI_3} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$endif} - - {$ifdef DELPHI_4} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$endif} - - {$ifdef DELPHI_5} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$endif} - - {$ifdef DELPHI_6} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$endif} - - {$ifdef DELPHI_7} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$endif} - - {$ifdef DELPHI_9} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$define DELPHI_9_UP} - {$endif} - - {$ifdef DELPHI_10} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$define DELPHI_9_UP} - {$define DELPHI_10_UP} - {$endif} - - {$ifdef CPPB_3} - {$define CPPB_3_UP} - {$endif} - - {$ifdef CPPB_4} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$endif} - - {$ifdef CPPB_5} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$define CPPB_5_UP} - {$endif} - - {$ifdef CPPB_6} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$define CPPB_5_UP} - {$define CPPB_6_UP} - {$endif} - - {$ifdef CPPB_3_UP} - // C++ Builder requires this if you use Delphi components in run-time packages. - {$ObjExportAll On} - {$endif} - -{$else (not Windows)} - // Linux is the target - {$define QT_CLX} - - {$define KYLIX} - {$define KYLIX_1} - {$define KYLIX_1_UP} - - {$ifdef VER150} - {$define COMPILER_7} - {$define KYLIX_3} - {$endif} - - {$ifdef VER140} - {$define COMPILER_6} - {$define KYLIX_2} - {$endif} - - {$ifdef KYLIX_2} - {$define KYLIX_2_UP} - {$endif} - - {$ifdef KYLIX_3} - {$define KYLIX_2_UP} - {$define KYLIX_3_UP} - {$endif} - -{$endif} - -// Compiler defines common to all platforms. -{$ifdef COMPILER_1} - {$define COMPILER_1_UP} -{$endif} - -{$ifdef COMPILER_2} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} -{$endif} - -{$ifdef COMPILER_3} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} -{$endif} - -{$ifdef COMPILER_4} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} -{$endif} - -{$ifdef COMPILER_5} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} -{$endif} - -{$ifdef COMPILER_6} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} -{$endif} - -{$ifdef COMPILER_7} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} -{$endif} - -{$ifdef COMPILER_9} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} - {$define COMPILER_9_UP} -{$endif} - -{$ifdef COMPILER_10} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} - {$define COMPILER_9_UP} - {$define COMPILER_10_UP} -{$endif} - -//---------------------------------------------------------------------------------------------------------------------- - -{$ALIGN ON} -{$BOOLEVAL OFF} - -{$ifdef COMPILER_7_UP} - {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } -{$endif} - -{$IFDEF COMPILER_6_UP} -{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } -{$ENDIF} - -{$IFDEF COMPILER_7_UP} -{$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } -{$WARN UNSAFE_TYPE OFF} -{$WARN UNSAFE_CAST OFF} -{$ENDIF} \ No newline at end of file diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas deleted file mode 100644 index 55025ecdc2..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas +++ /dev/null @@ -1,1099 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntControls; - -{$INCLUDE TntCompilers.inc} - -{ - Windows NT provides support for native Unicode windows. To add Unicode support to a - TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle(). - - One major reason this works is because the VCL only uses the ANSI version of - SendMessage() -- SendMessageA(). If you call SendMessageA() on a UNICODE - window, Windows deals with the ANSI/UNICODE conversion automatically. So - for example, if the VCL sends WM_SETTEXT to a window using SendMessageA, - Windows actually *expects* a PAnsiChar even if the target window is a UNICODE - window. So caling SendMessageA with PChars causes no problems. - - A problem in the VCL has to do with the TControl.Perform() method. Perform() - calls the window procedure directly and assumes an ANSI window. This is a - problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a - PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar. - - This is the reason for SubClassUnicodeControl(). This procedure will subclass the - Windows WndProc, and the TWinControl.WindowProc pointer. It will determine if the - message came from Windows or if the WindowProc was called directly. It will then - call SendMessageA() for Windows to perform proper conversion on certain text messages. - - Another problem has to do with TWinControl.DoKeyPress(). It is called from the WM_CHAR - message. It casts the WideChar to an AnsiChar, and sends the resulting character to - DefWindowProc. In order to avoid this, the DefWindowProc is subclassed as well. WindowProc - will make a WM_CHAR message safe for ANSI handling code by converting the char code to - #FF before passing it on. It stores the original WideChar in the .Unused field of TWMChar. - The code #FF is converted back to the WideChar before passing onto DefWindowProc. -} - -{ - Things to consider when designing new controls: - 1) Check that a WideString Hint property is published. - 2) If descending from TWinControl, override CreateWindowHandle(). - 3) If not descending from TWinControl, handle CM_HINTSHOW message. - 4) Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly. - 5) If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd. - 6) Consider using storage specifiers for Hint and Caption properties. - 7) If any class could possibly have published WideString properties, - override DefineProperties and call TntPersistent_AfterInherited_DefineProperties. - 8) Check if TTntThemeManager needs to be updated. - 9) Override GetActionLinkClass() and ActionChange(). - 10) If class updates Application.Hint then update TntApplication.Hint instead. -} - -interface - -{ TODO: Unicode enable .OnKeyPress event } - -uses - Classes, Windows, Messages, Controls, Menus; - - -{TNT-WARN TCaption} -type TWideCaption = type WideString; - -// caption/text management -function TntControl_IsCaptionStored(Control: TControl): Boolean; -function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; -procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); -function TntControl_GetText(Control: TControl): WideString; -procedure TntControl_SetText(Control: TControl; const Text: WideString); - -// hint management -function TntControl_IsHintStored(Control: TControl): Boolean; -function TntControl_GetHint(Control: TControl): WideString; -procedure TntControl_SetHint(Control: TControl; const Value: WideString); - -function WideGetHint(Control: TControl): WideString; -function WideGetShortHint(const Hint: WideString): WideString; -function WideGetLongHint(const Hint: WideString): WideString; -procedure ProcessCMHintShowMsg(var Message: TMessage); - -type - TTntCustomHintWindow = class(THintWindow) - private - FActivating: Boolean; - FBlockPaint: Boolean; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; -{$IFNDEF COMPILER_7_UP} - procedure CreateParams(var Params: TCreateParams); override; -{$ENDIF} - procedure Paint; override; - public - procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override; - procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override; - function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override; - property Caption: TWideCaption read GetCaption write SetCaption; - end; - - TTntHintWindow = class(TTntCustomHintWindow) - public - procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce; - procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce; - function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce; - end; - -// text/char message -function IsTextMessage(Msg: UINT): Boolean; -procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); -procedure RestoreWMCharMsg(var Message: TMessage); -function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; -procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); - -// register/create window -procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); -procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); -procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; - const SubClass: WideString; IDEWindow: Boolean = False); -procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); - -type - IWideCustomListControl = interface - ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}'] - procedure AddItem(const Item: WideString; AObject: TObject); - end; - -procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); - -var - _IsShellProgramming: Boolean = False; - -var - TNT_WM_DESTROY: Cardinal; - -implementation - -uses - ActnList, Forms, SysUtils, Contnrs, - TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils; - -type - TAccessControl = class(TControl); - TAccessWinControl = class(TWinControl); - TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}); - -//----------------------------------------------- WIDE CAPTION HOLDERS -------- - -{ TWideControlHelper } - -var - WideControlHelpers: TComponentList = nil; - -type - TWideControlHelper = class(TWideComponentHelper) - private - FControl: TControl; - FWideCaption: WideString; - FWideHint: WideString; - procedure SetAnsiText(const Value: AnsiString); - procedure SetAnsiHint(const Value: AnsiString); - public - constructor Create(AOwner: TControl); reintroduce; - property WideCaption: WideString read FWideCaption; - property WideHint: WideString read FWideHint; - end; - -constructor TWideControlHelper.Create(AOwner: TControl); -begin - inherited CreateHelper(AOwner, WideControlHelpers); - FControl := AOwner; -end; - -procedure TWideControlHelper.SetAnsiText(const Value: AnsiString); -begin - TAccessControl(FControl).Text := Value; -end; - -procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString); -begin - FControl.Hint := Value; -end; - -function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper; -begin - Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control)); - if (Result = nil) and CreateIfNotFound then - Result := TWideControlHelper.Create(Control); -end; - -//----------------------------------------------- GET/SET WINDOW CAPTION/HINT ------------- - -function TntControl_IsCaptionStored(Control: TControl): Boolean; -begin - with TAccessControl(Control) do - Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked; -end; - -function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; -var - WideControlHelper: TWideControlHelper; -begin - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper <> nil then - Result := WideControlHelper.WideCaption - else - Result := Default; -end; - -procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); -begin - FindWideControlHelper(Control).FWideCaption := Value; - TAccessControl(Control).Text := Value; -end; - -function TntControl_GetText(Control: TControl): WideString; -var - WideControlHelper: TWideControlHelper; -begin - if (not Win32PlatformIsUnicode) - or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then - // Win9x / non-unicode handle - Result := TAccessControl(Control).Text - else if (not (Control is TWinControl)) then begin - // non-windowed TControl - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper = nil then - Result := TAccessControl(Control).Text - else - Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text); - end else if (not TWinControl(Control).HandleAllocated) then begin - // NO HANDLE - Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text) - end else begin - // UNICODE & HANDLE - SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1); - GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result)); - SetLength(Result, Length(Result) - 1); - end; -end; - -procedure TntControl_SetText(Control: TControl; const Text: WideString); -begin - if (not Win32PlatformIsUnicode) - or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then - // Win9x / non-unicode handle - TAccessControl(Control).Text := Text - else if (not (Control is TWinControl)) then begin - // non-windowed TControl - with FindWideControlHelper(Control) do - SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText) - end else if (not TWinControl(Control).HandleAllocated) then begin - // NO HANDLE - TntControl_SetStoredText(Control, Text); - end else if TntControl_GetText(Control) <> Text then begin - // UNICODE & HANDLE - Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text)); - Control.Perform(CM_TEXTCHANGED, 0, 0); - end; -end; - -// hint management ----------------------------------------------------------------------- - -function TntControl_IsHintStored(Control: TControl): Boolean; -begin - with TAccessControl(Control) do - Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked; -end; - -function TntControl_GetHint(Control: TControl): WideString; -var - WideControlHelper: TWideControlHelper; -begin - if (not Win32PlatformIsUnicode) then - Result := Control.Hint - else begin - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper <> nil then - Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint) - else - Result := Control.Hint; - end; -end; - -procedure TntControl_SetHint(Control: TControl; const Value: WideString); -begin - if (not Win32PlatformIsUnicode) then - Control.Hint := Value - else - with FindWideControlHelper(Control) do - SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint); -end; - -function WideGetHint(Control: TControl): WideString; -begin - while Control <> nil do - if TntControl_GetHint(Control) = '' then - Control := Control.Parent - else - begin - Result := TntControl_GetHint(Control); - Exit; - end; - Result := ''; -end; - -function WideGetShortHint(const Hint: WideString): WideString; -var - I: Integer; -begin - I := Pos('|', Hint); - if I = 0 then - Result := Hint else - Result := Copy(Hint, 1, I - 1); -end; - -function WideGetLongHint(const Hint: WideString): WideString; -var - I: Integer; -begin - I := Pos('|', Hint); - if I = 0 then - Result := Hint else - Result := Copy(Hint, I + 1, Maxint); -end; - -//---------------------------------------------------------------------------------------- - -var UnicodeCreationControl: TWinControl = nil; - -function IsUnicodeCreationControl(Handle: HWND): Boolean; -begin - Result := (UnicodeCreationControl <> nil) - and (UnicodeCreationControl.HandleAllocated) - and (UnicodeCreationControl.Handle = Handle); -end; - -function WMNotifyFormatResult(FromHandle: HWND): Integer; -begin - if Win32PlatformIsUnicode - and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then - Result := NFR_UNICODE - else - Result := NFR_ANSI; -end; - -function IsTextMessage(Msg: UINT): Boolean; -begin - // WM_CHAR is omitted because of the special handling it receives - Result := (Msg = WM_SETTEXT) - or (Msg = WM_GETTEXT) - or (Msg = WM_GETTEXTLENGTH); -end; - -const - ANSI_UNICODE_HOLDER = $FF; - -procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); -begin - with TWMChar(Message) do begin - Assert(Msg = WM_CHAR); - if not _IsShellProgramming then - Assert(Unused = 0) - else begin - Assert((Unused = 0) or (CharCode <= Word(High(AnsiChar)))); - // When a Unicode control is embedded under non-Delphi Unicode - // window something strange happens - if (Unused <> 0) then begin - CharCode := (Unused shl 8) or CharCode; - end; - end; - if (CharCode > Word(High(AnsiChar))) then begin - Unused := CharCode; - CharCode := ANSI_UNICODE_HOLDER; - end; - end; -end; - -procedure RestoreWMCharMsg(var Message: TMessage); -begin - with TWMChar(Message) do begin - Assert(Message.Msg = WM_CHAR); - if (Unused > 0) - and (CharCode = ANSI_UNICODE_HOLDER) then - CharCode := Unused; - Unused := 0; - end; -end; - -function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; -begin - if (Message.CharCode = ANSI_UNICODE_HOLDER) - and (Message.Unused <> 0) then - Result := WideChar(Message.Unused) - else - Result := WideChar(Message.CharCode); -end; - -procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); -begin - Message.CharCode := Word(Ch); - Message.Unused := 0; - MakeWMCharMsgSafeForAnsi(TMessage(Message)); -end; - -//----------------------------------------------------------------------------------- -type - TWinControlTrap = class(TComponent) - private - WinControl_ObjectInstance: Pointer; - ObjectInstance: Pointer; - DefObjectInstance: Pointer; - function IsInSubclassChain(Control: TWinControl): Boolean; - procedure SubClassWindowProc; - private - FControl: TAccessWinControl; - Handle: THandle; - PrevWin32Proc: Pointer; - PrevDefWin32Proc: Pointer; - PrevWindowProc: TWndMethod; - private - LastWin32Msg: UINT; - Win32ProcLevel: Integer; - IDEWindow: Boolean; - DestroyTrap: Boolean; - TestForNull: Boolean; - FoundNull: Boolean; - {$IFDEF TNT_VERIFY_WINDOWPROC} - LastVerifiedWindowProc: TWndMethod; - {$ENDIF} - procedure Win32Proc(var Message: TMessage); - procedure DefWin32Proc(var Message: TMessage); - procedure WindowProc(var Message: TMessage); - private - procedure SubClassControl(Params_Caption: PAnsiChar); - procedure UnSubClassUnicodeControl; - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - end; - -constructor TWinControlTrap.Create(AOwner: TComponent); -begin - FControl := TAccessWinControl(AOwner as TWinControl); - inherited Create(nil); - FControl.FreeNotification(Self); - - WinControl_ObjectInstance := Classes.MakeObjectInstance(FControl.MainWndProc); - ObjectInstance := Classes.MakeObjectInstance(Win32Proc); - DefObjectInstance := Classes.MakeObjectInstance(DefWin32Proc); -end; - -destructor TWinControlTrap.Destroy; -begin - Classes.FreeObjectInstance(ObjectInstance); - Classes.FreeObjectInstance(DefObjectInstance); - Classes.FreeObjectInstance(WinControl_ObjectInstance); - inherited; -end; - -procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (AComponent = FControl) and (Operation = opRemove) then begin - FControl := nil; - if Win32ProcLevel = 0 then - Free - else - DestroyTrap := True; - end; -end; - -procedure TWinControlTrap.SubClassWindowProc; -begin - if not IsInSubclassChain(FControl) then begin - PrevWindowProc := FControl.WindowProc; - FControl.WindowProc := Self.WindowProc; - end; - {$IFDEF TNT_VERIFY_WINDOWPROC} - LastVerifiedWindowProc := FControl.WindowProc; - {$ENDIF} -end; - -procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar); -begin - // initialize trap object - Handle := FControl.Handle; - PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC)); - PrevDefWin32Proc := FControl.DefWndProc; - - // subclass Window Procedures - SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance)); - FControl.DefWndProc := DefObjectInstance; - SubClassWindowProc; - - // For some reason, caption gets garbled after calling SetWindowLongW(.., GWL_WNDPROC). - TntControl_SetText(FControl, TntControl_GetStoredText(FControl, Params_Caption)); -end; - -function SameWndMethod(A, B: TWndMethod): Boolean; -begin - Result := @A = @B; -end; - -var - PendingRecreateWndTrapList: TComponentList = nil; - -procedure TWinControlTrap.UnSubClassUnicodeControl; -begin - // remember caption for future window creation - if not (csDestroying in FControl.ComponentState) then - TntControl_SetStoredText(FControl, TntControl_GetText(FControl)); - - // restore window procs (restore WindowProc only if we are still the direct subclass) - if SameWndMethod(FControl.WindowProc, Self.WindowProc) then - FControl.WindowProc := PrevWindowProc; - TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc; - SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc)); - - if IDEWindow then - DestroyTrap := True - else if not (csDestroying in FControl.ComponentState) then - // control not being destroyed, probably recreating window - PendingRecreateWndTrapList.Add(Self); -end; - -var - Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak. - Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. } - -procedure TWinControlTrap.Win32Proc(var Message: TMessage); -begin - if (not Finalized) then begin - Inc(Win32ProcLevel); - try - with Message do begin - {$IFDEF TNT_VERIFY_WINDOWPROC} - if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin - SubClassWindowProc; - LastVerifiedWindowProc := FControl.WindowProc; - end; - {$ENDIF} - LastWin32Msg := Msg; - Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam); - end; - finally - Dec(Win32ProcLevel); - end; - if (Win32ProcLevel = 0) and (DestroyTrap) then - Free; - end else if (Message.Msg = WM_DESTROY) or (Message.Msg = TNT_WM_DESTROY) then - FControl.WindowHandle := 0 -end; - -procedure TWinControlTrap.DefWin32Proc(var Message: TMessage); - - function IsChildEdit(AHandle: HWND): Boolean; - var - AHandleClass: WideString; - begin - Result := False; - if (FControl.Handle = GetParent(Handle)) then begin - // child control - SetLength(AHandleClass, 255); - SetLength(AHandleClass, GetClassNameW(AHandle, PWideChar(AHandleClass), Length(AHandleClass))); - Result := WideSameText(AHandleClass, 'EDIT'); - end; - end; - -begin - with Message do begin - if Msg = WM_NOTIFYFORMAT then - Result := WMNotifyFormatResult(HWND(Message.wParam)) - else begin - if (Msg = WM_CHAR) then begin - RestoreWMCharMsg(Message) - end; - if (Msg = WM_IME_CHAR) and (not _IsShellProgramming) and (not Win32PlatformIsXP) then - begin - { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. } - { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. } - { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. } - Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam) - end else if (Msg = WM_IME_CHAR) and (_IsShellProgramming) then begin - { When a Tnt control is hosted by a non-delphi control, DefWindowProc doesn't always work even on XP. } - if IsChildEdit(Handle) then - Message.Result := Integer(PostMessageW(Handle, WM_CHAR, wParam, lParam)) // native edit child control - else - Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam); - end else begin - if (Msg = WM_DESTROY) then begin - UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } - end; - { Normal DefWindowProc } - Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam); - end; - end; - end; -end; - -procedure ProcessCMHintShowMsg(var Message: TMessage); -begin - if Win32PlatformIsUnicode then begin - with TCMHintShow(Message) do begin - if (HintInfo.HintWindowClass = THintWindow) - or (HintInfo.HintWindowClass.InheritsFrom(TTntCustomHintWindow)) then begin - if (HintInfo.HintWindowClass = THintWindow) then - HintInfo.HintWindowClass := TTntCustomHintWindow; - HintInfo.HintData := HintInfo; - HintInfo.HintStr := WideGetShortHint(WideGetHint(HintInfo.HintControl)); - end; - end; - end; -end; - -function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean; -var - Message: TMessage; -begin - if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then - Result := False { no subclassing } - else if SameWndMethod(Control.WindowProc, Self.WindowProc) then - Result := True { directly subclassed } - else begin - TestForNull := True; - FoundNull := False; - ZeroMemory(@Message, SizeOf(Message)); - Message.Msg := WM_NULL; - Control.WindowProc(Message); - Result := FoundNull; { indirectly subclassed } - end; -end; - -procedure TWinControlTrap.WindowProc(var Message: TMessage); -var - CameFromWindows: Boolean; -begin - if TestForNull and (Message.Msg = WM_NULL) then - FoundNull := True; - - if (not FControl.HandleAllocated) then - FControl.WndProc(Message) - else begin - CameFromWindows := LastWin32Msg <> WM_NULL; - LastWin32Msg := WM_NULL; - with Message do begin - if Msg = CM_HINTSHOW then - ProcessCMHintShowMsg(Message); - if (not CameFromWindows) - and (IsTextMessage(Msg)) then - Result := SendMessageA(Handle, Msg, wParam, lParam) - else begin - if (Msg = WM_CHAR) then begin - MakeWMCharMsgSafeForAnsi(Message); - end; - PrevWindowProc(Message) - end; - if (Msg = TNT_WM_DESTROY) then - UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } - end; - end; -end; - -//---------------------------------------------------------------------------------- - -function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap; -var - i: integer; -begin - // find or create trap object - Result := nil; - for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin - if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin - Result := TWinControlTrap(PendingRecreateWndTrapList[i]); - PendingRecreateWndTrapList.Delete(i); - break; { found it } - end; - end; - if Result = nil then - Result := TWinControlTrap.Create(Control); -end; - -procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); -var - WinControlTrap: TWinControlTrap; -begin - if not IsWindowUnicode(Control.Handle) then - raise ETntInternalError.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.'); - - WinControlTrap := FindOrCreateWinControlTrap(Control); - WinControlTrap.SubClassControl(Params_Caption); - WinControlTrap.IDEWindow := IDEWindow; -end; - - -//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE - -var - WindowAtom: TAtom; - ControlAtom: TAtom; - WindowAtomString: AnsiString; - ControlAtomString: AnsiString; - -type - TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; - -function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; - - function GetObjectInstance(Control: TWinControl): Pointer; - var - WinControlTrap: TWinControlTrap; - begin - WinControlTrap := FindOrCreateWinControlTrap(Control); - PendingRecreateWndTrapList.Add(WinControlTrap); - Result := WinControlTrap.WinControl_ObjectInstance; - end; - -var - ObjectInstance: Pointer; -begin - TAccessWinControl(CreationControl).WindowHandle := HWindow; - ObjectInstance := GetObjectInstance(CreationControl); - {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!} - SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance)); - if (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0) - and (GetWindowLongW(HWindow, GWL_ID) = 0) then - SetWindowLongW(HWindow, GWL_ID, Integer(HWindow)); - SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl)); - SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl)); - CreationControl := nil; - Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam); -end; - -procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); -const - UNICODE_CLASS_EXT = '.UnicodeClass'; -var - TempClass: TWndClassW; - WideClass: TWndClassW; - ClassRegistered: Boolean; - InitialProc: TFNWndProc; -begin - if IDEWindow then - InitialProc := @InitWndProc - else - InitialProc := @InitWndProcW; - - with Params do begin - WideWinClassName := WinClassName + UNICODE_CLASS_EXT; - ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass); - if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc) - then begin - if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance)); - // Prepare a TWndClassW record - WideClass := TWndClassW(WindowClass); - WideClass.hInstance := hInstance; - WideClass.lpfnWndProc := InitialProc; - if not Tnt_Is_IntResource(PWideChar(WindowClass.lpszMenuName)) then begin - WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName)); - end; - WideClass.lpszClassName := PWideChar(WideWinClassName); - - // Register the UNICODE class - if RegisterClassW(WideClass) = 0 then RaiseLastOSError; - end; - end; -end; - -procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; - const SubClass: WideString; IDEWindow: Boolean = False); -var - TempSubClass: TWndClassW; - WideWinClassName: WideString; - Handle: THandle; -begin - if (not Win32PlatformIsUnicode) then begin - with Params do - TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName, - Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); - end else begin - // SubClass the unicode version of this control by getting the correct DefWndProc - if (SubClass <> '') - and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then - TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc - else - TAccessWinControl(Control).DefWndProc := @DefWindowProcW; - - // make sure Unicode window class is registered - RegisterUnicodeClass(Params, WideWinClassName, IDEWindow); - - // Create UNICODE window handle - UnicodeCreationControl := Control; - try - with Params do - Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil, - Style, X, Y, Width, Height, WndParent, 0, hInstance, Param); - if Handle = 0 then - RaiseLastOSError; - TAccessWinControl(Control).WindowHandle := Handle; - if IDEWindow then - SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC)); - finally - UnicodeCreationControl := nil; - end; - - SubClassUnicodeControl(Control, Params.Caption, IDEWindow); - end; -end; - -procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); -var - WasFocused: Boolean; - Params: TCreateParams; -begin - with TAccessWinControl(Control) do begin - WasFocused := Focused; - DestroyHandle; - CreateParams(Params); - CreationControl := Control; - CreateUnicodeHandle(Control, Params, SubClass, IDEWindow); - StrDispose{TNT-ALLOW StrDispose}(WindowText); - WindowText := nil; - Perform(WM_SETFONT, Integer(Font.Handle), 1); - if AutoSize then AdjustSize; - UpdateControlState; - if WasFocused and (WindowHandle <> 0) then Windows.SetFocus(WindowHandle); - end; -end; - -{ TTntCustomHintWindow procs } - -function DataPointsToHintInfoForTnt(AData: Pointer): Boolean; -begin - try - Result := (AData <> nil) - and (PHintInfo(AData).HintData = AData) {points to self} - and (PHintInfo(AData).HintWindowClass.InheritsFrom(TTntCustomHintWindow)); - except - Result := False; - end; -end; - -function ExtractTntHintCaption(AData: Pointer): WideString; -var - Control: TControl; - WideHint: WideString; - AnsiHintWithShortCut: AnsiString; - ShortCut: TShortCut; -begin - Result := PHintInfo(AData).HintStr; - if Result <> '' then begin - Control := PHintInfo(AData).HintControl; - WideHint := WideGetShortHint(WideGetHint(Control)); - if (AnsiString(WideHint) = PHintInfo(AData).HintStr) then - Result := WideHint - else if Application.HintShortCuts and (Control <> nil) - and (Control.Action is TCustomAction{TNT-ALLOW TCustomAction}) then begin - ShortCut := TCustomAction{TNT-ALLOW TCustomAction}(Control.Action).ShortCut; - if (ShortCut <> scNone) then - begin - AnsiHintWithShortCut := Format{TNT-ALLOW Format}('%s (%s)', [WideHint, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)]); - if AnsiHintWithShortCut = PHintInfo(AData).HintStr then - Result := WideFormat('%s (%s)', [WideHint, WideShortCutToText(ShortCut)]); - end; - end; - end; -end; - -{ TTntCustomHintWindow } - -procedure TTntCustomHintWindow.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -{$IFNDEF COMPILER_7_UP} -procedure TTntCustomHintWindow.CreateParams(var Params: TCreateParams); -const - CS_DROPSHADOW = $00020000; -begin - inherited; - if Win32PlatformIsXP then { Enable drop shadow effect on Windows XP and later. } - Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; -end; -{$ENDIF} - -function TTntCustomHintWindow.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomHintWindow.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomHintWindow.Paint; -var - R: TRect; -begin - if FBlockPaint then - exit; - if (not Win32PlatformIsUnicode) then - inherited - else begin - R := ClientRect; - Inc(R.Left, 2); - Inc(R.Top, 2); - Canvas.Font.Color := Screen.HintFont.Color; - Tnt_DrawTextW(Canvas.Handle, PWideChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or - DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); - end; -end; - -procedure TTntCustomHintWindow.CMTextChanged(var Message: TMessage); -begin - { Avoid flicker when calling ActivateHint } - if FActivating then Exit; - Width := WideCanvasTextWidth(Canvas, Caption) + 6; - Height := WideCanvasTextHeight(Canvas, Caption) + 6; -end; - -procedure TTntCustomHintWindow.ActivateHint(Rect: TRect; const AHint: AnsiString); -var - SaveActivating: Boolean; -begin - SaveActivating := FActivating; - try - FActivating := True; - inherited; - finally - FActivating := SaveActivating; - end; -end; - -procedure TTntCustomHintWindow.ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); -var - SaveActivating: Boolean; -begin - if (not Win32PlatformIsUnicode) - or (not DataPointsToHintInfoForTnt(AData)) then - inherited - else begin - FBlockPaint := True; - try - SaveActivating := FActivating; - try - FActivating := True; - inherited; - Caption := ExtractTntHintCaption(AData); - finally - FActivating := SaveActivating; - end; - finally - FBlockPaint := False; - end; - Invalidate; - end; -end; - -function TntHintWindow_CalcHintRect(HintWindow: TTntCustomHintWindow; MaxWidth: Integer; const AHint: WideString): TRect; -begin - Result := Rect(0, 0, MaxWidth, 0); - Tnt_DrawTextW(HintWindow.Canvas.Handle, PWideChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or - DT_WORDBREAK or DT_NOPREFIX or HintWindow.DrawTextBiDiModeFlagsReadingOnly); - Inc(Result.Right, 6); - Inc(Result.Bottom, 2); -end; - -function TTntCustomHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; -var - WideHintStr: WideString; -begin - if (not Win32PlatformIsUnicode) - or (not DataPointsToHintInfoForTnt(AData)) then - Result := inherited CalcHintRect(MaxWidth, AHint, AData) - else begin - WideHintStr := ExtractTntHintCaption(AData); - Result := TntHintWindow_CalcHintRect(Self, MaxWidth, WideHintStr); - end; -end; - -{ TTntHintWindow } - -procedure TTntHintWindow.ActivateHint(Rect: TRect; const AHint: WideString); -var - SaveActivating: Boolean; -begin - SaveActivating := FActivating; - try - FActivating := True; - Caption := AHint; - inherited ActivateHint(Rect, AHint); - finally - FActivating := SaveActivating; - end; -end; - -procedure TTntHintWindow.ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); -var - SaveActivating: Boolean; -begin - FBlockPaint := True; - try - SaveActivating := FActivating; - try - FActivating := True; - Caption := AHint; - inherited ActivateHintData(Rect, AHint, AData); - finally - FActivating := SaveActivating; - end; - finally - FBlockPaint := False; - end; - Invalidate; -end; - -function TTntHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; -begin - Result := TntHintWindow_CalcHintRect(Self, MaxWidth, AHint); -end; - -procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); -var - WideControl: IWideCustomListControl; -begin - if Control.GetInterface(IWideCustomListControl, WideControl) then - WideControl.AddItem(Item, AObject) - else - Control.AddItem(Item, AObject); -end; - -procedure InitControls; - - procedure InitAtomStrings_D6_D7_D9; - var - Controls_HInstance: Cardinal; - begin - Controls_HInstance := FindClassHInstance(TWinControl); - WindowAtomString := Format{TNT-ALLOW Format}('Delphi%.8X',[GetCurrentProcessID]); - ControlAtomString := Format{TNT-ALLOW Format}('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]); - end; - - {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - -begin - InitAtomStrings; - WindowAtom := WinCheckH(GlobalAddAtom(PAnsiChar(WindowAtomString))); - ControlAtom := WinCheckH(GlobalAddAtom(PAnsiChar(ControlAtomString))); -end; - -initialization - TNT_WM_DESTROY := RegisterWindowMessage('TntUnicodeVcl.DestroyWindow'); - WideControlHelpers := TComponentList.Create(True); - PendingRecreateWndTrapList := TComponentList.Create(False); - InitControls; - -finalization - GlobalDeleteAtom(ControlAtom); - GlobalDeleteAtom(WindowAtom); - FreeAndNil(WideControlHelpers); - FreeAndNil(PendingRecreateWndTrapList); - Finalized := True; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas deleted file mode 100644 index 4490bd12e2..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas +++ /dev/null @@ -1,900 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDB; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, DB; - -type -{TNT-WARN TDateTimeField} - TTntDateTimeField = class(TDateTimeField{TNT-ALLOW TDateTimeField}) - protected - procedure SetAsString(const Value: AnsiString); override; - end; - -{TNT-WARN TDateField} - TTntDateField = class(TDateField{TNT-ALLOW TDateField}) - protected - procedure SetAsString(const Value: AnsiString); override; - end; - -{TNT-WARN TTimeField} - TTntTimeField = class(TTimeField{TNT-ALLOW TTimeField}) - protected - procedure SetAsString(const Value: AnsiString); override; - end; - - TFieldGetWideTextEvent = procedure(Sender: TField; var Text: WideString; - DoDisplayText: Boolean) of object; - TFieldSetWideTextEvent = procedure(Sender: TField; const Text: WideString) of object; - - IWideStringField = interface - ['{679C5F1A-4356-4696-A8F3-9C7C6970A9F6}'] - {$IFNDEF COMPILER_10_UP} - function GetAsWideString: WideString; - procedure SetAsWideString(const Value: WideString); - {$ENDIF} - function GetWideDisplayText: WideString; - function GetWideEditText: WideString; - procedure SetWideEditText(const Value: WideString); - //-- - {$IFNDEF COMPILER_10_UP} - property AsWideString: WideString read GetAsWideString write SetAsWideString{inherited}; - {$ENDIF} - property WideDisplayText: WideString read GetWideDisplayText; - property WideText: WideString read GetWideEditText write SetWideEditText; - end; - -{TNT-WARN TWideStringField} - TTntWideStringField = class(TWideStringField{TNT-ALLOW TWideStringField}, IWideStringField) - private - FOnGetText: TFieldGetWideTextEvent; - FOnSetText: TFieldSetWideTextEvent; - procedure SetOnGetText(const Value: TFieldGetWideTextEvent); - procedure SetOnSetText(const Value: TFieldSetWideTextEvent); - procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); - procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); - function GetWideDisplayText: WideString; - function GetWideEditText: WideString; - procedure SetWideEditText(const Value: WideString); - protected - {$IFNDEF COMPILER_10_UP} - function GetAsWideString: WideString; - {$ENDIF} - public - property Value: WideString read GetAsWideString write SetAsWideString; - property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; - property Text: WideString read GetWideEditText write SetWideEditText; - {$IFNDEF COMPILER_10_UP} - property AsWideString: WideString read GetAsWideString write SetAsWideString; - {$ENDIF} - property WideDisplayText: WideString read GetWideDisplayText; - property WideText: WideString read GetWideEditText write SetWideEditText; - published - property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; - property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; - end; - - TTntStringFieldEncodingMode = (emNone, emUTF8, emUTF7, emFixedCodePage, emFixedCodePage_Safe); - - //------------------------------------------------------------------------------------------- - // Comments on TTntStringFieldEncodingMode: - // - // emNone - Works like TStringField. - // emUTF8 - Should work well most databases. - // emUTF7 - Almost guaranteed to work with any database. Wasteful in database space. - // emFixedCodePage - Only tested it with Access 97, which doesn't support Unicode. - // emFixedCodePage_Safe - Like emFixedCodePage but uses char<=#128. Wasteful in database space. - // - // Only emUTF8 and emUTF7 fully support Unicode. - //------------------------------------------------------------------------------------------- - - TTntStringFieldCodePageEnum = (fcpOther, - fcpThai, fcpJapanese, fcpSimplifiedChinese, fcpTraditionalChinese, fcpKorean, - fcpCentralEuropean, fcpCyrillic, fcpLatinWestern, fcpGreek, fcpTurkish, - fcpHebrew, fcpArabic, fcpBaltic, fcpVietnamese); - -const - TntStringFieldCodePageEnumMap: array[TTntStringFieldCodePageEnum] of Word = (0, - 874, 932, 936, 950, 949, - 1250, 1251, 1252, 1253, 1254, - 1255, 1256, 1257, 1258); - -type -{TNT-WARN TStringField} - TTntStringField = class(TStringField{TNT-ALLOW TStringField},IWideStringField) - private - FOnGetText: TFieldGetWideTextEvent; - FOnSetText: TFieldSetWideTextEvent; - FEncodingMode: TTntStringFieldEncodingMode; - FFixedCodePage: Word; - FRawVariantAccess: Boolean; - procedure SetOnGetText(const Value: TFieldGetWideTextEvent); - procedure SetOnSetText(const Value: TFieldSetWideTextEvent); - procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); - procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); - function GetWideDisplayText: WideString; - function GetWideEditText: WideString; - procedure SetWideEditText(const Value: WideString); - function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; - procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); - function IsFixedCodePageStored: Boolean; - protected - {$IFDEF COMPILER_10_UP} - function GetAsWideString: WideString; override; - procedure SetAsWideString(const Value: WideString); override; - {$ELSE} - function GetAsWideString: WideString; virtual; - procedure SetAsWideString(const Value: WideString); virtual; - {$ENDIF} - function GetAsVariant: Variant; override; - procedure SetVarValue(const Value: Variant); override; - function GetAsString: string{TNT-ALLOW string}; override; - procedure SetAsString(const Value: string{TNT-ALLOW string}); override; - public - constructor Create(AOwner: TComponent); override; - property Value: WideString read GetAsWideString write SetAsWideString; - property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; - property Text: WideString read GetWideEditText write SetWideEditText; - {$IFNDEF COMPILER_10_UP} - property AsWideString: WideString read GetAsWideString write SetAsWideString; - {$ENDIF} - property WideDisplayText: WideString read GetWideDisplayText; - property WideText: WideString read GetWideEditText write SetWideEditText; - published - property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; - property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; - property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; - property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; - property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; - property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; - end; - -//====================== -type -{TNT-WARN TMemoField} - TTntMemoField = class(TMemoField{TNT-ALLOW TMemoField}, IWideStringField) - private - FOnGetText: TFieldGetWideTextEvent; - FOnSetText: TFieldSetWideTextEvent; - FEncodingMode: TTntStringFieldEncodingMode; - FFixedCodePage: Word; - FRawVariantAccess: Boolean; - procedure SetOnGetText(const Value: TFieldGetWideTextEvent); - procedure SetOnSetText(const Value: TFieldSetWideTextEvent); - procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); - procedure LegacySetText(Sender: TField; const AnsiText: AnsiString); - function GetWideDisplayText: WideString; - function GetWideEditText: WideString; - procedure SetWideEditText(const Value: WideString); - function GetFixedCodePageEnum: TTntStringFieldCodePageEnum; - procedure SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); - function IsFixedCodePageStored: Boolean; - protected - {$IFDEF COMPILER_10_UP} - function GetAsWideString: WideString; override; - procedure SetAsWideString(const Value: WideString); override; - {$ELSE} - function GetAsWideString: WideString; virtual; - procedure SetAsWideString(const Value: WideString); virtual; - {$ENDIF} - function GetAsVariant: Variant; override; - procedure SetVarValue(const Value: Variant); override; - function GetAsString: string{TNT-ALLOW string}; override; - procedure SetAsString(const Value: string{TNT-ALLOW string}); override; - public - constructor Create(AOwner: TComponent); override; - property Value: WideString read GetAsWideString write SetAsWideString; - property DisplayText{TNT-ALLOW DisplayText}: WideString read GetWideDisplayText; - property Text: WideString read GetWideEditText write SetWideEditText; - {$IFNDEF COMPILER_10_UP} - property AsWideString: WideString read GetAsWideString write SetAsWideString; - {$ENDIF} - property WideDisplayText: WideString read GetWideDisplayText; - property WideText: WideString read GetWideEditText write SetWideEditText; - published - property EncodingMode: TTntStringFieldEncodingMode read FEncodingMode write FEncodingMode default emUTF8; - property FixedCodePageEnum: TTntStringFieldCodePageEnum read GetFixedCodePageEnum write SetFixedCodePageEnum stored False; - property FixedCodePage: Word read FFixedCodePage write FFixedCodePage stored IsFixedCodePageStored; - property RawVariantAccess: Boolean read FRawVariantAccess write FRawVariantAccess default False; - property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText; - property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText; - end; - -//====================== -function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; - -function GetWideDisplayName(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer -function GetWideDisplayLabel(Field: TField): WideString; deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer -procedure SetWideDisplayLabel(Field: TField; const Value: WideString); deprecated; // for Unicode-enabled functionality, use Delphi 2006 or newer - -{TNT-WARN AsString} -{TNT-WARN DisplayText} - -function GetAsWideString(Field: TField): WideString; -procedure SetAsWideString(Field: TField; const Value: WideString); - -function GetWideDisplayText(Field: TField): WideString; - -function GetWideText(Field: TField): WideString; -procedure SetWideText(Field: TField; const Value: WideString); - -procedure RegisterTntFields; - -{ TTntWideStringField / TTntStringField common handlers } -procedure TntWideStringField_GetWideText(Field: TField; - var Text: WideString; DoDisplayText: Boolean); -function TntWideStringField_GetWideDisplayText(Field: TField; - OnGetText: TFieldGetWideTextEvent): WideString; -function TntWideStringField_GetWideEditText(Field: TField; - OnGetText: TFieldGetWideTextEvent): WideString; -procedure TntWideStringField_SetWideText(Field: TField; - const Value: WideString); -procedure TntWideStringField_SetWideEditText(Field: TField; - OnSetText: TFieldSetWideTextEvent; const Value: WideString); - - -implementation - -uses - SysUtils, MaskUtils, Variants, Contnrs, TntSystem, TntSysUtils; - -function GetTntFieldClass(FieldClass: TFieldClass): TFieldClass; -begin - if FieldClass = TDateTimeField{TNT-ALLOW TDateTimeField} then - Result := TTntDateTimeField - else if FieldClass = TDateField{TNT-ALLOW TDateField} then - Result := TTntDateField - else if FieldClass = TTimeField{TNT-ALLOW TTimeField} then - Result := TTntTimeField - else if FieldClass = TWideStringField{TNT-ALLOW TWideStringField} then - Result := TTntWideStringField - else if FieldClass = TStringField{TNT-ALLOW TStringField} then - Result := TTntStringField - else - Result := FieldClass; -end; - -function GetWideDisplayName(Field: TField): WideString; -begin - Result := Field.DisplayName; -end; - -function GetWideDisplayLabel(Field: TField): WideString; -begin - Result := Field.DisplayLabel; -end; - -procedure SetWideDisplayLabel(Field: TField; const Value: WideString); -begin - Field.DisplayLabel := Value; -end; - -function GetAsWideString(Field: TField): WideString; -{$IFDEF COMPILER_10_UP} -begin - if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then - Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } - else - Result := Field.AsWideString -end; -{$ELSE} -var - WideField: IWideStringField; -begin - if Field.GetInterface(IWideStringField, WideField) then - Result := WideField.AsWideString - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then - begin - if Field.IsNull then - // This fixes a bug in TWideStringField.GetAsWideString which does not handle Null at all. - Result := '' - else - Result := TWideStringField{TNT-ALLOW TWideStringField}(Field).Value - end else if (Field is TMemoField{TNT-ALLOW TMemoField}) then - Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide } - else - Result := Field.AsString{TNT-ALLOW AsString}; -end; -{$ENDIF} - -procedure SetAsWideString(Field: TField; const Value: WideString); -{$IFDEF COMPILER_10_UP} -begin - if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then - Field.AsVariant := Value { works for NexusDB BLOB Wide } - else - Field.AsWideString := Value; -end; -{$ELSE} -var - WideField: IWideStringField; -begin - if Field.GetInterface(IWideStringField, WideField) then - WideField.AsWideString := Value - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then - TWideStringField{TNT-ALLOW TWideStringField}(Field).Value := Value - else if (Field is TMemoField{TNT-ALLOW TMemoField}) then - Field.AsVariant := Value { works for NexusDB BLOB Wide } - else - Field.AsString{TNT-ALLOW AsString} := Value; -end; -{$ENDIF} - -function GetWideDisplayText(Field: TField): WideString; -var - WideField: IWideStringField; -begin - if Field.GetInterface(IWideStringField, WideField) then - Result := WideField.WideDisplayText - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) - and (not Assigned(Field.OnGetText)) then - Result := GetAsWideString(Field) - else - Result := Field.DisplayText{TNT-ALLOW DisplayText}; -end; - -function GetWideText(Field: TField): WideString; -var - WideField: IWideStringField; -begin - if Field.GetInterface(IWideStringField, WideField) then - Result := WideField.WideText - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) - and (not Assigned(Field.OnGetText)) then - Result := GetAsWideString(Field) - else - Result := Field.Text; -end; - -procedure SetWideText(Field: TField; const Value: WideString); -var - WideField: IWideStringField; -begin - if Field.GetInterface(IWideStringField, WideField) then - WideField.WideText := Value - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) - and (not Assigned(Field.OnSetText)) then - SetAsWideString(Field, Value) - else - Field.Text := Value -end; - -{ TTntDateTimeField } - -procedure TTntDateTimeField.SetAsString(const Value: AnsiString); -begin - if Value = '' then - inherited - else - SetAsDateTime(TntStrToDateTime(Value)); -end; - -{ TTntDateField } - -procedure TTntDateField.SetAsString(const Value: AnsiString); -begin - if Value = '' then - inherited - else - SetAsDateTime(TntStrToDate(Value)); -end; - -{ TTntTimeField } - -procedure TTntTimeField.SetAsString(const Value: AnsiString); -begin - if Value = '' then - inherited - else - SetAsDateTime(TntStrToTime(Value)); -end; - -{ TTntWideStringField / TTntStringField common handlers } - -procedure TntWideStringField_LegacyGetText(Sender: TField; OnGetText: TFieldGetWideTextEvent; - var AnsiText: AnsiString; DoDisplayText: Boolean); -var - WideText: WideString; -begin - if Assigned(OnGetText) then begin - WideText := AnsiText; - OnGetText(Sender, WideText, DoDisplayText); - AnsiText := WideText; - end; -end; - -procedure TntWideStringField_LegacySetText(Sender: TField; OnSetText: TFieldSetWideTextEvent; - const AnsiText: AnsiString); -begin - if Assigned(OnSetText) then - OnSetText(Sender, AnsiText); -end; - -procedure TntWideStringField_GetWideText(Field: TField; - var Text: WideString; DoDisplayText: Boolean); -var - WideStringField: IWideStringField; -begin - Field.GetInterface(IWideStringField, WideStringField); - Assert(WideStringField <> nil); - if DoDisplayText and (Field.EditMaskPtr <> '') then - { to gain the mask, we lose Unicode! } - Text := FormatMaskText(Field.EditMaskPtr, GetAsWideString(Field)) - else - Text := GetAsWideString(Field); -end; - -function TntWideStringField_GetWideDisplayText(Field: TField; - OnGetText: TFieldGetWideTextEvent): WideString; -begin - Result := ''; - if Assigned(OnGetText) then - OnGetText(Field, Result, True) - else if Assigned(Field.OnGetText) then - Result := Field.DisplayText{TNT-ALLOW DisplayText} {we lose Unicode to handle this event} - else - TntWideStringField_GetWideText(Field, Result, True); -end; - -function TntWideStringField_GetWideEditText(Field: TField; - OnGetText: TFieldGetWideTextEvent): WideString; -begin - Result := ''; - if Assigned(OnGetText) then - OnGetText(Field, Result, False) - else if Assigned(Field.OnGetText) then - Result := Field.Text {we lose Unicode to handle this event} - else - TntWideStringField_GetWideText(Field, Result, False); -end; - -procedure TntWideStringField_SetWideText(Field: TField; - const Value: WideString); -{$IFDEF COMPILER_10_UP} -begin - Field.AsWideString := Value; -end; -{$ELSE} -var - WideStringField: IWideStringField; -begin - Field.GetInterface(IWideStringField, WideStringField); - Assert(WideStringField <> nil); - WideStringField.SetAsWideString(Value); -end; -{$ENDIF} - -procedure TntWideStringField_SetWideEditText(Field: TField; - OnSetText: TFieldSetWideTextEvent; const Value: WideString); -begin - if Assigned(OnSetText) then - OnSetText(Field, Value) - else if Assigned(Field.OnSetText) then - Field.Text := Value {we lose Unicode to handle this event} - else - TntWideStringField_SetWideText(Field, Value); -end; - -{ TTntWideStringField } - -{$IFNDEF COMPILER_10_UP} -function TTntWideStringField.GetAsWideString: WideString; -begin - if not GetData(@Result, False) then - Result := ''; {fixes a bug in inherited which has unpredictable results for NULL} -end; -{$ENDIF} - -procedure TTntWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; - DoDisplayText: Boolean); -begin - TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); -end; - -procedure TTntWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); -begin - TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); -end; - -procedure TTntWideStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); -begin - FOnGetText := Value; - if Assigned(OnGetText) then - inherited OnGetText := LegacyGetText - else - inherited OnGetText := nil; -end; - -procedure TTntWideStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); -begin - FOnSetText := Value; - if Assigned(OnSetText) then - inherited OnSetText := LegacySetText - else - inherited OnSetText := nil; -end; - -function TTntWideStringField.GetWideDisplayText: WideString; -begin - Result := TntWideStringField_GetWideDisplayText(Self, OnGetText); -end; - -function TTntWideStringField.GetWideEditText: WideString; -begin - Result := TntWideStringField_GetWideEditText(Self, OnGetText); -end; - -procedure TTntWideStringField.SetWideEditText(const Value: WideString); -begin - TntWideStringField_SetWideEditText(Self, OnSetText, Value); -end; - -(* This stuffing method works with CJK codepages - intended to store accented characters in Access 97 *) - -function SafeStringToWideStringEx(const S: AnsiString; Codepage: Word): WideString; -var - R: AnsiString; - i: Integer; -begin - R := ''; - i := 1; - while i <= Length(S) do - begin - if (S[i] = #128) then - begin - Inc(i); - if S[i] = #128 then - R := R + #128 - else - R := R + Chr(Ord(S[i]) + 128); - Inc(i); - end - else - begin - R := R + S[I]; - Inc(i); - end; - end; - Result := StringToWideStringEx(R, CodePage); -end; - -function SafeWideStringToStringEx(const W: WideString; CodePage: Word): AnsiString; -var - TempS: AnsiString; - i: integer; -begin - TempS := WideStringToStringEx(W, CodePage); - Result := ''; - for i := 1 to Length(TempS) do - begin - if TempS[i] > #128 then - Result := Result + #128 + Chr(Ord(TempS[i]) - 128) - else if TempS[i] = #128 then - Result := Result + #128 + #128 - else - Result := Result + TempS[i]; - end; -end; - -{ TTntStringField } - -constructor TTntStringField.Create(AOwner: TComponent); -begin - inherited; - FEncodingMode := emUTF8; - FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] -end; - -function TTntStringField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; -var - i: TTntStringFieldCodePageEnum; -begin - Result := fcpOther; - for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin - if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin - Result := i; - Break; {found it} - end; - end; -end; - -procedure TTntStringField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); -begin - if (Value <> fcpOther) then - FixedCodePage := TntStringFieldCodePageEnumMap[Value]; -end; - -function TTntStringField.GetAsVariant: Variant; -begin - if RawVariantAccess then - Result := inherited GetAsVariant - else if IsNull then - Result := Null - else - Result := GetAsWideString; -end; - -procedure TTntStringField.SetVarValue(const Value: Variant); -begin - if RawVariantAccess then - inherited - else - SetAsWideString(Value); -end; - -function TTntStringField.GetAsWideString: WideString; -begin - case EncodingMode of - emNone: Result := (inherited GetAsString); - emUTF8: Result := UTF8ToWideString(inherited GetAsString); - emUTF7: try - Result := UTF7ToWideString(inherited GetAsString); - except - Result := inherited GetAsString; - end; - emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); - emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); - else - raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); - end; -end; - -procedure TTntStringField.SetAsWideString(const Value: WideString); -begin - case EncodingMode of - emNone: inherited SetAsString(Value); - emUTF8: inherited SetAsString(WideStringToUTF8(Value)); - emUTF7: inherited SetAsString(WideStringToUTF7(Value)); - emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); - emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); - else - raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); - end; -end; - -function TTntStringField.GetAsString: string{TNT-ALLOW string}; -begin - if EncodingMode = emNone then - Result := inherited GetAsString - else - Result := GetAsWideString; -end; - -procedure TTntStringField.SetAsString(const Value: string{TNT-ALLOW string}); -begin - if EncodingMode = emNone then - inherited SetAsString(Value) - else - SetAsWideString(Value); -end; - -procedure TTntStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; - DoDisplayText: Boolean); -begin - TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); -end; - -procedure TTntStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString); -begin - TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); -end; - -procedure TTntStringField.SetOnGetText(const Value: TFieldGetWideTextEvent); -begin - FOnGetText := Value; - if Assigned(OnGetText) then - inherited OnGetText := LegacyGetText - else - inherited OnGetText := nil; -end; - -procedure TTntStringField.SetOnSetText(const Value: TFieldSetWideTextEvent); -begin - FOnSetText := Value; - if Assigned(OnSetText) then - inherited OnSetText := LegacySetText - else - inherited OnSetText := nil; -end; - -function TTntStringField.GetWideDisplayText: WideString; -begin - Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) -end; - -function TTntStringField.GetWideEditText: WideString; -begin - Result := TntWideStringField_GetWideEditText(Self, OnGetText); -end; - -procedure TTntStringField.SetWideEditText(const Value: WideString); -begin - TntWideStringField_SetWideEditText(Self, OnSetText, Value); -end; - -function TTntStringField.IsFixedCodePageStored: Boolean; -begin - Result := EncodingMode = emFixedCodePage; -end; - -//--------------------------------------------------------------------------------------------- -{ TTntMemoField } - -constructor TTntMemoField.Create(AOwner: TComponent); -begin - inherited; - FEncodingMode := emUTF8; - FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern] -end; - -function TTntMemoField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum; -var - i: TTntStringFieldCodePageEnum; -begin - Result := fcpOther; - for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin - if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin - Result := i; - Break; {found it} - end; - end; -end; - -procedure TTntMemoField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum); -begin - if (Value <> fcpOther) then - FixedCodePage := TntStringFieldCodePageEnumMap[Value]; -end; - -function TTntMemoField.GetAsVariant: Variant; -begin - if RawVariantAccess then - Result := inherited GetAsVariant - else if IsNull then - Result := Null - else - Result := GetAsWideString; -end; - -procedure TTntMemoField.SetVarValue(const Value: Variant); -begin - if RawVariantAccess then - inherited - else - SetAsWideString(Value); -end; - -function TTntMemoField.GetAsWideString: WideString; -begin - case EncodingMode of - emNone: Result := (inherited GetAsString); - emUTF8: Result := UTF8ToWideString(inherited GetAsString); - emUTF7: try - Result := UTF7ToWideString(inherited GetAsString); - except - Result := inherited GetAsString; - end; - emFixedCodePage: Result := StringToWideStringEx(inherited GetAsString, FixedCodePage); - emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage); - else - raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); - end; -end; - -procedure TTntMemoField.SetAsWideString(const Value: WideString); -begin - case EncodingMode of - emNone: inherited SetAsString(Value); - emUTF8: inherited SetAsString(WideStringToUTF8(Value)); - emUTF7: inherited SetAsString(WideStringToUTF7(Value)); - emFixedCodePage: inherited SetAsString(WideStringToStringEx(Value, FixedCodePage)); - emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage)); - else - raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode'); - end; -end; - -function TTntMemoField.GetAsString: string{TNT-ALLOW string}; -begin - if EncodingMode = emNone then - Result := inherited GetAsString - else - Result := GetAsWideString; -end; - -procedure TTntMemoField.SetAsString(const Value: string{TNT-ALLOW string}); -begin - if EncodingMode = emNone then - inherited SetAsString(Value) - else - SetAsWideString(Value); -end; - -procedure TTntMemoField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; - DoDisplayText: Boolean); -begin - TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText); -end; - -procedure TTntMemoField.LegacySetText(Sender: TField; const AnsiText: AnsiString); -begin - TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText); -end; - -procedure TTntMemoField.SetOnGetText(const Value: TFieldGetWideTextEvent); -begin - FOnGetText := Value; - if Assigned(OnGetText) then - inherited OnGetText := LegacyGetText - else - inherited OnGetText := nil; -end; - -procedure TTntMemoField.SetOnSetText(const Value: TFieldSetWideTextEvent); -begin - FOnSetText := Value; - if Assigned(OnSetText) then - inherited OnSetText := LegacySetText - else - inherited OnSetText := nil; -end; - -function TTntMemoField.GetWideDisplayText: WideString; -begin - Result := TntWideStringField_GetWideDisplayText(Self, OnGetText) -end; - -function TTntMemoField.GetWideEditText: WideString; -begin - Result := TntWideStringField_GetWideEditText(Self, OnGetText); -end; - -procedure TTntMemoField.SetWideEditText(const Value: WideString); -begin - TntWideStringField_SetWideEditText(Self, OnSetText, Value); -end; - -function TTntMemoField.IsFixedCodePageStored: Boolean; -begin - Result := EncodingMode = emFixedCodePage; -end; -//================================================================== -procedure RegisterTntFields; -begin - RegisterFields([TTntDateTimeField]); - RegisterFields([TTntDateField]); - RegisterFields([TTntTimeField]); - RegisterFields([TTntWideStringField]); - RegisterFields([TTntStringField]); - RegisterFields([TTntMemoField]); -end; - -type PFieldClass = ^TFieldClass; - -initialization -{$IFDEF TNT_FIELDS} - PFieldClass(@DefaultFieldClasses[ftDate])^ := TTntDateField; - PFieldClass(@DefaultFieldClasses[ftTime])^ := TTntTimeField; - PFieldClass(@DefaultFieldClasses[ftDateTime])^ := TTntDateTimeField; - PFieldClass(@DefaultFieldClasses[ftWideString])^ := TTntWideStringField; - PFieldClass(@DefaultFieldClasses[ftString])^ := TTntStringField; - PFieldClass(@DefaultFieldClasses[ftFixedChar])^ := TTntStringField; -{$ENDIF} - -finalization - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas deleted file mode 100644 index 681257ec1a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas +++ /dev/null @@ -1,594 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDBActns; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, ActnList, DBActns, TntActnList; - -type -{TNT-WARN TDataSetAction} - TTntDataSetAction = class(TDataSetAction{TNT-ALLOW TDataSetAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetFirst} - TTntDataSetFirst = class(TDataSetFirst{TNT-ALLOW TDataSetFirst}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetPrior} - TTntDataSetPrior = class(TDataSetPrior{TNT-ALLOW TDataSetPrior}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetNext} - TTntDataSetNext = class(TDataSetNext{TNT-ALLOW TDataSetNext}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetLast} - TTntDataSetLast = class(TDataSetLast{TNT-ALLOW TDataSetLast}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetInsert} - TTntDataSetInsert = class(TDataSetInsert{TNT-ALLOW TDataSetInsert}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetDelete} - TTntDataSetDelete = class(TDataSetDelete{TNT-ALLOW TDataSetDelete}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetEdit} - TTntDataSetEdit = class(TDataSetEdit{TNT-ALLOW TDataSetEdit}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetPost} - TTntDataSetPost = class(TDataSetPost{TNT-ALLOW TDataSetPost}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetCancel} - TTntDataSetCancel = class(TDataSetCancel{TNT-ALLOW TDataSetCancel}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDataSetRefresh} - TTntDataSetRefresh = class(TDataSetRefresh{TNT-ALLOW TDataSetRefresh}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); - -implementation - -uses - TntClasses; - -{TNT-IGNORE-UNIT} - -procedure TntDBActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntAction_AfterInherited_Assign(Action, Source); - // TDataSetAction - if (Action is TDataSetAction) and (Source is TDataSetAction) then begin - TDataSetAction(Action).DataSource := TDataSetAction(Source).DataSource; - end; -end; - -//------------------------- -// TNT DB ACTNS -//------------------------- - -{ TTntDataSetAction } - -procedure TTntDataSetAction.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetFirst } - -procedure TTntDataSetFirst.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetFirst.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetFirst.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetFirst.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetFirst.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetFirst.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetPrior } - -procedure TTntDataSetPrior.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetPrior.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetPrior.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetPrior.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetPrior.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetPrior.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetNext } - -procedure TTntDataSetNext.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetNext.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetNext.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetNext.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetNext.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetNext.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetLast } - -procedure TTntDataSetLast.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetLast.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetLast.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetLast.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetLast.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetLast.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetInsert } - -procedure TTntDataSetInsert.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetInsert.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetInsert.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetInsert.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetInsert.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetInsert.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetDelete } - -procedure TTntDataSetDelete.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetDelete.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetDelete.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetDelete.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetDelete.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetDelete.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetEdit } - -procedure TTntDataSetEdit.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetEdit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetEdit.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetEdit.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetEdit.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetEdit.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetPost } - -procedure TTntDataSetPost.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetPost.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetPost.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetPost.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetPost.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetPost.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetCancel } - -procedure TTntDataSetCancel.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetCancel.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetCancel.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetCancel.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetCancel.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetCancel.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDataSetRefresh } - -procedure TTntDataSetRefresh.Assign(Source: TPersistent); -begin - inherited; - TntDBActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDataSetRefresh.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDataSetRefresh.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDataSetRefresh.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDataSetRefresh.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDataSetRefresh.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas deleted file mode 100644 index 98904c7380..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas +++ /dev/null @@ -1,197 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDBClientActns; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, ActnList, DBClientActns, TntActnList; - -type -{TNT-WARN TClientDataSetApply} - TTntClientDataSetApply = class(TClientDataSetApply{TNT-ALLOW TClientDataSetApply}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TClientDataSetRevert} - TTntClientDataSetRevert = class(TClientDataSetRevert{TNT-ALLOW TClientDataSetRevert}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TClientDataSetUndo} - TTntClientDataSetUndo = class(TClientDataSetUndo{TNT-ALLOW TClientDataSetUndo}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -implementation - -uses - TntClasses, TntDBActns; - -{TNT-IGNORE-UNIT} - -procedure TntDBClientActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntDBActn_AfterInherited_Assign(Action, Source); - // TClientDataSetApply - if (Action is TClientDataSetApply) and (Source is TClientDataSetApply) then begin - TClientDataSetApply(Action).MaxErrors := TClientDataSetApply(Source).MaxErrors; - TClientDataSetApply(Action).DisplayErrorDlg := TClientDataSetApply(Source).DisplayErrorDlg; - end; - // TClientDataSetUndo - if (Action is TClientDataSetUndo) and (Source is TClientDataSetUndo) then begin - TClientDataSetUndo(Action).FollowChange := TClientDataSetUndo(Source).FollowChange; - end; -end; - -//------------------------- -// TNT DB ACTNS -//------------------------- - -{ TTntClientDataSetApply } - -procedure TTntClientDataSetApply.Assign(Source: TPersistent); -begin - inherited; - TntDBClientActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntClientDataSetApply.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntClientDataSetApply.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntClientDataSetApply.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntClientDataSetApply.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntClientDataSetApply.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntClientDataSetRevert } - -procedure TTntClientDataSetRevert.Assign(Source: TPersistent); -begin - inherited; - TntDBClientActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntClientDataSetRevert.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntClientDataSetRevert.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntClientDataSetRevert.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntClientDataSetRevert.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntClientDataSetRevert.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntClientDataSetUndo } - -procedure TTntClientDataSetUndo.Assign(Source: TPersistent); -begin - inherited; - TntDBClientActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntClientDataSetUndo.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntClientDataSetUndo.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntClientDataSetUndo.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntClientDataSetUndo.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntClientDataSetUndo.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas deleted file mode 100644 index 49111d4aba..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas +++ /dev/null @@ -1,2195 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDBCtrls; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Windows, Messages, DB, DBCtrls, Controls, StdCtrls, - TntClasses, TntStdCtrls, TntControls, TntComCtrls, TntExtCtrls; - -type -{TNT-WARN TPaintControl} - TTntPaintControl = class - private - FOwner: TWinControl; - FClassName: WideString; - FHandle: HWnd; - FObjectInstance: Pointer; - FDefWindowProc: Pointer; - FCtl3dButton: Boolean; - function GetHandle: HWnd; - procedure SetCtl3DButton(Value: Boolean); - procedure WndProc(var Message: TMessage); - public - constructor Create(AOwner: TWinControl; const ClassName: WideString); - destructor Destroy; override; - procedure DestroyHandle; - property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton; - property Handle: HWnd read GetHandle; - end; - -type -{TNT-WARN TDBEdit} - TTntDBEdit = class(TDBEdit{TNT-ALLOW TDBEdit}) - private - InheritedDataChange: TNotifyEvent; - FPasswordChar: WideChar; - procedure DataChange(Sender: TObject); - procedure UpdateData(Sender: TObject); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMPaint(var Message: TWMPaint); message WM_PAINT; - function GetTextMargins: TPoint; - function GetPasswordChar: WideChar; - procedure SetPasswordChar(const Value: WideChar); - procedure CMEnter(var Message: TCMEnter); message CM_ENTER; - private - function GetSelStart: Integer; reintroduce; virtual; - procedure SetSelStart(const Value: Integer); reintroduce; virtual; - function GetSelLength: Integer; reintroduce; virtual; - procedure SetSelLength(const Value: Integer); reintroduce; virtual; - function GetSelText: WideString; reintroduce; - procedure SetSelText(const Value: WideString); - function GetText: WideString; - procedure SetText(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - property SelText: WideString read GetSelText write SetSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; - end; - -{TNT-WARN TDBText} - TTntDBText = class(TDBText{TNT-ALLOW TDBText}) - private - FDataLink: TFieldDataLink; - InheritedDataChange: TNotifyEvent; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - function GetCaption: TWideCaption; - function IsCaptionStored: Boolean; - procedure SetCaption(const Value: TWideCaption); - function GetFieldText: WideString; - procedure DataChange(Sender: TObject); - protected - procedure DefineProperties(Filer: TFiler); override; - function GetLabelText: WideString; reintroduce; virtual; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure DoDrawText(var Rect: TRect; Flags: Longint); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TDBComboBox} - TTntCustomDBComboBox = class(TDBComboBox{TNT-ALLOW TDBComboBox}, - IWideCustomListControl) - private - FDataLink: TFieldDataLink; - FFilter: WideString; - FLastTime: Cardinal; - procedure UpdateData(Sender: TObject); - procedure EditingChange(Sender: TObject); - procedure CMEnter(var Message: TCMEnter); message CM_ENTER; - procedure SetReadOnly; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - private - FItems: TTntStrings; - FSaveItems: TTntStrings; - FSaveItemIndex: integer; - function GetItems: TTntStrings; - procedure SetItems(const Value: TTntStrings); reintroduce; - function GetSelStart: Integer; - procedure SetSelStart(const Value: Integer); - function GetSelLength: Integer; - procedure SetSelLength(const Value: Integer); - function GetSelText: WideString; - procedure SetSelText(const Value: WideString); - function GetText: WideString; - procedure SetText(const Value: WideString); - - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - protected - procedure DataChange(Sender: TObject); - function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; - function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; - procedure DoEditCharMsg(var Message: TWMChar); virtual; - function GetFieldValue: Variant; virtual; - procedure SetFieldValue(const Value: Variant); virtual; - function GetComboValue: Variant; virtual; abstract; - procedure SetComboValue(const Value: Variant); virtual; abstract; - {$IFDEF DELPHI_7} // fix for Delphi 7 only - function GetItemsClass: TCustomComboBoxStringsClass; override; - {$ENDIF} - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - procedure WndProc(var Message: TMessage); override; - procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; - procedure KeyPress(var Key: AnsiChar); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure CopySelection(Destination: TCustomListControl); override; - procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; - public - property SelText: WideString read GetSelText write SetSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property Items: TTntStrings read GetItems write SetItems; - end; - - TTntDBComboBox = class(TTntCustomDBComboBox) - protected - function GetFieldValue: Variant; override; - procedure SetFieldValue(const Value: Variant); override; - function GetComboValue: Variant; override; - procedure SetComboValue(const Value: Variant); override; - end; - -type -{TNT-WARN TDBCheckBox} - TTntDBCheckBox = class(TDBCheckBox{TNT-ALLOW TDBCheckBox}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure Toggle; override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TDBRichEdit} - TTntDBRichEdit = class(TTntCustomRichEdit) - private - FDataLink: TFieldDataLink; - FAutoDisplay: Boolean; - FFocused: Boolean; - FMemoLoaded: Boolean; - FDataSave: AnsiString; - procedure BeginEditing; - procedure DataChange(Sender: TObject); - procedure EditingChange(Sender: TObject); - function GetDataField: WideString; - function GetDataSource: TDataSource; - function GetField: TField; - function GetReadOnly: Boolean; - procedure SetDataField(const Value: WideString); - procedure SetDataSource(Value: TDataSource); - procedure SetReadOnly(Value: Boolean); - procedure SetAutoDisplay(Value: Boolean); - procedure SetFocused(Value: Boolean); - procedure UpdateData(Sender: TObject); - procedure WMCut(var Message: TMessage); message WM_CUT; - procedure WMPaste(var Message: TMessage); message WM_PASTE; - procedure CMEnter(var Message: TCMEnter); message CM_ENTER; - procedure CMExit(var Message: TCMExit); message CM_EXIT; - procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; - procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; - procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; - protected - procedure InternalLoadMemo; dynamic; - procedure InternalSaveMemo; dynamic; - protected - procedure Change; override; - procedure KeyDown(var Key: Word; Shift: TShiftState); override; - procedure KeyPress(var Key: AnsiChar); override; - procedure Loaded; override; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function ExecuteAction(Action: TBasicAction): Boolean; override; - procedure LoadMemo; virtual; - function UpdateAction(Action: TBasicAction): Boolean; override; - function UseRightToLeftAlignment: Boolean; override; - property Field: TField read GetField; - published - property Align; - property Alignment; - property Anchors; - property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property Color; - property Constraints; - property Ctl3D; - property DataField: WideString read GetDataField write SetDataField; - property DataSource: TDataSource read GetDataSource write SetDataSource; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property HideScrollBars; - property ImeMode; - property ImeName; - property MaxLength; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PlainText; - property PopupMenu; - property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; - property ScrollBars; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - property WantReturns; - property WantTabs; - property WordWrap; - property OnChange; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnResizeRequest; - property OnSelectionChange; - property OnProtectChange; - property OnSaveClipboard; - property OnStartDock; - property OnStartDrag; - end; - -type -{TNT-WARN TDBMemo} - TTntDBMemo = class(TTntCustomMemo) - private - FDataLink: TFieldDataLink; - FAutoDisplay: Boolean; - FFocused: Boolean; - FMemoLoaded: Boolean; - FPaintControl: TTntPaintControl; - procedure DataChange(Sender: TObject); - procedure EditingChange(Sender: TObject); - function GetDataField: WideString; - function GetDataSource: TDataSource; - function GetField: TField; - function GetReadOnly: Boolean; - procedure SetDataField(const Value: WideString); - procedure SetDataSource(Value: TDataSource); - procedure SetReadOnly(Value: Boolean); - procedure SetAutoDisplay(Value: Boolean); - procedure SetFocused(Value: Boolean); - procedure UpdateData(Sender: TObject); - procedure WMCut(var Message: TMessage); message WM_CUT; - procedure WMPaste(var Message: TMessage); message WM_PASTE; - procedure WMUndo(var Message: TMessage); message WM_UNDO; - procedure CMEnter(var Message: TCMEnter); message CM_ENTER; - procedure CMExit(var Message: TCMExit); message CM_EXIT; - procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; - procedure WMPaint(var Message: TWMPaint); message WM_PAINT; - procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; - protected - procedure Change; override; - procedure KeyDown(var Key: Word; Shift: TShiftState); override; - procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; - procedure Loaded; override; - procedure Notification(AComponent: TComponent; - Operation: TOperation); override; - procedure WndProc(var Message: TMessage); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function ExecuteAction(Action: TBasicAction): Boolean; override; - procedure LoadMemo; virtual; - function UpdateAction(Action: TBasicAction): Boolean; override; - function UseRightToLeftAlignment: Boolean; override; - property Field: TField read GetField; - published - property Align; - property Alignment; - property Anchors; - property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property Color; - property Constraints; - property Ctl3D; - property DataField: WideString read GetDataField write SetDataField; - property DataSource: TDataSource read GetDataSource write SetDataSource; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property ImeMode; - property ImeName; - property MaxLength; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; - property ScrollBars; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - property WantReturns; - property WantTabs; - property WordWrap; - property OnChange; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - -{ TDBRadioGroup } -type - TTntDBRadioGroup = class(TTntCustomRadioGroup) - private - FDataLink: TFieldDataLink; - FValue: WideString; - FValues: TTntStrings; - FInSetValue: Boolean; - FOnChange: TNotifyEvent; - procedure DataChange(Sender: TObject); - procedure UpdateData(Sender: TObject); - function GetDataField: WideString; - function GetDataSource: TDataSource; - function GetField: TField; - function GetReadOnly: Boolean; - function GetButtonValue(Index: Integer): WideString; - procedure SetDataField(const Value: WideString); - procedure SetDataSource(Value: TDataSource); - procedure SetReadOnly(Value: Boolean); - procedure SetValue(const Value: WideString); - procedure SetItems(Value: TTntStrings); - procedure SetValues(Value: TTntStrings); - procedure CMExit(var Message: TCMExit); message CM_EXIT; - procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; - protected - procedure Change; dynamic; - procedure Click; override; - procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; - function CanModify: Boolean; override; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - property DataLink: TFieldDataLink read FDataLink; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function ExecuteAction(Action: TBasicAction): Boolean; override; - function UpdateAction(Action: TBasicAction): Boolean; override; - function UseRightToLeftAlignment: Boolean; override; - property Field: TField read GetField; - property ItemIndex; - property Value: WideString read FValue write SetValue; - published - property Align; - property Anchors; - property BiDiMode; - property Caption; - property Color; - property Columns; - property Constraints; - property Ctl3D; - property DataField: WideString read GetDataField write SetDataField; - property DataSource: TDataSource read GetDataSource write SetDataSource; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property Items write SetItems; - {$IFDEF COMPILER_7_UP} - property ParentBackground; - {$ENDIF} - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; - property ShowHint; - property TabOrder; - property TabStop; - property Values: TTntStrings read FValues write SetValues; - property Visible; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnClick; - property OnContextPopup; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnStartDock; - property OnStartDrag; - end; - -implementation - -uses - Forms, SysUtils, Graphics, Variants, TntDB, - TntActnList, TntGraphics, TntSysUtils, RichEdit, Mask; - -function FieldIsBlobLike(Field: TField): Boolean; -begin - Result := False; - if Assigned(Field) then begin - if (Field.IsBlob) - or (Field.DataType in [Low(TBlobType).. High(TBlobType)]) then - Result := True - else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) - and (Field.Size = MaxInt) then - Result := True; { wide string field filling in for a blob field } - end; -end; - -{ TTntPaintControl } - -type - TAccessWinControl = class(TWinControl); - -constructor TTntPaintControl.Create(AOwner: TWinControl; const ClassName: WideString); -begin - FOwner := AOwner; - FClassName := ClassName; -end; - -destructor TTntPaintControl.Destroy; -begin - DestroyHandle; -end; - -procedure TTntPaintControl.DestroyHandle; -begin - if FHandle <> 0 then DestroyWindow(FHandle); - Classes.FreeObjectInstance(FObjectInstance); - FHandle := 0; - FObjectInstance := nil; -end; - -function TTntPaintControl.GetHandle: HWnd; -var - Params: TCreateParams; -begin - if FHandle = 0 then - begin - FObjectInstance := Classes.MakeObjectInstance(WndProc); - TAccessWinControl(FOwner).CreateParams(Params); - Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL); - if (not Win32PlatformIsUnicode) then begin - with Params do - FHandle := CreateWindowEx(ExStyle, PAnsiChar(AnsiString(FClassName)), - PAnsiChar(TAccessWinControl(FOwner).Text), Style or WS_VISIBLE, - X, Y, Width, Height, Application.Handle, 0, HInstance, nil); - FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC)); - SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); - end else begin - with Params do - FHandle := CreateWindowExW(ExStyle, PWideChar(FClassName), - PWideChar(TntControl_GetText(FOwner)), Style or WS_VISIBLE, - X, Y, Width, Height, Application.Handle, 0, HInstance, nil); - FDefWindowProc := Pointer(GetWindowLongW(FHandle, GWL_WNDPROC)); - SetWindowLongW(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); - end; - SendMessage(FHandle, WM_SETFONT, Integer(TAccessWinControl(FOwner).Font.Handle), 1); - end; - Result := FHandle; -end; - -procedure TTntPaintControl.SetCtl3DButton(Value: Boolean); -begin - if FHandle <> 0 then DestroyHandle; - FCtl3DButton := Value; -end; - -procedure TTntPaintControl.WndProc(var Message: TMessage); -begin - with Message do - if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then - Result := FOwner.Perform(Msg, WParam, LParam) - else if (not Win32PlatformIsUnicode) then - Result := CallWindowProcA(FDefWindowProc, FHandle, Msg, WParam, LParam) - else - Result := CallWindowProcW(FDefWindowProc, FHandle, Msg, WParam, LParam); -end; - -{ THackFieldDataLink } -type - THackFieldDataLink_D6_D7_D9 = class(TDataLink) - protected - FxxxField: TField; - FxxxFieldName: string{TNT-ALLOW string}; - FxxxControl: TComponent; - FxxxEditing: Boolean; - FModified: Boolean; - end; - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - THackFieldDataLink = THackFieldDataLink_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - THackFieldDataLink = THackFieldDataLink_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - THackFieldDataLink = THackFieldDataLink_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - THackFieldDataLink = class(TDataLink) - protected - FxxxField: TField; - FxxxFieldName: WideString; - FxxxControl: TComponent; - FxxxEditing: Boolean; - FModified: Boolean; - end; -{$ENDIF} - -{ TTntDBEdit } - -type - THackDBEdit_D6_D7_D9 = class(TCustomMaskEdit) - protected - FDataLink: TFieldDataLink; - FCanvas: TControlCanvas; - FAlignment: TAlignment; - FFocused: Boolean; - end; - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - THackDBEdit = THackDBEdit_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - THackDBEdit = THackDBEdit_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - THackDBEdit = THackDBEdit_D6_D7_D9; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - THackDBEdit = THackDBEdit_D6_D7_D9; -{$ENDIF} - -constructor TTntDBEdit.Create(AOwner: TComponent); -begin - inherited; - InheritedDataChange := THackDBEdit(Self).FDataLink.OnDataChange; - THackDBEdit(Self).FDataLink.OnDataChange := DataChange; - THackDBEdit(Self).FDataLink.OnUpdateData := UpdateData; -end; - -procedure TTntDBEdit.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'EDIT'); -end; - -procedure TTntDBEdit.CreateWnd; -begin - inherited; - TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); -end; - -procedure TTntDBEdit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDBEdit.GetSelStart: Integer; -begin - Result := TntCustomEdit_GetSelStart(Self); -end; - -procedure TTntDBEdit.SetSelStart(const Value: Integer); -begin - TntCustomEdit_SetSelStart(Self, Value); -end; - -function TTntDBEdit.GetSelLength: Integer; -begin - Result := TntCustomEdit_GetSelLength(Self); -end; - -procedure TTntDBEdit.SetSelLength(const Value: Integer); -begin - TntCustomEdit_SetSelLength(Self, Value); -end; - -function TTntDBEdit.GetSelText: WideString; -begin - Result := TntCustomEdit_GetSelText(Self); -end; - -procedure TTntDBEdit.SetSelText(const Value: WideString); -begin - TntCustomEdit_SetSelText(Self, Value); -end; - -function TTntDBEdit.GetPasswordChar: WideChar; -begin - Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar) -end; - -procedure TTntDBEdit.SetPasswordChar(const Value: WideChar); -begin - TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); -end; - -function TTntDBEdit.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntDBEdit.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntDBEdit.DataChange(Sender: TObject); -begin - with THackDBEdit(Self), Self do begin - if Field = nil then - InheritedDataChange(Sender) - else begin - if FAlignment <> Field.Alignment then - begin - EditText := ''; {forces update} - FAlignment := Field.Alignment; - end; - EditMask := Field.EditMask; - if not (csDesigning in ComponentState) then - begin - if (Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then - MaxLength := Field.Size; - end; - if FFocused and FDataLink.CanModify then - Text := GetWideText(Field) - else - begin - Text := GetWideDisplayText(Field); - if FDataLink.Editing and THackFieldDataLink(FDataLink).FModified then - Modified := True; - end; - end; - end; -end; - -procedure TTntDBEdit.UpdateData(Sender: TObject); -begin - ValidateEdit; - SetWideText(Field, Text); -end; - -procedure TTntDBEdit.CMEnter(var Message: TCMEnter); -var - SaveFarEast: Boolean; -begin - SaveFarEast := SysLocale.FarEast; - try - SysLocale.FarEast := False; - inherited; // inherited tries to work around Win95 FarEast bug, but introduces others - finally - SysLocale.FarEast := SaveFarEast; - end; -end; - -function TTntDBEdit.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntDBEdit.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntDBEdit.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntDBEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntDBEdit.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntDBEdit.WMPaint(var Message: TWMPaint); -const - AlignStyle : array[Boolean, TAlignment] of DWORD = - ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT), - (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT)); -var - ALeft: Integer; - _Margins: TPoint; - R: TRect; - DC: HDC; - PS: TPaintStruct; - S: WideString; - AAlignment: TAlignment; - I: Integer; -begin - with THackDBEdit(Self), Self do begin - AAlignment := FAlignment; - if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); - if ((AAlignment = taLeftJustify) or FFocused) and (not (csPaintCopy in ControlState)) - or (not Win32PlatformIsUnicode) then - begin - inherited; - Exit; - end; - { Since edit controls do not handle justification unless multi-line (and - then only poorly) we will draw right and center justify manually unless - the edit has the focus. } - if FCanvas = nil then - begin - FCanvas := TControlCanvas.Create; - FCanvas.Control := Self; - end; - DC := Message.DC; - if DC = 0 then DC := BeginPaint(Handle, PS); - FCanvas.Handle := DC; - try - FCanvas.Font := Font; - with FCanvas do - begin - R := ClientRect; - if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then - begin - Brush.Color := clWindowFrame; - FrameRect(R); - InflateRect(R, -1, -1); - end; - Brush.Color := Color; - if not Enabled then - Font.Color := clGrayText; - if (csPaintCopy in ControlState) and (Field <> nil) then - begin - S := GetWideDisplayText(Field); - case CharCase of - ecUpperCase: - S := Tnt_WideUpperCase(S); - ecLowerCase: - S := Tnt_WideLowerCase(S); - end; - end else - S := Text { EditText? }; - if PasswordChar <> #0 then - for I := 1 to Length(S) do S[I] := PasswordChar; - _Margins := GetTextMargins; - case AAlignment of - taLeftJustify: ALeft := _Margins.X; - taRightJustify: ALeft := ClientWidth - WideCanvasTextWidth(FCanvas, S) - _Margins.X - 1; - else - ALeft := (ClientWidth - WideCanvasTextWidth(FCanvas, S)) div 2; - end; - if SysLocale.MiddleEast then UpdateTextFlags; - WideCanvasTextRect(FCanvas, R, ALeft, _Margins.Y, S); - end; - finally - FCanvas.Handle := 0; - if Message.DC = 0 then EndPaint(Handle, PS); - end; - end; -end; - -function TTntDBEdit.GetTextMargins: TPoint; -var - DC: HDC; - SaveFont: HFont; - I: Integer; - SysMetrics, Metrics: TTextMetric; -begin - if NewStyleControls then - begin - if BorderStyle = bsNone then I := 0 else - if Ctl3D then I := 1 else I := 2; - Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I; - Result.Y := I; - end else - begin - if BorderStyle = bsNone then I := 0 else - begin - DC := GetDC(0); - GetTextMetrics(DC, SysMetrics); - SaveFont := SelectObject(DC, Font.Handle); - GetTextMetrics(DC, Metrics); - SelectObject(DC, SaveFont); - ReleaseDC(0, DC); - I := SysMetrics.tmHeight; - if I > Metrics.tmHeight then I := Metrics.tmHeight; - I := I div 4; - end; - Result.X := I; - Result.Y := I; - end; -end; - -{ TTntDBText } - -constructor TTntDBText.Create(AOwner: TComponent); -begin - inherited; - FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; - InheritedDataChange := FDataLink.OnDataChange; - FDataLink.OnDataChange := DataChange; -end; - -destructor TTntDBText.Destroy; -begin - FDataLink := nil; - inherited; -end; - -procedure TTntDBText.CMDialogChar(var Message: TCMDialogChar); -begin - TntLabel_CMDialogChar(Self, Message, Caption); -end; - -function TTntDBText.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntDBText.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntDBText.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntDBText.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDBText.GetLabelText: WideString; -begin - if csPaintCopy in ControlState then - Result := GetFieldText - else - Result := Caption; -end; - -procedure TTntDBText.DoDrawText(var Rect: TRect; Flags: Integer); -begin - if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then - inherited; -end; - -function TTntDBText.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntDBText.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntDBText.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntDBText.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntDBText.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntDBText.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -function TTntDBText.GetFieldText: WideString; -begin - if Field <> nil then - Result := GetWideDisplayText(Field) - else - if csDesigning in ComponentState then Result := Name else Result := ''; -end; - -procedure TTntDBText.DataChange(Sender: TObject); -begin - Caption := GetFieldText; -end; - -{ TTntCustomDBComboBox } - -constructor TTntCustomDBComboBox.Create(AOwner: TComponent); -begin - inherited; - FItems := TTntComboBoxStrings.Create; - TTntComboBoxStrings(FItems).ComboBox := Self; - FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; - FDataLink.OnDataChange := DataChange; - FDataLink.OnUpdateData := UpdateData; - FDataLink.OnEditingChange := EditingChange; -end; - -destructor TTntCustomDBComboBox.Destroy; -begin - FreeAndNil(FItems); - FreeAndNil(FSaveItems); - FDataLink := nil; - inherited; -end; - -procedure TTntCustomDBComboBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'COMBOBOX'); -end; - -procedure TTntCustomDBComboBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -type - TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); - -procedure TTntCustomDBComboBox.CreateWnd; -var - PreInheritedAnsiText: AnsiString; -begin - PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; - inherited; - TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); -end; - -procedure TTntCustomDBComboBox.DestroyWnd; -var - SavedText: WideString; -begin - if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } - TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); - inherited; - TntControl_SetStoredText(Self, SavedText); - end; -end; - -procedure TTntCustomDBComboBox.SetReadOnly; -begin - if (Style in [csDropDown, csSimple]) and HandleAllocated then - SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.CanModify), 0); -end; - -procedure TTntCustomDBComboBox.EditingChange(Sender: TObject); -begin - SetReadOnly; -end; - -procedure TTntCustomDBComboBox.CMEnter(var Message: TCMEnter); -var - SaveFarEast: Boolean; -begin - SaveFarEast := SysLocale.FarEast; - try - SysLocale.FarEast := False; - inherited; // inherited tries to work around Win95 FarEast bug, but introduces others - finally - SysLocale.FarEast := SaveFarEast; - end; -end; - -procedure TTntCustomDBComboBox.WndProc(var Message: TMessage); -begin - if (not (csDesigning in ComponentState)) - and (Message.Msg = CB_SHOWDROPDOWN) - and (Message.WParam = 0) - and (not FDataLink.Editing) then begin - DataChange(Self); {Restore text} - Dispatch(Message); {Do NOT call inherited!} - end else - inherited WndProc(Message); -end; - -procedure TTntCustomDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); -begin - if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then - inherited; -end; - -procedure TTntCustomDBComboBox.KeyPress(var Key: AnsiChar); -var - SaveAutoComplete: Boolean; -begin - TntCombo_BeforeKeyPress(Self, SaveAutoComplete); - try - inherited; - finally - TntCombo_AfterKeyPress(Self, SaveAutoComplete); - end; -end; - -procedure TTntCustomDBComboBox.DoEditCharMsg(var Message: TWMChar); -begin - TntCombo_AutoCompleteKeyPress(Self, Items, Message, - GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); -end; - -procedure TTntCustomDBComboBox.WMChar(var Message: TWMChar); -begin - TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); - inherited; -end; - -function TTntCustomDBComboBox.GetItems: TTntStrings; -begin - Result := FItems; -end; - -procedure TTntCustomDBComboBox.SetItems(const Value: TTntStrings); -begin - FItems.Assign(Value); - DataChange(Self); -end; - -function TTntCustomDBComboBox.GetSelStart: Integer; -begin - Result := TntCombo_GetSelStart(Self); -end; - -procedure TTntCustomDBComboBox.SetSelStart(const Value: Integer); -begin - TntCombo_SetSelStart(Self, Value); -end; - -function TTntCustomDBComboBox.GetSelLength: Integer; -begin - Result := TntCombo_GetSelLength(Self); -end; - -procedure TTntCustomDBComboBox.SetSelLength(const Value: Integer); -begin - TntCombo_SetSelLength(Self, Value); -end; - -function TTntCustomDBComboBox.GetSelText: WideString; -begin - Result := TntCombo_GetSelText(Self); -end; - -procedure TTntCustomDBComboBox.SetSelText(const Value: WideString); -begin - TntCombo_SetSelText(Self, Value); -end; - -function TTntCustomDBComboBox.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntCustomDBComboBox.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomDBComboBox.CNCommand(var Message: TWMCommand); -begin - if not TntCombo_CNCommand(Self, Items, Message) then - inherited; -end; - -function TTntCustomDBComboBox.GetFieldValue: Variant; -begin - Result := Field.Value; -end; - -procedure TTntCustomDBComboBox.SetFieldValue(const Value: Variant); -begin - Field.Value := Value; -end; - -procedure TTntCustomDBComboBox.DataChange(Sender: TObject); -begin - if not (Style = csSimple) and DroppedDown then Exit; - if Field <> nil then - SetComboValue(GetFieldValue) - else - if csDesigning in ComponentState then - SetComboValue(Name) - else - SetComboValue(Null); -end; - -procedure TTntCustomDBComboBox.UpdateData(Sender: TObject); -begin - SetFieldValue(GetComboValue); -end; - -function TTntCustomDBComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; -begin - Result := True; -end; - -function TTntCustomDBComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; -begin - Result := False; -end; - -function TTntCustomDBComboBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomDBComboBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomDBComboBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomDBComboBox.AddItem(const Item: WideString; AObject: TObject); -begin - TntComboBox_AddItem(Items, Item, AObject); -end; - -procedure TTntCustomDBComboBox.CopySelection(Destination: TCustomListControl); -begin - TntComboBox_CopySelection(Items, ItemIndex, Destination); -end; - -procedure TTntCustomDBComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomDBComboBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{$IFDEF DELPHI_7} // fix for Delphi 7 only -function TTntCustomDBComboBox.GetItemsClass: TCustomComboBoxStringsClass; -begin - Result := TD7PatchedComboBoxStrings; -end; -{$ENDIF} - -{ TTntDBComboBox } - -function TTntDBComboBox.GetFieldValue: Variant; -begin - Result := GetWideText(Field); -end; - -procedure TTntDBComboBox.SetFieldValue(const Value: Variant); -begin - SetWideText(Field, Value); -end; - -procedure TTntDBComboBox.SetComboValue(const Value: Variant); -var - I: Integer; - Redraw: Boolean; - OldValue: WideString; - NewValue: WideString; -begin - OldValue := VarToWideStr(GetComboValue); - NewValue := VarToWideStr(Value); - - if NewValue <> OldValue then - begin - if Style <> csDropDown then - begin - Redraw := (Style <> csSimple) and HandleAllocated; - if Redraw then Items.BeginUpdate; - try - if NewValue = '' then I := -1 else I := Items.IndexOf(NewValue); - ItemIndex := I; - finally - Items.EndUpdate; - end; - if I >= 0 then Exit; - end; - if Style in [csDropDown, csSimple] then Text := NewValue; - end; -end; - -function TTntDBComboBox.GetComboValue: Variant; -var - I: Integer; -begin - if Style in [csDropDown, csSimple] then Result := Text else - begin - I := ItemIndex; - if I < 0 then Result := '' else Result := Items[I]; - end; -end; - -{ TTntDBCheckBox } - -procedure TTntDBCheckBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'BUTTON'); -end; - -procedure TTntDBCheckBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDBCheckBox.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntDBCheckBox.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntDBCheckBox.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntDBCheckBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntDBCheckBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntDBCheckBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntDBCheckBox.Toggle; -var - FDataLink: TDataLink; -begin - inherited; - FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; - FDataLink.UpdateRecord; -end; - -procedure TTntDBCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntDBCheckBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntDBRichEdit } - -constructor TTntDBRichEdit.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - inherited ReadOnly := True; - FAutoDisplay := True; - FDataLink := TFieldDataLink.Create; - FDataLink.Control := Self; - FDataLink.OnDataChange := DataChange; - FDataLink.OnEditingChange := EditingChange; - FDataLink.OnUpdateData := UpdateData; -end; - -destructor TTntDBRichEdit.Destroy; -begin - FDataLink.Free; - FDataLink := nil; - inherited Destroy; -end; - -procedure TTntDBRichEdit.Loaded; -begin - inherited Loaded; - if (csDesigning in ComponentState) then - DataChange(Self) -end; - -procedure TTntDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (Operation = opRemove) and (FDataLink <> nil) and - (AComponent = DataSource) then DataSource := nil; -end; - -function TTntDBRichEdit.UseRightToLeftAlignment: Boolean; -begin - Result := DBUseRightToLeftAlignment(Self, Field); -end; - -procedure TTntDBRichEdit.BeginEditing; -begin - if not FDataLink.Editing then - try - if FieldIsBlobLike(Field) then - FDataSave := Field.AsString{TNT-ALLOW AsString}; - FDataLink.Edit; - finally - FDataSave := ''; - end; -end; - -procedure TTntDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState); -begin - inherited KeyDown(Key, Shift); - if FMemoLoaded then - begin - if (Key = VK_DELETE) or (Key = VK_BACK) or - ((Key = VK_INSERT) and (ssShift in Shift)) or - (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then - BeginEditing; - end; -end; - -procedure TTntDBRichEdit.KeyPress(var Key: AnsiChar); -begin - inherited KeyPress(Key); - if FMemoLoaded then - begin - if (Key in [#32..#255]) and (Field <> nil) and - not Field.IsValidChar(Key) then - begin - MessageBeep(0); - Key := #0; - end; - case Key of - ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: - BeginEditing; - #27: - FDataLink.Reset; - end; - end else - begin - if Key = #13 then LoadMemo; - Key := #0; - end; -end; - -procedure TTntDBRichEdit.Change; -begin - if FMemoLoaded then - FDataLink.Modified; - FMemoLoaded := True; - inherited Change; -end; - -procedure TTntDBRichEdit.CNNotify(var Message: TWMNotify); -begin - inherited; - if Message.NMHdr^.code = EN_PROTECTED then - Message.Result := 0 { allow the operation (otherwise the control might appear stuck) } -end; - -function TTntDBRichEdit.GetDataSource: TDataSource; -begin - Result := FDataLink.DataSource; -end; - -procedure TTntDBRichEdit.SetDataSource(Value: TDataSource); -begin - FDataLink.DataSource := Value; - if Value <> nil then Value.FreeNotification(Self); -end; - -function TTntDBRichEdit.GetDataField: WideString; -begin - Result := FDataLink.FieldName; -end; - -procedure TTntDBRichEdit.SetDataField(const Value: WideString); -begin - FDataLink.FieldName := Value; -end; - -function TTntDBRichEdit.GetReadOnly: Boolean; -begin - Result := FDataLink.ReadOnly; -end; - -procedure TTntDBRichEdit.SetReadOnly(Value: Boolean); -begin - FDataLink.ReadOnly := Value; -end; - -function TTntDBRichEdit.GetField: TField; -begin - Result := FDataLink.Field; -end; - -procedure TTntDBRichEdit.InternalLoadMemo; -var - Stream: TStringStream{TNT-ALLOW TStringStream}; -begin - if PlainText then - Text := GetAsWideString(Field) - else begin - Stream := TStringStream{TNT-ALLOW TStringStream}.Create(Field.AsString{TNT-ALLOW AsString}); - try - Lines.LoadFromStream(Stream); - finally - Stream.Free; - end; - end; -end; - -procedure TTntDBRichEdit.LoadMemo; -begin - if not FMemoLoaded and Assigned(Field) and FieldIsBlobLike(Field) then - begin - try - InternalLoadMemo; - FMemoLoaded := True; - except - { Rich Edit Load failure } - on E:EOutOfResources do - Lines.Text := WideFormat('(%s)', [E.Message]); - end; - EditingChange(Self); - end; -end; - -procedure TTntDBRichEdit.DataChange(Sender: TObject); -begin - if Field <> nil then - if FieldIsBlobLike(Field) then - begin - if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then - begin - { Check if the data has changed since we read it the first time } - if (FDataSave <> '') and (FDataSave = Field.AsString{TNT-ALLOW AsString}) then Exit; - FMemoLoaded := False; - LoadMemo; - end else - begin - Text := WideFormat('(%s)', [Field.DisplayName]); - FMemoLoaded := False; - end; - end else - begin - if FFocused and FDataLink.CanModify then - Text := GetWideText(Field) - else - Text := GetWideDisplayText(Field); - FMemoLoaded := True; - end - else - begin - if csDesigning in ComponentState then Text := Name else Text := ''; - FMemoLoaded := False; - end; - if HandleAllocated then - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); -end; - -procedure TTntDBRichEdit.EditingChange(Sender: TObject); -begin - inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); -end; - -procedure TTntDBRichEdit.InternalSaveMemo; -var - Stream: TStringStream{TNT-ALLOW TStringStream}; -begin - if PlainText then - SetAsWideString(Field, Text) - else begin - Stream := TStringStream{TNT-ALLOW TStringStream}.Create(''); - try - Lines.SaveToStream(Stream); - Field.AsString{TNT-ALLOW AsString} := Stream.DataString; - finally - Stream.Free; - end; - end; -end; - -procedure TTntDBRichEdit.UpdateData(Sender: TObject); -begin - if FieldIsBlobLike(Field) then - InternalSaveMemo - else - SetAsWideString(Field, Text); -end; - -procedure TTntDBRichEdit.SetFocused(Value: Boolean); -begin - if FFocused <> Value then - begin - FFocused := Value; - if not Assigned(Field) or not FieldIsBlobLike(Field) then - FDataLink.Reset; - end; -end; - -procedure TTntDBRichEdit.CMEnter(var Message: TCMEnter); -begin - SetFocused(True); - inherited; -end; - -procedure TTntDBRichEdit.CMExit(var Message: TCMExit); -begin - try - FDataLink.UpdateRecord; - except - SetFocus; - raise; - end; - SetFocused(False); - inherited; -end; - -procedure TTntDBRichEdit.SetAutoDisplay(Value: Boolean); -begin - if FAutoDisplay <> Value then - begin - FAutoDisplay := Value; - if Value then LoadMemo; - end; -end; - -procedure TTntDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk); -begin - if not FMemoLoaded then LoadMemo else inherited; -end; - -procedure TTntDBRichEdit.WMCut(var Message: TMessage); -begin - BeginEditing; - inherited; -end; - -procedure TTntDBRichEdit.WMPaste(var Message: TMessage); -begin - BeginEditing; - inherited; -end; - -procedure TTntDBRichEdit.CMGetDataLink(var Message: TMessage); -begin - Message.Result := Integer(FDataLink); -end; - -function TTntDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean; -begin - Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and - FDataLink.ExecuteAction(Action); -end; - -function TTntDBRichEdit.UpdateAction(Action: TBasicAction): Boolean; -begin - Result := inherited UpdateAction(Action) or (FDataLink <> nil) and - FDataLink.UpdateAction(Action); -end; - -{ TTntDBMemo } - -constructor TTntDBMemo.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - inherited ReadOnly := True; - ControlStyle := ControlStyle + [csReplicatable]; - FAutoDisplay := True; - FDataLink := TFieldDataLink.Create; - FDataLink.Control := Self; - FDataLink.OnDataChange := DataChange; - FDataLink.OnEditingChange := EditingChange; - FDataLink.OnUpdateData := UpdateData; - FPaintControl := TTntPaintControl.Create(Self, 'EDIT'); -end; - -destructor TTntDBMemo.Destroy; -begin - FPaintControl.Free; - FDataLink.Free; - FDataLink := nil; - inherited Destroy; -end; - -procedure TTntDBMemo.Loaded; -begin - inherited Loaded; - if (csDesigning in ComponentState) then DataChange(Self); -end; - -procedure TTntDBMemo.Notification(AComponent: TComponent; - Operation: TOperation); -begin - inherited Notification(AComponent, Operation); - if (Operation = opRemove) and (FDataLink <> nil) and - (AComponent = DataSource) then DataSource := nil; -end; - -function TTntDBMemo.UseRightToLeftAlignment: Boolean; -begin - Result := DBUseRightToLeftAlignment(Self, Field); -end; - -procedure TTntDBMemo.KeyDown(var Key: Word; Shift: TShiftState); -begin - inherited KeyDown(Key, Shift); - if FMemoLoaded then - begin - if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then - FDataLink.Edit; - end; -end; - -procedure TTntDBMemo.KeyPress(var Key: Char{TNT-ALLOW Char}); -begin - inherited KeyPress(Key); - if FMemoLoaded then - begin - if (Key in [#32..#255]) and (FDataLink.Field <> nil) and - not FDataLink.Field.IsValidChar(Key) then - begin - MessageBeep(0); - Key := #0; - end; - case Key of - ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: - FDataLink.Edit; - #27: - FDataLink.Reset; - end; - end else - begin - if Key = #13 then LoadMemo; - Key := #0; - end; -end; - -procedure TTntDBMemo.Change; -begin - if FMemoLoaded then FDataLink.Modified; - FMemoLoaded := True; - inherited Change; -end; - -function TTntDBMemo.GetDataSource: TDataSource; -begin - Result := FDataLink.DataSource; -end; - -procedure TTntDBMemo.SetDataSource(Value: TDataSource); -begin - if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then - FDataLink.DataSource := Value; - if Value <> nil then Value.FreeNotification(Self); -end; - -function TTntDBMemo.GetDataField: WideString; -begin - Result := FDataLink.FieldName; -end; - -procedure TTntDBMemo.SetDataField(const Value: WideString); -begin - FDataLink.FieldName := Value; -end; - -function TTntDBMemo.GetReadOnly: Boolean; -begin - Result := FDataLink.ReadOnly; -end; - -procedure TTntDBMemo.SetReadOnly(Value: Boolean); -begin - FDataLink.ReadOnly := Value; -end; - -function TTntDBMemo.GetField: TField; -begin - Result := FDataLink.Field; -end; - -procedure TTntDBMemo.LoadMemo; -begin - if not FMemoLoaded and Assigned(FDataLink.Field) and FieldIsBlobLike(FDataLink.Field) then - begin - try - Lines.Text := GetAsWideString(FDataLink.Field); - FMemoLoaded := True; - except - { Memo too large } - on E:EInvalidOperation do - Lines.Text := WideFormat('(%s)', [E.Message]); - end; - EditingChange(Self); - end; -end; - -procedure TTntDBMemo.DataChange(Sender: TObject); -begin - if FDataLink.Field <> nil then - if FieldIsBlobLike(FDataLink.Field) then - begin - if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then - begin - FMemoLoaded := False; - LoadMemo; - end else - begin - Text := WideFormat('(%s)', [FDataLink.Field.DisplayName]); - FMemoLoaded := False; - EditingChange(Self); - end; - end else - begin - if FFocused and FDataLink.CanModify then - Text := GetWideText(FDataLink.Field) - else - Text := GetWideDisplayText(FDataLink.Field); - FMemoLoaded := True; - end - else - begin - if csDesigning in ComponentState then Text := Name else Text := ''; - FMemoLoaded := False; - end; - if HandleAllocated then - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); -end; - -procedure TTntDBMemo.EditingChange(Sender: TObject); -begin - inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); -end; - -procedure TTntDBMemo.UpdateData(Sender: TObject); -begin - SetAsWideString(FDataLink.Field, Text); -end; - -procedure TTntDBMemo.SetFocused(Value: Boolean); -begin - if FFocused <> Value then - begin - FFocused := Value; - if not Assigned(FDataLink.Field) or not FieldIsBlobLike(FDataLink.Field) then - FDataLink.Reset; - end; -end; - -procedure TTntDBMemo.WndProc(var Message: TMessage); -begin - with Message do - if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or - (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle; - inherited; -end; - -procedure TTntDBMemo.CMEnter(var Message: TCMEnter); -begin - SetFocused(True); - inherited; -end; - -procedure TTntDBMemo.CMExit(var Message: TCMExit); -begin - try - FDataLink.UpdateRecord; - except - SetFocus; - raise; - end; - SetFocused(False); - inherited; -end; - -procedure TTntDBMemo.SetAutoDisplay(Value: Boolean); -begin - if FAutoDisplay <> Value then - begin - FAutoDisplay := Value; - if Value then LoadMemo; - end; -end; - -procedure TTntDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk); -begin - if not FMemoLoaded then LoadMemo else inherited; -end; - -procedure TTntDBMemo.WMCut(var Message: TMessage); -begin - FDataLink.Edit; - inherited; -end; - -procedure TTntDBMemo.WMUndo(var Message: TMessage); -begin - FDataLink.Edit; - inherited; -end; - -procedure TTntDBMemo.WMPaste(var Message: TMessage); -begin - FDataLink.Edit; - inherited; -end; - -procedure TTntDBMemo.CMGetDataLink(var Message: TMessage); -begin - Message.Result := Integer(FDataLink); -end; - -procedure TTntDBMemo.WMPaint(var Message: TWMPaint); -var - S: WideString; -begin - if not (csPaintCopy in ControlState) then - inherited - else begin - if FDataLink.Field <> nil then - if FieldIsBlobLike(FDataLink.Field) then - begin - if FAutoDisplay then - S := TntAdjustLineBreaks(GetAsWideString(FDataLink.Field)) else - S := WideFormat('(%s)', [FDataLink.Field.DisplayName]); - end else - S := GetWideDisplayText(FDataLink.Field); - if (not Win32PlatformIsUnicode) then - SendMessageA(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PAnsiChar(AnsiString(S)))) - else begin - SendMessageW(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PWideChar(S))); - end; - SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Integer(Message.DC), 0); - SendMessage(FPaintControl.Handle, WM_PAINT, Integer(Message.DC), 0); - end; -end; - -function TTntDBMemo.ExecuteAction(Action: TBasicAction): Boolean; -begin - Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and - FDataLink.ExecuteAction(Action); -end; - -function TTntDBMemo.UpdateAction(Action: TBasicAction): Boolean; -begin - Result := inherited UpdateAction(Action) or (FDataLink <> nil) and - FDataLink.UpdateAction(Action); -end; - -{ TTntDBRadioGroup } - -constructor TTntDBRadioGroup.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FDataLink := TFieldDataLink.Create; - FDataLink.Control := Self; - FDataLink.OnDataChange := DataChange; - FDataLink.OnUpdateData := UpdateData; - FValues := TTntStringList.Create; -end; - -destructor TTntDBRadioGroup.Destroy; -begin - FDataLink.Free; - FDataLink := nil; - FValues.Free; - inherited Destroy; -end; - -procedure TTntDBRadioGroup.Notification(AComponent: TComponent; - Operation: TOperation); -begin - inherited Notification(AComponent, Operation); - if (Operation = opRemove) and (FDataLink <> nil) and - (AComponent = DataSource) then DataSource := nil; -end; - -function TTntDBRadioGroup.UseRightToLeftAlignment: Boolean; -begin - Result := inherited UseRightToLeftAlignment; -end; - -procedure TTntDBRadioGroup.DataChange(Sender: TObject); -begin - if FDataLink.Field <> nil then - Value := GetWideText(FDataLink.Field) else - Value := ''; -end; - -procedure TTntDBRadioGroup.UpdateData(Sender: TObject); -begin - if FDataLink.Field <> nil then - SetWideText(FDataLink.Field, Value); -end; - -function TTntDBRadioGroup.GetDataSource: TDataSource; -begin - Result := FDataLink.DataSource; -end; - -procedure TTntDBRadioGroup.SetDataSource(Value: TDataSource); -begin - FDataLink.DataSource := Value; - if Value <> nil then Value.FreeNotification(Self); -end; - -function TTntDBRadioGroup.GetDataField: WideString; -begin - Result := FDataLink.FieldName; -end; - -procedure TTntDBRadioGroup.SetDataField(const Value: WideString); -begin - FDataLink.FieldName := Value; -end; - -function TTntDBRadioGroup.GetReadOnly: Boolean; -begin - Result := FDataLink.ReadOnly; -end; - -procedure TTntDBRadioGroup.SetReadOnly(Value: Boolean); -begin - FDataLink.ReadOnly := Value; -end; - -function TTntDBRadioGroup.GetField: TField; -begin - Result := FDataLink.Field; -end; - -function TTntDBRadioGroup.GetButtonValue(Index: Integer): WideString; -begin - if (Index < FValues.Count) and (FValues[Index] <> '') then - Result := FValues[Index] - else if Index < Items.Count then - Result := Items[Index] - else - Result := ''; -end; - -procedure TTntDBRadioGroup.SetValue(const Value: WideString); -var - WasFocused: Boolean; - I, Index: Integer; -begin - if FValue <> Value then - begin - FInSetValue := True; - try - WasFocused := (ItemIndex > -1) and (Buttons[ItemIndex].Focused); - Index := -1; - for I := 0 to Items.Count - 1 do - if Value = GetButtonValue(I) then - begin - Index := I; - Break; - end; - ItemIndex := Index; - // Move the focus rect along with the selected index - if WasFocused then - Buttons[ItemIndex].SetFocus; - finally - FInSetValue := False; - end; - FValue := Value; - Change; - end; -end; - -procedure TTntDBRadioGroup.CMExit(var Message: TCMExit); -begin - try - FDataLink.UpdateRecord; - except - if ItemIndex >= 0 then - (Controls[ItemIndex] as TTntRadioButton).SetFocus else - (Controls[0] as TTntRadioButton).SetFocus; - raise; - end; - inherited; -end; - -procedure TTntDBRadioGroup.CMGetDataLink(var Message: TMessage); -begin - Message.Result := Integer(FDataLink); -end; - -procedure TTntDBRadioGroup.Click; -begin - if not FInSetValue then - begin - inherited Click; - if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex); - if FDataLink.Editing then FDataLink.Modified; - end; -end; - -procedure TTntDBRadioGroup.SetItems(Value: TTntStrings); -begin - Items.Assign(Value); - DataChange(Self); -end; - -procedure TTntDBRadioGroup.SetValues(Value: TTntStrings); -begin - FValues.Assign(Value); - DataChange(Self); -end; - -procedure TTntDBRadioGroup.Change; -begin - if Assigned(FOnChange) then FOnChange(Self); -end; - -procedure TTntDBRadioGroup.KeyPress(var Key: Char{TNT-ALLOW Char}); -begin - inherited KeyPress(Key); - case Key of - #8, ' ': FDataLink.Edit; - #27: FDataLink.Reset; - end; -end; - -function TTntDBRadioGroup.CanModify: Boolean; -begin - Result := FDataLink.Edit; -end; - -function TTntDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean; -begin - Result := inherited ExecuteAction(Action) or (DataLink <> nil) and - DataLink.ExecuteAction(Action); -end; - -function TTntDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean; -begin - Result := inherited UpdateAction(Action) or (DataLink <> nil) and - DataLink.UpdateAction(Action); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas deleted file mode 100644 index 2664bf7b5a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas +++ /dev/null @@ -1,1175 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDBGrids; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, TntClasses, Controls, Windows, Grids, DBGrids, Messages, DBCtrls, DB, TntStdCtrls; - -type -{TNT-WARN TColumnTitle} - TTntColumnTitle = class(TColumnTitle{TNT-ALLOW TColumnTitle}) - private - FCaption: WideString; - procedure SetInheritedCaption(const Value: AnsiString); - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function IsCaptionStored: Boolean; - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - procedure RestoreDefaults; override; - function DefaultCaption: WideString; - published - property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; - end; - -{TNT-WARN TColumn} -type - TTntColumn = class(TColumn{TNT-ALLOW TColumn}) - private - FWidePickList: TTntStrings; - function GetWidePickList: TTntStrings; - procedure SetWidePickList(const Value: TTntStrings); - procedure HandlePickListChange(Sender: TObject); - function GetTitle: TTntColumnTitle; - procedure SetTitle(const Value: TTntColumnTitle); - protected - procedure DefineProperties(Filer: TFiler); override; - function CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; override; - public - destructor Destroy; override; - property WidePickList: TTntStrings read GetWidePickList write SetWidePickList; - published -{TNT-WARN PickList} - property PickList{TNT-ALLOW PickList}: TTntStrings read GetWidePickList write SetWidePickList; - property Title: TTntColumnTitle read GetTitle write SetTitle; - end; - - { TDBGridInplaceEdit adds support for a button on the in-place editor, - which can be used to drop down a table-based lookup list, a stringlist-based - pick list, or (if button style is esEllipsis) fire the grid event - OnEditButtonClick. } - -type - TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit} = class(TInplaceEditList) - private - {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - FDataList: TDBLookupListBox; // 1st field - Delphi/BCB 6 TCustomDBGrid assumes this - FUseDataList: Boolean; // 2nd field - Delphi/BCB 6 TCustomDBGrid assumes this - {$ENDIF} - {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - FDataList: TDBLookupListBox; // 1st field - Delphi 7 TCustomDBGrid assumes this - FUseDataList: Boolean; // 2nd field - Delphi 7 TCustomDBGrid assumes this - {$ENDIF} - {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - FDataList: TDBLookupListBox; // 1st field - Delphi 9 TCustomDBGrid assumes this - FUseDataList: Boolean; // 2nd field - Delphi 9 TCustomDBGrid assumes this - {$ENDIF} - {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - FDataList: TDBLookupListBox; // 1st field - Delphi 10 TCustomDBGrid assumes this - FUseDataList: Boolean; // 2nd field - Delphi 10 TCustomDBGrid assumes this - {$ENDIF} - FLookupSource: TDatasource; - FWidePickListBox: TTntCustomListbox; - function GetWidePickListBox: TTntCustomListbox; - protected - procedure CloseUp(Accept: Boolean); override; - procedure DoEditButtonClick; override; - procedure DropDown; override; - procedure UpdateContents; override; - property UseDataList: Boolean read FUseDataList; - public - constructor Create(Owner: TComponent); override; - property DataList: TDBLookupListBox read FDataList; - property WidePickListBox: TTntCustomListbox read GetWidePickListBox; - end; - -type -{TNT-WARN TDBGridInplaceEdit} - TTntDBGridInplaceEdit = class(TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}) - private - FInDblClick: Boolean; - FBlockSetText: Boolean; - procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; - protected - function GetText: WideString; virtual; - procedure SetText(const Value: WideString); virtual; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure UpdateContents; override; - procedure DblClick; override; - public - property Text: WideString read GetText write SetText; - end; - -{TNT-WARN TDBGridColumns} - TTntDBGridColumns = class(TDBGridColumns{TNT-ALLOW TDBGridColumns}) - private - function GetColumn(Index: Integer): TTntColumn; - procedure SetColumn(Index: Integer; const Value: TTntColumn); - public - function Add: TTntColumn; - property Items[Index: Integer]: TTntColumn read GetColumn write SetColumn; default; - end; - - TTntGridDataLink = class(TGridDataLink) - private - OriginalSetText: TFieldSetTextEvent; - procedure GridUpdateFieldText(Sender: TField; const Text: AnsiString); - protected - procedure UpdateData; override; - procedure RecordChanged(Field: TField); override; - end; - -{TNT-WARN TCustomDBGrid} - TTntCustomDBGrid = class(TCustomDBGrid{TNT-ALLOW TCustomDBGrid}) - private - FEditText: WideString; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMChar(var Msg: TWMChar); message WM_CHAR; - function GetColumns: TTntDBGridColumns; - procedure SetColumns(const Value: TTntDBGridColumns); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure ShowEditorChar(Ch: WideChar); dynamic; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; override; - property Columns: TTntDBGridColumns read GetColumns write SetColumns; - function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; - function CreateDataLink: TGridDataLink; override; - function GetEditText(ACol, ARow: Longint): WideString; reintroduce; - procedure DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); override; - procedure SetEditText(ACol, ARow: Longint; const Value: AnsiString); override; - public - procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer; - Column: TTntColumn; State: TGridDrawState); dynamic; - procedure DefaultDrawDataCell(const Rect: TRect; Field: TField; - State: TGridDrawState); - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TDBGrid} - TTntDBGrid = class(TTntCustomDBGrid) - public - property Canvas; - property SelectedRows; - published - property Align; - property Anchors; - property BiDiMode; - property BorderStyle; - property Color; - property Columns stored False; //StoreColumns; - property Constraints; - property Ctl3D; - property DataSource; - property DefaultDrawing; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property FixedColor; - property Font; - property ImeMode; - property ImeName; - property Options; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ReadOnly; - property ShowHint; - property TabOrder; - property TabStop; - property TitleFont; - property Visible; - property OnCellClick; - property OnColEnter; - property OnColExit; - property OnColumnMoved; - property OnDrawDataCell; { obsolete } - property OnDrawColumnCell; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEditButtonClick; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnMouseWheelDown; - property OnMouseWheelUp; - property OnStartDock; - property OnStartDrag; - property OnTitleClick; - end; - -implementation - -uses - SysUtils, TntControls, Math, Variants, Forms, - TntGraphics, Graphics, TntDB, TntActnList, TntSysUtils, TntWindows; - -{ TTntColumnTitle } - -procedure TTntColumnTitle.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntColumnTitle.DefaultCaption: WideString; -var - Field: TField; -begin - Field := Column.Field; - if Assigned(Field) then - Result := Field.DisplayName - else - Result := Column.FieldName; -end; - -function TTntColumnTitle.IsCaptionStored: Boolean; -begin - Result := (cvTitleCaption in Column.AssignedValues) and - (FCaption <> DefaultCaption); -end; - -procedure TTntColumnTitle.SetInheritedCaption(const Value: AnsiString); -begin - inherited Caption := Value; -end; - -function TTntColumnTitle.GetCaption: WideString; -begin - if cvTitleCaption in Column.AssignedValues then - Result := GetSyncedWideString(FCaption, inherited Caption) - else - Result := DefaultCaption; -end; - -procedure TTntColumnTitle.SetCaption(const Value: WideString); -begin - if not (Column as TTntColumn).IsStored then - inherited Caption := Value - else begin - if (cvTitleCaption in Column.AssignedValues) and (Value = FCaption) then Exit; - SetSyncedWideString(Value, FCaption, inherited Caption, SetInheritedCaption); - end; -end; - -procedure TTntColumnTitle.Assign(Source: TPersistent); -begin - inherited Assign(Source); - if Source is TTntColumnTitle then - begin - if cvTitleCaption in TTntColumnTitle(Source).Column.AssignedValues then - Caption := TTntColumnTitle(Source).Caption; - end; -end; - -procedure TTntColumnTitle.RestoreDefaults; -begin - FCaption := ''; - inherited; -end; - -{ TTntColumn } - -procedure TTntColumn.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntColumn.CreateTitle: TColumnTitle{TNT-ALLOW TColumnTitle}; -begin - Result := TTntColumnTitle.Create(Self); -end; - -function TTntColumn.GetTitle: TTntColumnTitle; -begin - Result := (inherited Title) as TTntColumnTitle; -end; - -procedure TTntColumn.SetTitle(const Value: TTntColumnTitle); -begin - inherited Title := Value; -end; - -function TTntColumn.GetWidePickList: TTntStrings; -begin - if FWidePickList = nil then begin - FWidePickList := TTntStringList.Create; - TTntStringList(FWidePickList).OnChange := HandlePickListChange; - end; - Result := FWidePickList; -end; - -procedure TTntColumn.SetWidePickList(const Value: TTntStrings); -begin - if Value = nil then - begin - FWidePickList.Free; - FWidePickList := nil; - (inherited PickList{TNT-ALLOW PickList}).Clear; - Exit; - end; - WidePickList.Assign(Value); -end; - -procedure TTntColumn.HandlePickListChange(Sender: TObject); -begin - inherited PickList{TNT-ALLOW PickList}.Assign(WidePickList); -end; - -destructor TTntColumn.Destroy; -begin - inherited; - FWidePickList.Free; -end; - -{ TTntPopupListbox } -type - TTntPopupListbox = class(TTntCustomListbox) - private - FSearchText: WideString; - FSearchTickCount: Longint; - protected - procedure CreateParams(var Params: TCreateParams); override; - procedure CreateWnd; override; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - procedure KeyPressW(var Key: WideChar); - procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; - end; - -procedure TTntPopupListbox.CreateParams(var Params: TCreateParams); -begin - inherited CreateParams(Params); - with Params do - begin - Style := Style or WS_BORDER; - ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST; - AddBiDiModeExStyle(ExStyle); - WindowClass.Style := CS_SAVEBITS; - end; -end; - -procedure TTntPopupListbox.CreateWnd; -begin - inherited CreateWnd; - Windows.SetParent(Handle, 0); - CallWindowProc(DefWndProc, Handle, wm_SetFocus, 0, 0); -end; - -procedure TTntPopupListbox.WMChar(var Message: TWMChar); -var - Key: WideChar; -begin - Key := GetWideCharFromWMCharMsg(Message); - KeyPressW(Key); - SetWideCharForWMCharMsg(Message, Key); - inherited; -end; - -procedure TTntPopupListbox.KeypressW(var Key: WideChar); -var - TickCount: Integer; -begin - case Key of - #8, #27: FSearchText := ''; - #32..High(WideChar): - begin - TickCount := GetTickCount; - if TickCount - FSearchTickCount > 2000 then FSearchText := ''; - FSearchTickCount := TickCount; - if Length(FSearchText) < 32 then FSearchText := FSearchText + Key; - if IsWindowUnicode(Handle) then - SendMessageW(Handle, LB_SelectString, WORD(-1), Longint(PWideChar(FSearchText))) - else - SendMessageA(Handle, LB_SelectString, WORD(-1), Longint(PAnsiChar(AnsiString(FSearchText)))); - Key := #0; - end; - end; -end; - -procedure TTntPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; - X, Y: Integer); -begin - inherited MouseUp(Button, Shift, X, Y); - (Owner as TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}).CloseUp((X >= 0) and (Y >= 0) and - (X < Width) and (Y < Height)); -end; - -{ TTntPopupDataList } -type - TTntPopupDataList = class(TPopupDataList) - protected - procedure Paint; override; - end; - -procedure TTntPopupDataList.Paint; -var - FRecordIndex: Integer; - FRecordCount: Integer; - FKeySelected: Boolean; - FKeyField: TField; - - procedure UpdateListVars; - begin - if ListActive then - begin - FRecordIndex := ListLink.ActiveRecord; - FRecordCount := ListLink.RecordCount; - FKeySelected := not VarIsNull(KeyValue) or - not ListLink.DataSet.BOF; - end else - begin - FRecordIndex := 0; - FRecordCount := 0; - FKeySelected := False; - end; - - FKeyField := nil; - if ListLink.Active and (KeyField <> '') then - FKeyField := GetFieldProperty(ListLink.DataSet, Self, KeyField); - end; - - function VarEquals(const V1, V2: Variant): Boolean; - begin - Result := False; - try - Result := V1 = V2; - except - end; - end; - -var - I, J, W, X, TxtWidth, TxtHeight, LastFieldIndex: Integer; - S: WideString; - R: TRect; - Selected: Boolean; - Field: TField; - AAlignment: TAlignment; -begin - UpdateListVars; - Canvas.Font := Font; - TxtWidth := WideCanvasTextWidth(Canvas, '0'); - TxtHeight := WideCanvasTextHeight(Canvas, '0'); - LastFieldIndex := ListFields.Count - 1; - if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then - Canvas.Pen.Color := clBtnFace else - Canvas.Pen.Color := clBtnShadow; - for I := 0 to RowCount - 1 do - begin - if Enabled then - Canvas.Font.Color := Font.Color else - Canvas.Font.Color := clGrayText; - Canvas.Brush.Color := Color; - Selected := not FKeySelected and (I = 0); - R.Top := I * TxtHeight; - R.Bottom := R.Top + TxtHeight; - if I < FRecordCount then - begin - ListLink.ActiveRecord := I; - if not VarIsNull(KeyValue) and - VarEquals(FKeyField.Value, KeyValue) then - begin - Canvas.Font.Color := clHighlightText; - Canvas.Brush.Color := clHighlight; - Selected := True; - end; - R.Right := 0; - for J := 0 to LastFieldIndex do - begin - Field := ListFields[J]; - if J < LastFieldIndex then - W := Field.DisplayWidth * TxtWidth + 4 else - W := ClientWidth - R.Right; - S := GetWideDisplayText(Field); - X := 2; - AAlignment := Field.Alignment; - if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); - case AAlignment of - taRightJustify: X := W - WideCanvasTextWidth(Canvas, S) - 3; - taCenter: X := (W - WideCanvasTextWidth(Canvas, S)) div 2; - end; - R.Left := R.Right; - R.Right := R.Right + W; - if SysLocale.MiddleEast then TControlCanvas(Canvas).UpdateTextFlags; - WideCanvasTextRect(Canvas, R, R.Left + X, R.Top, S); - if J < LastFieldIndex then - begin - Canvas.MoveTo(R.Right, R.Top); - Canvas.LineTo(R.Right, R.Bottom); - Inc(R.Right); - if R.Right >= ClientWidth then Break; - end; - end; - end; - R.Left := 0; - R.Right := ClientWidth; - if I >= FRecordCount then Canvas.FillRect(R); - if Selected then - Canvas.DrawFocusRect(R); - end; - if FRecordCount <> 0 then ListLink.ActiveRecord := FRecordIndex; -end; - -//----------------------------------------------------------------------------------------- -// TDBGridInplaceEdit - Delphi 6 and higher -//----------------------------------------------------------------------------------------- - -constructor TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.Create(Owner: TComponent); -begin - inherited Create(Owner); - FLookupSource := TDataSource.Create(Self); -end; - -function TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.GetWidePickListBox: TTntCustomListBox; -var - PopupListbox: TTntPopupListbox; -begin - if not Assigned(FWidePickListBox) then - begin - PopupListbox := TTntPopupListbox.Create(Self); - PopupListbox.Visible := False; - PopupListbox.Parent := Self; - PopupListbox.OnMouseUp := ListMouseUp; - PopupListbox.IntegralHeight := True; - PopupListbox.ItemHeight := 11; - FWidePickListBox := PopupListBox; - end; - Result := FWidePickListBox; -end; - -procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.CloseUp(Accept: Boolean); -var - MasterField: TField; - ListValue: Variant; -begin - if ListVisible then - begin - if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0); - if ActiveList = DataList then - ListValue := DataList.KeyValue - else - if WidePickListBox.ItemIndex <> -1 then - ListValue := WidePickListBox.Items[WidePickListBox.ItemIndex]; - SetWindowPos(ActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or - SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW); - ListVisible := False; - if Assigned(FDataList) then - FDataList.ListSource := nil; - FLookupSource.Dataset := nil; - Invalidate; - if Accept then - if ActiveList = DataList then - with Grid as TTntCustomDBGrid, Columns[SelectedIndex].Field do - begin - MasterField := DataSet.FieldByName(KeyFields); - if MasterField.CanModify and DataLink.Edit then - MasterField.Value := ListValue; - end - else - if (not VarIsNull(ListValue)) and EditCanModify then - with Grid as TTntCustomDBGrid do - SetWideText(Columns[SelectedIndex].Field, ListValue) - end; -end; - -procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DoEditButtonClick; -begin - (Grid as TTntCustomDBGrid).EditButtonClick; -end; - -type TAccessTntCustomListbox = class(TTntCustomListbox); - -procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.DropDown; -var - Column: TTntColumn; - I, J, Y: Integer; -begin - if not ListVisible then - begin - with (Grid as TTntCustomDBGrid) do - Column := Columns[SelectedIndex] as TTntColumn; - if ActiveList = FDataList then - with Column.Field do - begin - FDataList.Color := Color; - FDataList.Font := Font; - FDataList.RowCount := Column.DropDownRows; - FLookupSource.DataSet := LookupDataSet; - FDataList.KeyField := LookupKeyFields; - FDataList.ListField := LookupResultField; - FDataList.ListSource := FLookupSource; - FDataList.KeyValue := DataSet.FieldByName(KeyFields).Value; - end - else if ActiveList = WidePickListBox then - begin - WidePickListBox.Items.Assign(Column.WidePickList); - DropDownRows := Column.DropDownRows; - // this is needed as inherited doesn't know about our WidePickListBox - if (DropDownRows > 0) and (WidePickListBox.Items.Count >= DropDownRows) then - WidePickListBox.Height := DropDownRows * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4 - else - WidePickListBox.Height := WidePickListBox.Items.Count * TAccessTntCustomListbox(WidePickListBox as TTntCustomListbox).ItemHeight + 4; - if Text = '' then - WidePickListBox.ItemIndex := -1 - else - WidePickListBox.ItemIndex := WidePickListBox.Items.IndexOf(Text); - J := WidePickListBox.ClientWidth; - for I := 0 to WidePickListBox.Items.Count - 1 do - begin - Y := WideCanvasTextWidth(WidePickListBox.Canvas, WidePickListBox.Items[I]); - if Y > J then J := Y; - end; - WidePickListBox.ClientWidth := J; - end; - end; - inherited DropDown; -end; - -procedure TDBGridInplaceEdit{TNT-ALLOW TDBGridInplaceEdit}.UpdateContents; -var - Column: TTntColumn; -begin - inherited UpdateContents; - if EditStyle = esPickList then - ActiveList := WidePickListBox; - if FUseDataList then - begin - if FDataList = nil then - begin - FDataList := TTntPopupDataList.Create(Self); - FDataList.Visible := False; - FDataList.Parent := Self; - FDataList.OnMouseUp := ListMouseUp; - end; - ActiveList := FDataList; - end; - with (Grid as TTntCustomDBGrid) do - Column := Columns[SelectedIndex] as TTntColumn; - Self.ReadOnly := Column.ReadOnly; - Font.Assign(Column.Font); - ImeMode := Column.ImeMode; - ImeName := Column.ImeName; -end; - -//----------------------------------------------------------------------------------------- - -{ TTntDBGridInplaceEdit } - -procedure TTntDBGridInplaceEdit.CreateWindowHandle(const Params: TCreateParams); -begin - TntCustomEdit_CreateWindowHandle(Self, Params); -end; - -function TTntDBGridInplaceEdit.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntDBGridInplaceEdit.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntDBGridInplaceEdit.WMSetText(var Message: TWMSetText); -begin - if (not FBlockSetText) then - inherited; -end; - -procedure TTntDBGridInplaceEdit.UpdateContents; -var - Grid: TTntCustomDBGrid; -begin - Grid := Self.Grid as TTntCustomDBGrid; - EditMask := Grid.GetEditMask(Grid.Col, Grid.Row); - Text := Grid.GetEditText(Grid.Col, Grid.Row); - MaxLength := Grid.GetEditLimit; - - FBlockSetText := True; - try - inherited; - finally - FBlockSetText := False; - end; -end; - -procedure TTntDBGridInplaceEdit.DblClick; -begin - FInDblClick := True; - try - inherited; - finally - FInDblClick := False; - end; -end; - -{ TTntGridDataLink } - -procedure TTntGridDataLink.GridUpdateFieldText(Sender: TField; const Text: AnsiString); -begin - Sender.OnSetText := OriginalSetText; - if Assigned(Sender) then - SetWideText(Sender, (Grid as TTntCustomDBGrid).FEditText); -end; - -procedure TTntGridDataLink.RecordChanged(Field: TField); -var - CField: TField; -begin - inherited; - if Grid.HandleAllocated then begin - CField := Grid.SelectedField; - if ((Field = nil) or (CField = Field)) and - (Assigned(CField) and (GetWideText(CField) <> (Grid as TTntCustomDBGrid).FEditText)) then - begin - with (Grid as TTntCustomDBGrid) do begin - InvalidateEditor; - if InplaceEditor <> nil then InplaceEditor.Deselect; - end; - end; - end; -end; - -procedure TTntGridDataLink.UpdateData; -var - Field: TField; -begin - Field := (Grid as TTntCustomDBGrid).SelectedField; - // remember "set text" - if Field <> nil then - OriginalSetText := Field.OnSetText; - try - // redirect "set text" to self - if Field <> nil then - Field.OnSetText := GridUpdateFieldText; - inherited; // clear modified ! - finally - // redirect "set text" to field - if Field <> nil then - Field.OnSetText := OriginalSetText; - // forget original "set text" - OriginalSetText := nil; - end; -end; - -{ TTntDBGridColumns } - -function TTntDBGridColumns.Add: TTntColumn; -begin - Result := inherited Add as TTntColumn; -end; - -function TTntDBGridColumns.GetColumn(Index: Integer): TTntColumn; -begin - Result := inherited Items[Index] as TTntColumn; -end; - -procedure TTntDBGridColumns.SetColumn(Index: Integer; const Value: TTntColumn); -begin - inherited Items[Index] := Value; -end; - -{ TTntCustomDBGrid } - -procedure TTntCustomDBGrid.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -type TAccessCustomGrid = class(TCustomGrid); - -procedure TTntCustomDBGrid.WMChar(var Msg: TWMChar); -begin - if (goEditing in TAccessCustomGrid(Self).Options) - and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin - RestoreWMCharMsg(TMessage(Msg)); - ShowEditorChar(WideChar(Msg.CharCode)); - end else - inherited; -end; - -procedure TTntCustomDBGrid.ShowEditorChar(Ch: WideChar); -begin - ShowEditor; - if InplaceEditor <> nil then begin - if Win32PlatformIsUnicode then - PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) - else - PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); - end; -end; - -procedure TTntCustomDBGrid.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomDBGrid.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomDBGrid.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomDBGrid.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntCustomDBGrid.CreateColumns: TDBGridColumns{TNT-ALLOW TDBGridColumns}; -begin - Result := TTntDBGridColumns.Create(Self, TTntColumn); -end; - -function TTntCustomDBGrid.GetColumns: TTntDBGridColumns; -begin - Result := inherited Columns as TTntDBGridColumns; -end; - -procedure TTntCustomDBGrid.SetColumns(const Value: TTntDBGridColumns); -begin - inherited Columns := Value; -end; - -function TTntCustomDBGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; -begin - Result := TTntDBGridInplaceEdit.Create(Self); -end; - -function TTntCustomDBGrid.CreateDataLink: TGridDataLink; -begin - Result := TTntGridDataLink.Create(Self); -end; - -function TTntCustomDBGrid.GetEditText(ACol, ARow: Integer): WideString; -var - Field: TField; -begin - Field := GetColField(RawToDataColumn(ACol)); - if Field = nil then - Result := '' - else - Result := GetWideText(Field); - FEditText := Result; -end; - -procedure TTntCustomDBGrid.SetEditText(ACol, ARow: Integer; const Value: AnsiString); -begin - if (InplaceEditor as TTntDBGridInplaceEdit).FInDblClick then - FEditText := Value - else - FEditText := (InplaceEditor as TTntDBGridInplaceEdit).Text; - inherited; -end; - -//----------------- DRAW CELL PROCS -------------------------------------------------- -var - DrawBitmap: TBitmap = nil; - -procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; - const Text: WideString; Alignment: TAlignment; ARightToLeft: Boolean); -const - AlignFlags : array [TAlignment] of Integer = - ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, - DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, - DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX ); - RTL: array [Boolean] of Integer = (0, DT_RTLREADING); -var - B, R: TRect; - Hold, Left: Integer; - I: TColorRef; -begin - I := ColorToRGB(ACanvas.Brush.Color); - if GetNearestColor(ACanvas.Handle, I) = I then - begin { Use ExtTextOutW for solid colors } - { In BiDi, because we changed the window origin, the text that does not - change alignment, actually gets its alignment changed. } - if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then - ChangeBiDiModeAlignment(Alignment); - case Alignment of - taLeftJustify: - Left := ARect.Left + DX; - taRightJustify: - Left := ARect.Right - WideCanvasTextWidth(ACanvas, Text) - 3; - else { taCenter } - Left := ARect.Left + (ARect.Right - ARect.Left) div 2 - - (WideCanvasTextWidth(ACanvas, Text) div 2); - end; - WideCanvasTextRect(ACanvas, ARect, Left, ARect.Top + DY, Text); - end - else begin { Use FillRect and Drawtext for dithered colors } - DrawBitmap.Canvas.Lock; - try - with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and } - begin { brush origin tics in painting / scrolling. } - Width := Max(Width, Right - Left); - Height := Max(Height, Bottom - Top); - R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1); - B := Rect(0, 0, Right - Left, Bottom - Top); - end; - with DrawBitmap.Canvas do - begin - Font := ACanvas.Font; - Font.Color := ACanvas.Font.Color; - Brush := ACanvas.Brush; - Brush.Style := bsSolid; - FillRect(B); - SetBkMode(Handle, TRANSPARENT); - if (ACanvas.CanvasOrientation = coRightToLeft) then - ChangeBiDiModeAlignment(Alignment); - Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), R, - AlignFlags[Alignment] or RTL[ARightToLeft]); - end; - if (ACanvas.CanvasOrientation = coRightToLeft) then - begin - Hold := ARect.Left; - ARect.Left := ARect.Right; - ARect.Right := Hold; - end; - ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B); - finally - DrawBitmap.Canvas.Unlock; - end; - end; -end; - -procedure TTntCustomDBGrid.DefaultDrawDataCell(const Rect: TRect; Field: TField; - State: TGridDrawState); -var - Alignment: TAlignment; - Value: WideString; -begin - Alignment := taLeftJustify; - Value := ''; - if Assigned(Field) then - begin - Alignment := Field.Alignment; - Value := GetWideDisplayText(Field); - end; - WriteText(Canvas, Rect, 2, 2, Value, Alignment, - UseRightToLeftAlignmentForField(Field, Alignment)); -end; - -procedure TTntCustomDBGrid.DefaultDrawColumnCell(const Rect: TRect; - DataCol: Integer; Column: TTntColumn; State: TGridDrawState); -var - Value: WideString; -begin - Value := ''; - if Assigned(Column.Field) then - Value := GetWideDisplayText(Column.Field); - WriteText(Canvas, Rect, 2, 2, Value, Column.Alignment, - UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)); -end; - -procedure TTntCustomDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); -var - FrameOffs: Byte; - - procedure DrawTitleCell(ACol, ARow: Integer; Column: TTntColumn; var AState: TGridDrawState); - const - ScrollArrows: array [Boolean, Boolean] of Integer = - ((DFCS_SCROLLRIGHT, DFCS_SCROLLLEFT), (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT)); - var - MasterCol: TColumn{TNT-ALLOW TColumn}; - TitleRect, TxtRect, ButtonRect: TRect; - I: Integer; - InBiDiMode: Boolean; - begin - TitleRect := CalcTitleRect(Column, ARow, MasterCol); - - if MasterCol = nil then - begin - Canvas.FillRect(ARect); - Exit; - end; - - Canvas.Font := MasterCol.Title.Font; - Canvas.Brush.Color := MasterCol.Title.Color; - if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then - InflateRect(TitleRect, -1, -1); - TxtRect := TitleRect; - I := GetSystemMetrics(SM_CXHSCROLL); - if ((TxtRect.Right - TxtRect.Left) > I) and MasterCol.Expandable then - begin - Dec(TxtRect.Right, I); - ButtonRect := TitleRect; - ButtonRect.Left := TxtRect.Right; - I := SaveDC(Canvas.Handle); - try - Canvas.FillRect(ButtonRect); - InflateRect(ButtonRect, -1, -1); - IntersectClipRect(Canvas.Handle, ButtonRect.Left, - ButtonRect.Top, ButtonRect.Right, ButtonRect.Bottom); - InflateRect(ButtonRect, 1, 1); - { DrawFrameControl doesn't draw properly when orienatation has changed. - It draws as ExtTextOutW does. } - InBiDiMode := Canvas.CanvasOrientation = coRightToLeft; - if InBiDiMode then { stretch the arrows box } - Inc(ButtonRect.Right, GetSystemMetrics(SM_CXHSCROLL) + 4); - DrawFrameControl(Canvas.Handle, ButtonRect, DFC_SCROLL, - ScrollArrows[InBiDiMode, MasterCol.Expanded] or DFCS_FLAT); - finally - RestoreDC(Canvas.Handle, I); - end; - end; - with (MasterCol.Title as TTntColumnTitle) do - WriteText(Canvas, TxtRect, FrameOffs, FrameOffs, Caption, Alignment, IsRightToLeft); - if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then - begin - InflateRect(TitleRect, 1, 1); - DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); - DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_TOPLEFT); - end; - AState := AState - [gdFixed]; // prevent box drawing later - end; - -var - OldActive: Integer; - Highlight: Boolean; - Value: WideString; - DrawColumn: TTntColumn; -begin - if csLoading in ComponentState then - begin - Canvas.Brush.Color := Color; - Canvas.FillRect(ARect); - Exit; - end; - - if (gdFixed in AState) and (RawToDataColumn(ACol) < 0) then - begin - inherited; - exit; - end; - - Dec(ARow, FixedRows); - ACol := RawToDataColumn(ACol); - - if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = - [dgRowLines, dgColLines]) then - begin - InflateRect(ARect, -1, -1); - FrameOffs := 1; - end - else - FrameOffs := 2; - - with Canvas do - begin - DrawColumn := Columns[ACol] as TTntColumn; - if not DrawColumn.Showing then Exit; - if not (gdFixed in AState) then - begin - Font := DrawColumn.Font; - Brush.Color := DrawColumn.Color; - end; - if ARow < 0 then - DrawTitleCell(ACol, ARow + FixedRows, DrawColumn, AState) - else if (DataLink = nil) or not DataLink.Active then - FillRect(ARect) - else - begin - Value := ''; - OldActive := DataLink.ActiveRecord; - try - DataLink.ActiveRecord := ARow; - if Assigned(DrawColumn.Field) then - Value := GetWideDisplayText(DrawColumn.Field); - Highlight := HighlightCell(ACol, ARow, Value, AState); - if Highlight then - begin - Brush.Color := clHighlight; - Font.Color := clHighlightText; - end; - if not Enabled then - Font.Color := clGrayText; - if DefaultDrawing then - DefaultDrawColumnCell(ARect, ACol, DrawColumn, AState); - if Columns.State = csDefault then - DrawDataCell(ARect, DrawColumn.Field, AState); - DrawColumnCell(ARect, ACol, DrawColumn, AState); - finally - DataLink.ActiveRecord := OldActive; - end; - if DefaultDrawing and (gdSelected in AState) - and ((dgAlwaysShowSelection in Options) or Focused) - and not (csDesigning in ComponentState) - and not (dgRowSelect in Options) - and (UpdateLock = 0) - and (ValidParentForm(Self).ActiveControl = Self) then - Windows.DrawFocusRect(Handle, ARect); - end; - end; - if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options = - [dgRowLines, dgColLines]) then - begin - InflateRect(ARect, 1, 1); - DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT); - DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT); - end; -end; - -procedure TTntCustomDBGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomDBGrid.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -initialization - DrawBitmap := TBitmap.Create; - -finalization - DrawBitmap.Free; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm deleted file mode 100644 index fd0a07196b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm +++ /dev/null @@ -1,108 +0,0 @@ -object TntLoginDialog: TTntLoginDialog - Left = 307 - Top = 131 - ActiveControl = Password - BorderStyle = bsDialog - Caption = 'Database Login' - ClientHeight = 147 - ClientWidth = 273 - Color = clBtnFace - ParentFont = True - - Position = poScreenCenter - OnShow = FormShow - PixelsPerInch = 96 - TextHeight = 13 - object OKButton: TTntButton - Left = 109 - Top = 114 - Width = 75 - Height = 25 - Caption = '&OK' - Default = True - ModalResult = 1 - TabOrder = 0 - end - object CancelButton: TTntButton - Left = 190 - Top = 114 - Width = 75 - Height = 25 - Cancel = True - Caption = 'Cancel' - ModalResult = 2 - TabOrder = 1 - end - object Panel: TTntPanel - Left = 8 - Top = 7 - Width = 257 - Height = 98 - BevelInner = bvRaised - BevelOuter = bvLowered - TabOrder = 2 - object Label3: TTntLabel - Left = 10 - Top = 6 - Width = 50 - Height = 13 - Caption = 'Database:' - end - object DatabaseName: TTntLabel - Left = 91 - Top = 6 - Width = 3 - Height = 13 - end - object Bevel: TTntBevel - Left = 1 - Top = 24 - Width = 254 - Height = 9 - Shape = bsTopLine - end - object Panel1: TTntPanel - Left = 2 - Top = 31 - Width = 253 - Height = 65 - Align = alBottom - BevelOuter = bvNone - TabOrder = 0 - object Label1: TTntLabel - Left = 8 - Top = 8 - Width = 56 - Height = 13 - Caption = '&User Name:' - FocusControl = UserName - end - object Label2: TTntLabel - Left = 8 - Top = 36 - Width = 50 - Height = 13 - Caption = '&Password:' - FocusControl = Password - end - object UserName: TTntEdit - Left = 86 - Top = 5 - Width = 153 - Height = 21 - MaxLength = 31 - TabOrder = 0 - end - object Password: TTntEdit - Left = 86 - Top = 33 - Width = 153 - Height = 21 - MaxLength = 31 - PasswordCharW = #9679 - TabOrder = 1 - PasswordChar_UTF7 = '+Jc8' - end - end - end -end diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas deleted file mode 100644 index c8747e2f2a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas +++ /dev/null @@ -1,133 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDBLogDlg; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - SysUtils, Windows, Messages, Classes, Graphics, - TntForms, TntStdCtrls, TntExtCtrls, StdCtrls, ExtCtrls, Controls; - -type - TTntLoginDialog = class(TTntForm) - Panel: TTntPanel; - Bevel: TTntBevel; - DatabaseName: TTntLabel; - OKButton: TTntButton; - CancelButton: TTntButton; - Panel1: TTntPanel; - Label1: TTntLabel; - Label2: TTntLabel; - Label3: TTntLabel; - Password: TTntEdit; - UserName: TTntEdit; - procedure FormShow(Sender: TObject); - end; - -{TNT-WARN LoginDialog} -function TntLoginDialog(const ADatabaseName: WideString; - var AUserName, APassword: WideString): Boolean; - -{TNT-WARN LoginDialogEx} -function TntLoginDialogEx(const ADatabaseName: WideString; - var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; - -{TNT-WARN RemoteLoginDialog} -function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; - -implementation - -{$R *.dfm} - -uses - Forms, VDBConsts; - -function TntLoginDialog(const ADatabaseName: WideString; - var AUserName, APassword: WideString): Boolean; -begin - with TTntLoginDialog.Create(Application) do - try - DatabaseName.Caption := ADatabaseName; - UserName.Text := AUserName; - Result := False; - if AUserName = '' then ActiveControl := UserName; - if ShowModal = mrOk then - begin - AUserName := UserName.Text; - APassword := Password.Text; - Result := True; - end; - finally - Free; - end; -end; - -function TntLoginDialogEx(const ADatabaseName: WideString; - var AUserName, APassword: WideString; NameReadOnly: Boolean): Boolean; -begin - with TTntLoginDialog.Create(Application) do - try - DatabaseName.Caption := ADatabaseName; - UserName.Text := AUserName; - Result := False; - if NameReadOnly then - UserName.Enabled := False - else - if AUserName = '' then ActiveControl := UserName; - if ShowModal = mrOk then - begin - AUserName := UserName.Text; - APassword := Password.Text; - Result := True; - end; - finally - Free; - end; -end; - -function TntRemoteLoginDialog(var AUserName, APassword: WideString): Boolean; -begin - with TTntLoginDialog.Create(Application) do - try - Caption := SRemoteLogin; - Bevel.Visible := False; - DatabaseName.Visible := False; - Label3.Visible := False; - Panel.Height := Panel.Height - Bevel.Top; - OKButton.Top := OKButton.Top - Bevel.Top; - CancelButton.Top := CancelButton.Top - Bevel.Top; - Height := Height - Bevel.Top; - UserName.Text := AUserName; - Result := False; - if AUserName = '' then ActiveControl := UserName; - if ShowModal = mrOk then - begin - AUserName := UserName.Text; - APassword := Password.Text; - Result := True; - end; - finally - Free; - end; -end; - -{ TTntLoginDialog } - -procedure TTntLoginDialog.FormShow(Sender: TObject); -begin - if (DatabaseName.Width + DatabaseName.Left) >= Panel.ClientWidth then - DatabaseName.Width := (Panel.ClientWidth - DatabaseName.Left) - 5; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas deleted file mode 100644 index 0c06d07f7d..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas +++ /dev/null @@ -1,981 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntDialogs; - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: TFindDialog and TReplaceDialog. } -{ TODO: Property editor for TTntOpenDialog.Filter } - -uses - Classes, Messages, CommDlg, Windows, Dialogs, - TntClasses, TntForms, TntSysUtils; - -type -{TNT-WARN TIncludeItemEvent} - TIncludeItemEventW = procedure (const OFN: TOFNotifyExW; var Include: Boolean) of object; - -{TNT-WARN TOpenDialog} - TTntOpenDialog = class(TOpenDialog{TNT-ALLOW TOpenDialog}) - private - FDefaultExt: WideString; - FFileName: TWideFileName; - FFilter: WideString; - FInitialDir: WideString; - FTitle: WideString; - FFiles: TTntStrings; - FOnIncludeItem: TIncludeItemEventW; - function GetDefaultExt: WideString; - procedure SetInheritedDefaultExt(const Value: AnsiString); - procedure SetDefaultExt(const Value: WideString); - function GetFileName: TWideFileName; - procedure SetFileName(const Value: TWideFileName); - function GetFilter: WideString; - procedure SetInheritedFilter(const Value: AnsiString); - procedure SetFilter(const Value: WideString); - function GetInitialDir: WideString; - procedure SetInheritedInitialDir(const Value: AnsiString); - procedure SetInitialDir(const Value: WideString); - function GetTitle: WideString; - procedure SetInheritedTitle(const Value: AnsiString); - procedure SetTitle(const Value: WideString); - function GetFiles: TTntStrings; - private - FProxiedOpenFilenameA: TOpenFilenameA; - protected - FAllowDoCanClose: Boolean; - procedure DefineProperties(Filer: TFiler); override; - function CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; - function DoCanClose: Boolean; override; - procedure GetFileNamesW(var OpenFileName: TOpenFileNameW); - procedure DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); override; - procedure WndProc(var Message: TMessage); override; - function DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; overload; - function DoExecuteW(Func: Pointer): Bool; overload; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function Execute: Boolean; override; - {$IFDEF COMPILER_9_UP} - function Execute(ParentWnd: HWND): Boolean; override; - {$ENDIF} - property Files: TTntStrings read GetFiles; - published - property DefaultExt: WideString read GetDefaultExt write SetDefaultExt; - property FileName: TWideFileName read GetFileName write SetFileName; - property Filter: WideString read GetFilter write SetFilter; - property InitialDir: WideString read GetInitialDir write SetInitialDir; - property Title: WideString read GetTitle write SetTitle; - property OnIncludeItem: TIncludeItemEventW read FOnIncludeItem write FOnIncludeItem; - end; - -{TNT-WARN TSaveDialog} - TTntSaveDialog = class(TTntOpenDialog) - public - function Execute: Boolean; override; - {$IFDEF COMPILER_9_UP} - function Execute(ParentWnd: HWND): Boolean; override; - {$ENDIF} - end; - -{ Message dialog } - -{TNT-WARN CreateMessageDialog} -function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons): TTntForm;overload; -function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; overload; - -{TNT-WARN MessageDlg} -function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; overload; -function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; overload; - -{TNT-WARN MessageDlgPos} -function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; overload; -function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; overload; - -{TNT-WARN MessageDlgPosHelp} -function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; - const HelpFileName: WideString): Integer; overload; -function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; - const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; overload; - -{TNT-WARN ShowMessage} -procedure WideShowMessage(const Msg: WideString); -{TNT-WARN ShowMessageFmt} -procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); -{TNT-WARN ShowMessagePos} -procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); - -{ Input dialog } - -{TNT-WARN InputQuery} -function WideInputQuery(const ACaption, APrompt: WideString; - var Value: WideString): Boolean; -{TNT-WARN InputBox} -function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; - -{TNT-WARN PromptForFileName} -function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; - const ADefaultExt: WideString = ''; const ATitle: WideString = ''; - const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; - -function GetModalParentWnd: HWND; - -implementation - -uses - Controls, Forms, Types, SysUtils, Graphics, Consts, Math, - TntWindows, TntStdCtrls, TntClipBrd, TntExtCtrls, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -function GetModalParentWnd: HWND; -begin - {$IFDEF COMPILER_9} - Result := Application.ActiveFormHandle; - {$ELSE} - Result := 0; - {$ENDIF} - {$IFDEF COMPILER_10_UP} - if Application.ModalPopupMode <> pmNone then - begin - Result := Application.ActiveFormHandle; - end; - {$ENDIF} - if Result = 0 then begin - Result := Application.Handle; - end; -end; - -var - ProxyExecuteDialog: TTntOpenDialog; - -function ProxyGetOpenFileNameA(var OpenFile: TOpenFilename): Bool; stdcall; -begin - ProxyExecuteDialog.FProxiedOpenFilenameA := OpenFile; - Result := False; { as if user hit "Cancel". } -end; - -{ TTntOpenDialog } - -constructor TTntOpenDialog.Create(AOwner: TComponent); -begin - inherited; - FFiles := TTntStringList.Create; -end; - -destructor TTntOpenDialog.Destroy; -begin - FreeAndNil(FFiles); - inherited; -end; - -procedure TTntOpenDialog.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntOpenDialog.GetDefaultExt: WideString; -begin - Result := GetSyncedWideString(FDefaultExt, inherited DefaultExt); -end; - -procedure TTntOpenDialog.SetInheritedDefaultExt(const Value: AnsiString); -begin - inherited DefaultExt := Value; -end; - -procedure TTntOpenDialog.SetDefaultExt(const Value: WideString); -begin - SetSyncedWideString(Value, FDefaultExt, inherited DefaultExt, SetInheritedDefaultExt); -end; - -function TTntOpenDialog.GetFileName: TWideFileName; -var - Path: array[0..MAX_PATH] of WideChar; -begin - if Win32PlatformIsUnicode and NewStyleControls and (Handle <> 0) then begin - // get filename from handle - SendMessageW(GetParent(Handle), CDM_GETFILEPATH, SizeOf(Path), Integer(@Path)); - Result := Path; - end else - Result := GetSyncedWideString(WideString(FFileName), inherited FileName); -end; - -procedure TTntOpenDialog.SetFileName(const Value: TWideFileName); -begin - FFileName := Value; - inherited FileName := Value; -end; - -function TTntOpenDialog.GetFilter: WideString; -begin - Result := GetSyncedWideString(FFilter, inherited Filter); -end; - -procedure TTntOpenDialog.SetInheritedFilter(const Value: AnsiString); -begin - inherited Filter := Value; -end; - -procedure TTntOpenDialog.SetFilter(const Value: WideString); -begin - SetSyncedWideString(Value, FFilter, inherited Filter, SetInheritedFilter); -end; - -function TTntOpenDialog.GetInitialDir: WideString; -begin - Result := GetSyncedWideString(FInitialDir, inherited InitialDir); -end; - -procedure TTntOpenDialog.SetInheritedInitialDir(const Value: AnsiString); -begin - inherited InitialDir := Value; -end; - -procedure TTntOpenDialog.SetInitialDir(const Value: WideString); - - function RemoveTrailingPathDelimiter(const Value: WideString): WideString; - var - L: Integer; - begin - // remove trailing path delimiter (except 'C:\') - L := Length(Value); - if (L > 1) and WideIsPathDelimiter(Value, L) and not WideIsDelimiter(':', Value, L - 1) then - Dec(L); - Result := Copy(Value, 1, L); - end; - -begin - SetSyncedWideString(RemoveTrailingPathDelimiter(Value), FInitialDir, - inherited InitialDir, SetInheritedInitialDir); -end; - -function TTntOpenDialog.GetTitle: WideString; -begin - Result := GetSyncedWideString(FTitle, inherited Title) -end; - -procedure TTntOpenDialog.SetInheritedTitle(const Value: AnsiString); -begin - inherited Title := Value; -end; - -procedure TTntOpenDialog.SetTitle(const Value: WideString); -begin - SetSyncedWideString(Value, FTitle, inherited Title, SetInheritedTitle); -end; - -function TTntOpenDialog.GetFiles: TTntStrings; -begin - if (not Win32PlatformIsUnicode) then - FFiles.Assign(inherited Files); - Result := FFiles; -end; - -function TTntOpenDialog.DoCanClose: Boolean; -begin - if FAllowDoCanClose then - Result := inherited DoCanClose - else - Result := True; -end; - -function TTntOpenDialog.CanCloseW(var OpenFileName: TOpenFileNameW): Boolean; -begin - GetFileNamesW(OpenFileName); - FAllowDoCanClose := True; - try - Result := DoCanClose; - finally - FAllowDoCanClose := False; - end; - FFiles.Clear; - inherited Files.Clear; -end; - -procedure TTntOpenDialog.DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); -begin - // CDN_INCLUDEITEM -> DoIncludeItem() is only be available on Windows 2000 + - // Therefore, just cast OFN as a TOFNotifyExW, since that's what it really is. - if Win32PlatformIsUnicode and Assigned(FOnIncludeItem) then - FOnIncludeItem(TOFNotifyExW(OFN), Include) -end; - -procedure TTntOpenDialog.WndProc(var Message: TMessage); -begin - Message.Result := 0; - if (Message.Msg = WM_INITDIALOG) and not (ofOldStyleDialog in Options) then begin - { If not ofOldStyleDialog then DoShow on CDN_INITDONE, not WM_INITDIALOG } - Exit; - end; - if Win32PlatformIsUnicode - and (Message.Msg = WM_NOTIFY) then begin - case (POFNotify(Message.LParam)^.hdr.code) of - CDN_FILEOK: - if not CanCloseW(POFNotifyW(Message.LParam)^.lpOFN^) then - begin - Message.Result := 1; - SetWindowLong(Handle, DWL_MSGRESULT, Message.Result); - Exit; - end; - end; - end; - inherited WndProc(Message); -end; - -function TTntOpenDialog.DoExecuteW(Func: Pointer): Bool; -begin - Result := DoExecuteW(Func, GetModalParentWnd); -end; - -function TTntOpenDialog.DoExecuteW(Func: Pointer; ParentWnd: HWND): Bool; -var - OpenFilename: TOpenFilenameW; - - function GetResNamePtr(var ScopedStringStorage: WideString; lpszName: PAnsiChar): PWideChar; - // duplicated from TntTrxResourceUtils.pas - begin - if Tnt_Is_IntResource(PWideChar(lpszName)) then - Result := PWideChar(lpszName) - else begin - ScopedStringStorage := lpszName; - Result := PWideChar(ScopedStringStorage); - end; - end; - - function AllocFilterStr(const S: WideString): WideString; - var - P: PWideChar; - begin - Result := ''; - if S <> '' then - begin - Result := S + #0#0; // double null terminators (an additional zero added in case Description/Filter pair not even.) - P := WStrScan(PWideChar(Result), '|'); - while P <> nil do - begin - P^ := #0; - Inc(P); - P := WStrScan(P, '|'); - end; - end; - end; - -var - TempTemplate, TempFilter, TempFilename, TempExt: WideString; -begin - FFiles.Clear; - - // 1. Init inherited dialog defaults. - // 2. Populate OpenFileName record with ansi defaults - ProxyExecuteDialog := Self; - try - DoExecute(@ProxyGetOpenFileNameA); - finally - ProxyExecuteDialog := nil; - end; - OpenFileName := TOpenFilenameW(FProxiedOpenFilenameA); - - with OpenFilename do - begin - if not IsWindow(hWndOwner) then begin - hWndOwner := ParentWnd; - end; - // Filter (PChar -> PWideChar) - TempFilter := AllocFilterStr(Filter); - lpstrFilter := PWideChar(TempFilter); - // FileName (PChar -> PWideChar) - SetLength(TempFilename, nMaxFile + 2); - lpstrFile := PWideChar(TempFilename); - FillChar(lpstrFile^, (nMaxFile + 2) * SizeOf(WideChar), 0); - WStrLCopy(lpstrFile, PWideChar(FileName), nMaxFile); - // InitialDir (PChar -> PWideChar) - if (InitialDir = '') and ForceCurrentDirectory then - lpstrInitialDir := '.' - else - lpstrInitialDir := PWideChar(InitialDir); - // Title (PChar -> PWideChar) - lpstrTitle := PWideChar(Title); - // DefaultExt (PChar -> PWideChar) - TempExt := DefaultExt; - if (TempExt = '') and (Flags and OFN_EXPLORER = 0) then - begin - TempExt := WideExtractFileExt(Filename); - Delete(TempExt, 1, 1); - end; - if TempExt <> '' then - lpstrDefExt := PWideChar(TempExt); - // resource template (PChar -> PWideChar) - lpTemplateName := GetResNamePtr(TempTemplate, Template); - // start modal dialog - Result := TaskModalDialog(Func, OpenFileName); - if Result then - begin - GetFileNamesW(OpenFilename); - if (Flags and OFN_EXTENSIONDIFFERENT) <> 0 then - Options := Options + [ofExtensionDifferent] - else - Options := Options - [ofExtensionDifferent]; - if (Flags and OFN_READONLY) <> 0 then - Options := Options + [ofReadOnly] - else - Options := Options - [ofReadOnly]; - FilterIndex := nFilterIndex; - end; - end; -end; - -procedure TTntOpenDialog.GetFileNamesW(var OpenFileName: TOpenFileNameW); -var - Separator: WideChar; - - procedure ExtractFileNamesW(P: PWideChar); - var - DirName, FileName: TWideFileName; - FileList: TWideStringDynArray; - i: integer; - begin - FileList := ExtractStringsFromStringArray(P, Separator); - if Length(FileList) = 0 then - FFiles.Add('') - else begin - DirName := FileList[0]; - if Length(FileList) = 1 then - FFiles.Add(DirName) - else begin - // prepare DirName - if WideLastChar(DirName) <> WideString(PathDelim) then - DirName := DirName + PathDelim; - // add files - for i := 1 {second item} to High(FileList) do begin - FileName := FileList[i]; - // prepare FileName - if (FileName[1] <> PathDelim) - and ((Length(FileName) <= 3) or (FileName[2] <> DriveDelim) or (FileName[3] <> PathDelim)) - then - FileName := DirName + FileName; - // add to list - FFiles.Add(FileName); - end; - end; - end; - end; - -var - P: PWideChar; -begin - Separator := #0; - if (ofAllowMultiSelect in Options) and - ((ofOldStyleDialog in Options) or not NewStyleControls) then - Separator := ' '; - with OpenFileName do - begin - if ofAllowMultiSelect in Options then - begin - ExtractFileNamesW(lpstrFile); - FileName := FFiles[0]; - end else - begin - P := lpstrFile; - FileName := ExtractStringFromStringArray(P, Separator); - FFiles.Add(FileName); - end; - end; - - // Sync inherited Files - inherited Files.Assign(FFiles); -end; - -function TTntOpenDialog.Execute: Boolean; -begin - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetOpenFileNameA) - else - Result := DoExecuteW(@GetOpenFileNameW); -end; - -{$IFDEF COMPILER_9_UP} -function TTntOpenDialog.Execute(ParentWnd: HWND): Boolean; -begin - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetOpenFileNameA, ParentWnd) - else - Result := DoExecuteW(@GetOpenFileNameW, ParentWnd); -end; -{$ENDIF} - -{ TTntSaveDialog } - -function TTntSaveDialog.Execute: Boolean; -begin - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetSaveFileNameA) - else - Result := DoExecuteW(@GetSaveFileNameW); -end; - -{$IFDEF COMPILER_9_UP} -function TTntSaveDialog.Execute(ParentWnd: HWND): Boolean; -begin - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetSaveFileNameA, ParentWnd) - else - Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); -end; -{$ENDIF} - -{ Message dialog } - -function GetAveCharSize(Canvas: TCanvas): TPoint; -var - I: Integer; - Buffer: array[0..51] of WideChar; - tm: TTextMetric; -begin - for I := 0 to 25 do Buffer[I] := WideChar(I + Ord('A')); - for I := 0 to 25 do Buffer[I + 26] := WideChar(I + Ord('a')); - GetTextMetrics(Canvas.Handle, tm); - GetTextExtentPointW(Canvas.Handle, Buffer, 52, TSize(Result)); - Result.X := (Result.X div 26 + 1) div 2; - Result.Y := tm.tmHeight; -end; - -type - TTntMessageForm = class(TTntForm) - private - Message: TTntLabel; - procedure HelpButtonClick(Sender: TObject); - protected - procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); - function GetFormText: WideString; - public - constructor CreateNew(AOwner: TComponent); reintroduce; - end; - -constructor TTntMessageForm.CreateNew(AOwner: TComponent); -var - NonClientMetrics: TNonClientMetrics; -begin - inherited CreateNew(AOwner); - NonClientMetrics.cbSize := sizeof(NonClientMetrics); - if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then - Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont); -end; - -procedure TTntMessageForm.HelpButtonClick(Sender: TObject); -begin - Application.HelpContext(HelpContext); -end; - -procedure TTntMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); -begin - if (Shift = [ssCtrl]) and (Key = Word('C')) then - begin - Beep; - TntClipboard.AsWideText := GetFormText; - end; -end; - -function TTntMessageForm.GetFormText: WideString; -var - DividerLine, ButtonCaptions: WideString; - I: integer; -begin - DividerLine := StringOfChar('-', 27) + sLineBreak; - for I := 0 to ComponentCount - 1 do - if Components[I] is TTntButton then - ButtonCaptions := ButtonCaptions + TTntButton(Components[I]).Caption + - StringOfChar(' ', 3); - ButtonCaptions := Tnt_WideStringReplace(ButtonCaptions,'&','', [rfReplaceAll]); - Result := DividerLine + Caption + sLineBreak + DividerLine + Message.Caption + sLineBreak - + DividerLine + ButtonCaptions + sLineBreak + DividerLine; -end; - -function GetMessageCaption(MsgType: TMsgDlgType): WideString; -begin - case MsgType of - mtWarning: Result := SMsgDlgWarning; - mtError: Result := SMsgDlgError; - mtInformation: Result := SMsgDlgInformation; - mtConfirmation: Result := SMsgDlgConfirm; - mtCustom: Result := ''; - else - raise ETntInternalError.Create('Unexpected MsgType in GetMessageCaption.'); - end; -end; - -function GetButtonCaption(MsgDlgBtn: TMsgDlgBtn): WideString; -begin - case MsgDlgBtn of - mbYes: Result := SMsgDlgYes; - mbNo: Result := SMsgDlgNo; - mbOK: Result := SMsgDlgOK; - mbCancel: Result := SMsgDlgCancel; - mbAbort: Result := SMsgDlgAbort; - mbRetry: Result := SMsgDlgRetry; - mbIgnore: Result := SMsgDlgIgnore; - mbAll: Result := SMsgDlgAll; - mbNoToAll: Result := SMsgDlgNoToAll; - mbYesToAll: Result := SMsgDlgYesToAll; - mbHelp: Result := SMsgDlgHelp; - else - raise ETntInternalError.Create('Unexpected MsgDlgBtn in GetButtonCaption.'); - end; -end; - -var - IconIDs: array[TMsgDlgType] of PAnsiChar = (IDI_EXCLAMATION, IDI_HAND, - IDI_ASTERISK, IDI_QUESTION, nil); - ButtonNames: array[TMsgDlgBtn] of WideString = ( - 'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll', - 'YesToAll', 'Help'); - ModalResults: array[TMsgDlgBtn] of Integer = ( - mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll, - mrYesToAll, 0); - -function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TTntForm; -const - mcHorzMargin = 8; - mcVertMargin = 8; - mcHorzSpacing = 10; - mcVertSpacing = 10; - mcButtonWidth = 50; - mcButtonHeight = 14; - mcButtonSpacing = 4; -var - DialogUnits: TPoint; - HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth, - ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth, - IconTextWidth, IconTextHeight, X, ALeft: Integer; - B, CancelButton: TMsgDlgBtn; - IconID: PAnsiChar; - ATextRect: TRect; - ThisButtonWidth: integer; - LButton: TTntButton; -begin - Result := TTntMessageForm.CreateNew(Application); - with Result do - begin - BorderStyle := bsDialog; // By doing this first, it will work on WINE. - BiDiMode := Application.BiDiMode; - Canvas.Font := Font; - KeyPreview := True; - Position := poDesigned; - OnKeyDown := TTntMessageForm(Result).CustomKeyDown; - DialogUnits := GetAveCharSize(Canvas); - HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4); - VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8); - HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4); - VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8); - ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4); - for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do - begin - if B in Buttons then - begin - ATextRect := Rect(0,0,0,0); - Tnt_DrawTextW(Canvas.Handle, - PWideChar(GetButtonCaption(B)), -1, - ATextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or - DrawTextBiDiModeFlagsReadingOnly); - with ATextRect do ThisButtonWidth := Right - Left + 8; - if ThisButtonWidth > ButtonWidth then - ButtonWidth := ThisButtonWidth; - end; - end; - ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8); - ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4); - SetRect(ATextRect, 0, 0, Screen.Width div 2, 0); - Tnt_DrawTextW(Canvas.Handle, PWideChar(Msg), Length(Msg) + 1, ATextRect, - DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or - DrawTextBiDiModeFlagsReadingOnly); - IconID := IconIDs[DlgType]; - IconTextWidth := ATextRect.Right; - IconTextHeight := ATextRect.Bottom; - if IconID <> nil then - begin - Inc(IconTextWidth, 32 + HorzSpacing); - if IconTextHeight < 32 then IconTextHeight := 32; - end; - ButtonCount := 0; - for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do - if B in Buttons then Inc(ButtonCount); - ButtonGroupWidth := 0; - if ButtonCount <> 0 then - ButtonGroupWidth := ButtonWidth * ButtonCount + - ButtonSpacing * (ButtonCount - 1); - ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2; - ClientHeight := IconTextHeight + ButtonHeight + VertSpacing + - VertMargin * 2; - Left := (Screen.Width div 2) - (Width div 2); - Top := (Screen.Height div 2) - (Height div 2); - if DlgType <> mtCustom then - Caption := GetMessageCaption(DlgType) - else - Caption := TntApplication.Title; - if IconID <> nil then - with TTntImage.Create(Result) do - begin - Name := 'Image'; - Parent := Result; - Picture.Icon.Handle := LoadIcon(0, IconID); - SetBounds(HorzMargin, VertMargin, 32, 32); - end; - TTntMessageForm(Result).Message := TTntLabel.Create(Result); - with TTntMessageForm(Result).Message do - begin - Name := 'Message'; - Parent := Result; - WordWrap := True; - Caption := Msg; - BoundsRect := ATextRect; - BiDiMode := Result.BiDiMode; - ALeft := IconTextWidth - ATextRect.Right + HorzMargin; - if UseRightToLeftAlignment then - ALeft := Result.ClientWidth - ALeft - Width; - SetBounds(ALeft, VertMargin, - ATextRect.Right, ATextRect.Bottom); - end; - if mbCancel in Buttons then CancelButton := mbCancel else - if mbNo in Buttons then CancelButton := mbNo else - CancelButton := mbOk; - X := (ClientWidth - ButtonGroupWidth) div 2; - for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do - if B in Buttons then - begin - LButton := TTntButton.Create(Result); - with LButton do - begin - Name := ButtonNames[B]; - Parent := Result; - Caption := GetButtonCaption(B); - ModalResult := ModalResults[B]; - if B = DefaultButton then - begin - Default := True; - ActiveControl := LButton; - end; - if B = CancelButton then - Cancel := True; - SetBounds(X, IconTextHeight + VertMargin + VertSpacing, - ButtonWidth, ButtonHeight); - Inc(X, ButtonWidth + ButtonSpacing); - if B = mbHelp then - OnClick := TTntMessageForm(Result).HelpButtonClick; - end; - end; - end; -end; - -function WideCreateMessageDialog(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons): TTntForm; -var - DefaultButton: TMsgDlgBtn; -begin - if mbOk in Buttons then DefaultButton := mbOk else - if mbYes in Buttons then DefaultButton := mbYes else - DefaultButton := mbRetry; - Result := WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton); -end; - -function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): Integer; -begin - Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, '', DefaultButton); -end; - -function WideMessageDlg(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; -begin - Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, ''); -end; - -function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; DefaultButton: TMsgDlgBtn): Integer; -begin - Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, '', DefaultButton); -end; - -function WideMessageDlgPos(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; -begin - Result := WideMessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, ''); -end; - -function _Internal_WideMessageDlgPosHelp(Dlg: TTntForm; HelpCtx: Longint; X, Y: Integer; - const HelpFileName: WideString): Integer; -begin - with Dlg do - try - HelpContext := HelpCtx; - HelpFile := HelpFileName; - if X >= 0 then Left := X; - if Y >= 0 then Top := Y; - if (Y < 0) and (X < 0) then Position := poScreenCenter; - Result := ShowModal; - finally - Free; - end; -end; - -function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; - const HelpFileName: WideString; DefaultButton: TMsgDlgBtn): Integer; -begin - Result := _Internal_WideMessageDlgPosHelp( - WideCreateMessageDialog(Msg, DlgType, Buttons, DefaultButton), HelpCtx, X, Y, HelpFileName); -end; - -function WideMessageDlgPosHelp(const Msg: WideString; DlgType: TMsgDlgType; - Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; - const HelpFileName: WideString): Integer; -begin - Result := _Internal_WideMessageDlgPosHelp( - WideCreateMessageDialog(Msg, DlgType, Buttons), HelpCtx, X, Y, HelpFileName); -end; - -procedure WideShowMessage(const Msg: WideString); -begin - WideShowMessagePos(Msg, -1, -1); -end; - -procedure WideShowMessageFmt(const Msg: WideString; Params: array of const); -begin - WideShowMessage(WideFormat(Msg, Params)); -end; - -procedure WideShowMessagePos(const Msg: WideString; X, Y: Integer); -begin - WideMessageDlgPos(Msg, mtCustom, [mbOK], 0, X, Y); -end; - -{ Input dialog } - -function WideInputQuery(const ACaption, APrompt: WideString; var Value: WideString): Boolean; -var - Form: TTntForm; - Prompt: TTntLabel; - Edit: TTntEdit; - DialogUnits: TPoint; - ButtonTop, ButtonWidth, ButtonHeight: Integer; -begin - Result := False; - Form := TTntForm.Create(Application); - with Form do begin - try - BorderStyle := bsDialog; // By doing this first, it will work on WINE. - Canvas.Font := Font; - DialogUnits := GetAveCharSize(Canvas); - Caption := ACaption; - ClientWidth := MulDiv(180, DialogUnits.X, 4); - Position := poScreenCenter; - Prompt := TTntLabel.Create(Form); - with Prompt do - begin - Parent := Form; - Caption := APrompt; - Left := MulDiv(8, DialogUnits.X, 4); - Top := MulDiv(8, DialogUnits.Y, 8); - Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4); - WordWrap := True; - end; - Edit := TTntEdit.Create(Form); - with Edit do - begin - Parent := Form; - Left := Prompt.Left; - Top := Prompt.Top + Prompt.Height + 5; - Width := MulDiv(164, DialogUnits.X, 4); - MaxLength := 255; - Text := Value; - SelectAll; - end; - ButtonTop := Edit.Top + Edit.Height + 15; - ButtonWidth := MulDiv(50, DialogUnits.X, 4); - ButtonHeight := MulDiv(14, DialogUnits.Y, 8); - with TTntButton.Create(Form) do - begin - Parent := Form; - Caption := SMsgDlgOK; - ModalResult := mrOk; - Default := True; - SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, - ButtonHeight); - end; - with TTntButton.Create(Form) do - begin - Parent := Form; - Caption := SMsgDlgCancel; - ModalResult := mrCancel; - Cancel := True; - SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15, ButtonWidth, - ButtonHeight); - Form.ClientHeight := Top + Height + 13; - end; - if ShowModal = mrOk then - begin - Value := Edit.Text; - Result := True; - end; - finally - Form.Free; - end; - end; -end; - -function WideInputBox(const ACaption, APrompt, ADefault: WideString): WideString; -begin - Result := ADefault; - WideInputQuery(ACaption, APrompt, Result); -end; - -function WidePromptForFileName(var AFileName: WideString; const AFilter: WideString = ''; - const ADefaultExt: WideString = ''; const ATitle: WideString = ''; - const AInitialDir: WideString = ''; SaveDialog: Boolean = False): Boolean; -var - Dialog: TTntOpenDialog; -begin - if SaveDialog then - begin - Dialog := TTntSaveDialog.Create(nil); - Dialog.Options := Dialog.Options + [ofOverwritePrompt]; - end - else - Dialog := TTntOpenDialog.Create(nil); - with Dialog do - try - Title := ATitle; - DefaultExt := ADefaultExt; - if AFilter = '' then - Filter := SDefaultFilter else - Filter := AFilter; - InitialDir := AInitialDir; - FileName := AFileName; - Result := Execute; - if Result then - AFileName := FileName; - finally - Free; - end; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas deleted file mode 100644 index cf1f342142..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas +++ /dev/null @@ -1,1400 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntExtActns; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, TntActnList, ExtActns; - -type -{TNT-WARN TCustomFileRun} - TTntCustomFileRun = class(TCustomFileRun{TNT-ALLOW TCustomFileRun}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFileRun} - TTntFileRun = class(TFileRun{TNT-ALLOW TFileRun}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditAction} - TTntRichEditAction = class(TRichEditAction{TNT-ALLOW TRichEditAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditBold} - TTntRichEditBold = class(TRichEditBold{TNT-ALLOW TRichEditBold}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditItalic} - TTntRichEditItalic = class(TRichEditItalic{TNT-ALLOW TRichEditItalic}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditUnderline} - TTntRichEditUnderline = class(TRichEditUnderline{TNT-ALLOW TRichEditUnderline}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditStrikeOut} - TTntRichEditStrikeOut = class(TRichEditStrikeOut{TNT-ALLOW TRichEditStrikeOut}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditBullets} - TTntRichEditBullets = class(TRichEditBullets{TNT-ALLOW TRichEditBullets}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditAlignLeft} - TTntRichEditAlignLeft = class(TRichEditAlignLeft{TNT-ALLOW TRichEditAlignLeft}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditAlignRight} - TTntRichEditAlignRight = class(TRichEditAlignRight{TNT-ALLOW TRichEditAlignRight}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TRichEditAlignCenter} - TTntRichEditAlignCenter = class(TRichEditAlignCenter{TNT-ALLOW TRichEditAlignCenter}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TTabAction} - TTntTabAction = class(TTabAction{TNT-ALLOW TTabAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TPreviousTab} - TTntPreviousTab = class(TPreviousTab{TNT-ALLOW TPreviousTab}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TNextTab} - TTntNextTab = class(TNextTab{TNT-ALLOW TNextTab}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TOpenPicture} - TTntOpenPicture = class(TOpenPicture{TNT-ALLOW TOpenPicture}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSavePicture} - TTntSavePicture = class(TSavePicture{TNT-ALLOW TSavePicture}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TURLAction} - TTntURLAction = class(TURLAction{TNT-ALLOW TURLAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TBrowseURL} - TTntBrowseURL = class(TBrowseURL{TNT-ALLOW TBrowseURL}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TDownLoadURL} - TTntDownLoadURL = class(TDownLoadURL{TNT-ALLOW TDownLoadURL}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSendMail} - TTntSendMail = class(TSendMail{TNT-ALLOW TSendMail}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlAction} - TTntListControlAction = class(TListControlAction{TNT-ALLOW TListControlAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlCopySelection} - TTntListControlCopySelection = class(TListControlCopySelection{TNT-ALLOW TListControlCopySelection}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlDeleteSelection} - TTntListControlDeleteSelection = class(TListControlDeleteSelection{TNT-ALLOW TListControlDeleteSelection}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlSelectAll} - TTntListControlSelectAll = class(TListControlSelectAll{TNT-ALLOW TListControlSelectAll}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlClearSelection} - TTntListControlClearSelection = class(TListControlClearSelection{TNT-ALLOW TListControlClearSelection}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TListControlMoveSelection} - TTntListControlMoveSelection = class(TListControlMoveSelection{TNT-ALLOW TListControlMoveSelection}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -implementation - -uses - ActnList, TntStdActns, TntClasses; - -{TNT-IGNORE-UNIT} - -procedure TntExtActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntStdActn_AfterInherited_Assign(Action, Source); - // TCustomFileRun - if (Action is TCustomFileRun) and (Source is TCustomFileRun) then begin - TCustomFileRun(Action).Browse := TCustomFileRun(Source).Browse; - if TCustomFileRun(Source).BrowseDlg.Owner <> Source then - TCustomFileRun(Action).BrowseDlg := TCustomFileRun(Source).BrowseDlg - else begin - { Carry over dialog properties. Currently TOpenDialog doesn't support Assign. } - { TCustomFileRun(Action).BrowseDlg.Assign(TCustomFileRun(Source).BrowseDlg); } - end; - TCustomFileRun(Action).Directory := TCustomFileRun(Source).Directory; - TCustomFileRun(Action).FileName := TCustomFileRun(Source).FileName; - TCustomFileRun(Action).Operation := TCustomFileRun(Source).Operation; - TCustomFileRun(Action).ParentControl := TCustomFileRun(Source).ParentControl; - TCustomFileRun(Action).Parameters := TCustomFileRun(Source).Parameters; - TCustomFileRun(Action).ShowCmd := TCustomFileRun(Source).ShowCmd; - end; - // TTabAction - if (Action is TTabAction) and (Source is TTabAction) then begin - TTabAction(Action).SkipHiddenTabs := TTabAction(Source).SkipHiddenTabs; - TTabAction(Action).TabControl := TTabAction(Source).TabControl; - TTabAction(Action).Wrap := TTabAction(Source).Wrap; - TTabAction(Action).BeforeTabChange := TTabAction(Source).BeforeTabChange; - TTabAction(Action).AfterTabChange := TTabAction(Source).AfterTabChange; - TTabAction(Action).OnValidateTab := TTabAction(Source).OnValidateTab; - end; - // TNextTab - if (Action is TNextTab) and (Source is TNextTab) then begin - TNextTab(Action).LastTabCaption := TNextTab(Source).LastTabCaption; - TNextTab(Action).OnFinish := TNextTab(Source).OnFinish; - end; - // TURLAction - if (Action is TURLAction) and (Source is TURLAction) then begin - TURLAction(Action).URL := TURLAction(Source).URL; - end; - // TBrowseURL - if (Action is TBrowseURL) and (Source is TBrowseURL) then begin - {$IFDEF COMPILER_7_UP} - TBrowseURL(Action).BeforeBrowse := TBrowseURL(Source).BeforeBrowse; - TBrowseURL(Action).AfterBrowse := TBrowseURL(Source).AfterBrowse; - {$ENDIF} - end; - // TDownloadURL - if (Action is TDownloadURL) and (Source is TDownloadURL) then begin - TDownloadURL(Action).FileName := TDownloadURL(Source).FileName; - {$IFDEF COMPILER_7_UP} - TDownloadURL(Action).BeforeDownload := TDownloadURL(Source).BeforeDownload; - TDownloadURL(Action).AfterDownload := TDownloadURL(Source).AfterDownload; - {$ENDIF} - TDownloadURL(Action).OnDownloadProgress := TDownloadURL(Source).OnDownloadProgress; - end; - // TSendMail - if (Action is TSendMail) and (Source is TSendMail) then begin - TSendMail(Action).Text := TSendMail(Source).Text; - end; - // TListControlAction - if (Action is TListControlAction) and (Source is TListControlAction) then begin - TListControlAction(Action).ListControl := TListControlAction(Source).ListControl; - end; - // TListControlCopySelection - if (Action is TListControlCopySelection) and (Source is TListControlCopySelection) then begin - TListControlCopySelection(Action).Destination := TListControlCopySelection(Source).Destination; - end; -end; - -//------------------------- -// TNT EXT ACTNS -//------------------------- - -{ TTntCustomFileRun } - -procedure TTntCustomFileRun.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntCustomFileRun.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomFileRun.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntCustomFileRun.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntCustomFileRun.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntCustomFileRun.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntFileRun } - -procedure TTntFileRun.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileRun.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileRun.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileRun.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileRun.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileRun.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditAction } - -procedure TTntRichEditAction.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditBold } - -procedure TTntRichEditBold.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditBold.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditBold.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditBold.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditBold.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditBold.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditItalic } - -procedure TTntRichEditItalic.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditItalic.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditItalic.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditItalic.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditItalic.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditItalic.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditUnderline } - -procedure TTntRichEditUnderline.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditUnderline.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditUnderline.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditUnderline.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditUnderline.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditUnderline.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditStrikeOut } - -procedure TTntRichEditStrikeOut.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditStrikeOut.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditStrikeOut.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditStrikeOut.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditStrikeOut.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditStrikeOut.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditBullets } - -procedure TTntRichEditBullets.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditBullets.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditBullets.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditBullets.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditBullets.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditBullets.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditAlignLeft } - -procedure TTntRichEditAlignLeft.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditAlignLeft.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditAlignLeft.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditAlignLeft.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditAlignLeft.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditAlignLeft.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditAlignRight } - -procedure TTntRichEditAlignRight.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditAlignRight.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditAlignRight.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditAlignRight.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditAlignRight.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditAlignRight.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntRichEditAlignCenter } - -procedure TTntRichEditAlignCenter.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntRichEditAlignCenter.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntRichEditAlignCenter.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntRichEditAlignCenter.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntRichEditAlignCenter.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntRichEditAlignCenter.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntTabAction } - -procedure TTntTabAction.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntTabAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntTabAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntTabAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntTabAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntTabAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntPreviousTab } - -procedure TTntPreviousTab.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntPreviousTab.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntPreviousTab.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntPreviousTab.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntPreviousTab.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntPreviousTab.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntNextTab } - -procedure TTntNextTab.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntNextTab.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntNextTab.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntNextTab.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntNextTab.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntNextTab.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntOpenPicture } - -procedure TTntOpenPicture.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntOpenPicture.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntOpenPicture.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntOpenPicture.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntOpenPicture.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntOpenPicture.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSavePicture } - -procedure TTntSavePicture.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSavePicture.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSavePicture.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSavePicture.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSavePicture.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSavePicture.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntURLAction } - -procedure TTntURLAction.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntURLAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntURLAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntURLAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntURLAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntURLAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntBrowseURL } - -procedure TTntBrowseURL.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntBrowseURL.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntBrowseURL.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntBrowseURL.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntBrowseURL.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntBrowseURL.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntDownLoadURL } - -procedure TTntDownLoadURL.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntDownLoadURL.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntDownLoadURL.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntDownLoadURL.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntDownLoadURL.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntDownLoadURL.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSendMail } - -procedure TTntSendMail.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSendMail.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSendMail.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSendMail.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSendMail.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSendMail.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlAction } - -procedure TTntListControlAction.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlCopySelection } - -procedure TTntListControlCopySelection.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlCopySelection.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlCopySelection.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlCopySelection.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlCopySelection.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlCopySelection.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlDeleteSelection } - -procedure TTntListControlDeleteSelection.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlDeleteSelection.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlDeleteSelection.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlDeleteSelection.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlDeleteSelection.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlDeleteSelection.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlSelectAll } - -procedure TTntListControlSelectAll.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlSelectAll.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlSelectAll.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlSelectAll.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlSelectAll.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlSelectAll.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlClearSelection } - -procedure TTntListControlClearSelection.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlClearSelection.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlClearSelection.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlClearSelection.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlClearSelection.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlClearSelection.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntListControlMoveSelection } - -procedure TTntListControlMoveSelection.Assign(Source: TPersistent); -begin - inherited; - TntExtActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntListControlMoveSelection.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntListControlMoveSelection.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntListControlMoveSelection.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntListControlMoveSelection.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntListControlMoveSelection.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas deleted file mode 100644 index 4789fa714a..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas +++ /dev/null @@ -1,1062 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntExtCtrls; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Messages, Controls, ExtCtrls, TntClasses, TntControls, TntStdCtrls, TntGraphics; - -type -{TNT-WARN TShape} - TTntShape = class(TShape{TNT-ALLOW TShape}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TPaintBox} - TTntPaintBox = class(TPaintBox{TNT-ALLOW TPaintBox}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TImage} - TTntImage = class(TImage{TNT-ALLOW TImage}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - function GetPicture: TTntPicture; - procedure SetPicture(const Value: TTntPicture); - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property Picture: TTntPicture read GetPicture write SetPicture; - end; - -{TNT-WARN TBevel} - TTntBevel = class(TBevel{TNT-ALLOW TBevel}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCustomPanel} - TTntCustomPanel = class(TCustomPanel{TNT-ALLOW TCustomPanel}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - protected - procedure Paint; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TPanel} - TTntPanel = class(TTntCustomPanel) - public - property DockManager; - published - property Align; - property Alignment; - property Anchors; - property AutoSize; - property BevelEdges; - property BevelInner; - property BevelKind; - property BevelOuter; - property BevelWidth; - property BiDiMode; - property BorderWidth; - property BorderStyle; - property Caption; - property Color; - property Constraints; - property Ctl3D; - property UseDockManager default True; - property DockSite; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property FullRepaint; - property Font; - property Locked; - {$IFDEF COMPILER_10_UP} - property Padding; - {$ENDIF} - property ParentBiDiMode; - {$IFDEF COMPILER_7_UP} - property ParentBackground; - {$ENDIF} - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property TabOrder; - property TabStop; - {$IFDEF COMPILER_9_UP} - property VerticalAlignment; - {$ENDIF} - property Visible; - {$IFDEF COMPILER_9_UP} - property OnAlignInsertBefore; - property OnAlignPosition; - {$ENDIF} - property OnCanResize; - property OnClick; - property OnConstrainedResize; - property OnContextPopup; - property OnDockDrop; - property OnDockOver; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetSiteInfo; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnResize; - property OnStartDock; - property OnStartDrag; - property OnUnDock; - end; - -{TNT-WARN TCustomControlBar} - TTntCustomControlBar = class(TCustomControlBar{TNT-ALLOW TCustomControlBar}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TControlBar} - TTntControlBar = class(TTntCustomControlBar) - public - property Canvas; - published - property Align; - property Anchors; - property AutoDock; - property AutoDrag; - property AutoSize; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BorderWidth; - property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; - property Constraints; - {$IFDEF COMPILER_10_UP} - property CornerEdge; - {$ENDIF} - property DockSite; - property DragCursor; - property DragKind; - property DragMode; - {$IFDEF COMPILER_10_UP} - property DrawingStyle; - {$ENDIF} - property Enabled; - {$IFDEF COMPILER_10_UP} - property GradientDirection; - property GradientEndColor; - property GradientStartColor; - {$ENDIF} - {$IFDEF COMPILER_7_UP} - property ParentBackground default True; - {$ENDIF} - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property Picture; - property PopupMenu; - property RowSize; - property RowSnap; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - {$IFDEF COMPILER_9_UP} - property OnAlignInsertBefore; - property OnAlignPosition; - {$ENDIF} - property OnBandDrag; - property OnBandInfo; - property OnBandMove; - property OnBandPaint; - {$IFDEF COMPILER_9_UP} - property OnBeginBandMove; - property OnEndBandMove; - {$ENDIF} - property OnCanResize; - property OnClick; - property OnConstrainedResize; - property OnContextPopup; - property OnDockDrop; - property OnDockOver; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetSiteInfo; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnPaint; - property OnResize; - property OnStartDock; - property OnStartDrag; - property OnUnDock; - end; - -{TNT-WARN TCustomRadioGroup} - TTntCustomRadioGroup = class(TTntCustomGroupBox) - private - FButtons: TList; - FItems: TTntStrings; - FItemIndex: Integer; - FColumns: Integer; - FReading: Boolean; - FUpdating: Boolean; - function GetButtons(Index: Integer): TTntRadioButton; - procedure ArrangeButtons; - procedure ButtonClick(Sender: TObject); - procedure ItemsChange(Sender: TObject); - procedure SetButtonCount(Value: Integer); - procedure SetColumns(Value: Integer); - procedure SetItemIndex(Value: Integer); - procedure SetItems(Value: TTntStrings); - procedure UpdateButtons; - procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; - procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; - procedure WMSize(var Message: TWMSize); message WM_SIZE; - protected - procedure Loaded; override; - procedure ReadState(Reader: TReader); override; - function CanModify: Boolean; virtual; - procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; - property Columns: Integer read FColumns write SetColumns default 1; - property ItemIndex: Integer read FItemIndex write SetItemIndex default -1; - property Items: TTntStrings read FItems write SetItems; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure FlipChildren(AllLevels: Boolean); override; - property Buttons[Index: Integer]: TTntRadioButton read GetButtons; - end; - -{TNT-WARN TRadioGroup} - TTntRadioGroup = class(TTntCustomRadioGroup) - published - property Align; - property Anchors; - property BiDiMode; - property Caption; - property Color; - property Columns; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property ItemIndex; - property Items; - property Constraints; - property ParentBiDiMode; - {$IFDEF COMPILER_7_UP} - property ParentBackground default True; - {$ENDIF} - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - property OnClick; - property OnContextPopup; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnStartDock; - property OnStartDrag; - end; - -{TNT-WARN TSplitter} - TTntSplitter = class(TSplitter{TNT-ALLOW TSplitter}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -implementation - -uses - Windows, Graphics, Forms, {$IFDEF THEME_7_UP} Themes, {$ENDIF} - TntSysUtils, TntWindows, TntActnList; - -{ TTntShape } - -procedure TTntShape.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntShape.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntShape.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntShape.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntShape.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntShape.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntShape.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntPaintBox } - -procedure TTntPaintBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntPaintBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntPaintBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntPaintBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntPaintBox.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntPaintBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntPaintBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -type -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - THackImage = class(TGraphicControl) - protected - FPicture: TPicture{TNT-ALLOW TPicture}; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - THackImage = class(TGraphicControl) - protected - FPicture: TPicture{TNT-ALLOW TPicture}; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - THackImage = class(TGraphicControl) - private - FPicture: TPicture{TNT-ALLOW TPicture}; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - THackImage = class(TGraphicControl) - private - FPicture: TPicture{TNT-ALLOW TPicture}; - end; -{$ENDIF} - -{ TTntImage } - -constructor TTntImage.Create(AOwner: TComponent); -var - OldPicture: TPicture{TNT-ALLOW TPicture}; -begin - inherited; - OldPicture := THackImage(Self).FPicture; - THackImage(Self).FPicture := TTntPicture.Create; - Picture.OnChange := OldPicture.OnChange; - Picture.OnProgress := OldPicture.OnProgress; - OldPicture.Free; -end; - -function TTntImage.GetPicture: TTntPicture; -begin - Result := inherited Picture as TTntPicture; -end; - -procedure TTntImage.SetPicture(const Value: TTntPicture); -begin - inherited Picture := Value; -end; - -procedure TTntImage.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntImage.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntImage.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntImage.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntImage.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntImage.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntImage.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntBevel } - -procedure TTntBevel.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntBevel.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntBevel.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntBevel.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntBevel.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntBevel.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntBevel.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomPanel } - -procedure TTntCustomPanel.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntCustomPanel.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomPanel.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntCustomPanel.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomPanel.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomPanel.Paint; -const - Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER); -var - Rect: TRect; - TopColor, BottomColor: TColor; - FontHeight: Integer; - Flags: Longint; - - procedure AdjustColors(Bevel: TPanelBevel); - begin - TopColor := clBtnHighlight; - if Bevel = bvLowered then TopColor := clBtnShadow; - BottomColor := clBtnShadow; - if Bevel = bvLowered then BottomColor := clBtnHighlight; - end; - -begin - if (not Win32PlatformIsUnicode) then - inherited - else begin - Rect := GetClientRect; - if BevelOuter <> bvNone then - begin - AdjustColors(BevelOuter); - Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); - end; - {$IFDEF THEME_7_UP} - if ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} and ParentBackground {$ENDIF} then - InflateRect(Rect, -BorderWidth, -BorderWidth) - else - {$ENDIF} - begin - Frame3D(Canvas, Rect, Color, Color, BorderWidth); - end; - if BevelInner <> bvNone then - begin - AdjustColors(BevelInner); - Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); - end; - with Canvas do - begin - {$IFDEF THEME_7_UP} - if not ThemeServices.ThemesEnabled {$IFDEF COMPILER_7_UP} or not ParentBackground {$ENDIF} then - {$ENDIF} - begin - Brush.Color := Color; - FillRect(Rect); - end; - Brush.Style := bsClear; - Font := Self.Font; - FontHeight := WideCanvasTextHeight(Canvas, 'W'); - with Rect do - begin - Top := ((Bottom + Top) - FontHeight) div 2; - Bottom := Top + FontHeight; - end; - Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment]; - Flags := DrawTextBiDiModeFlags(Flags); - Tnt_DrawTextW(Handle, PWideChar(Caption), -1, Rect, Flags); - end; - end; -end; - -function TTntCustomPanel.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomPanel.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomPanel.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomPanel.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomPanel.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomControlBar } - -procedure TTntCustomControlBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntCustomControlBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomControlBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomControlBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomControlBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomControlBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomControlBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntGroupButton } - -type - TTntGroupButton = class(TTntRadioButton) - private - FInClick: Boolean; - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - protected - procedure KeyDown(var Key: Word; Shift: TShiftState); override; - procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; - public - constructor InternalCreate(RadioGroup: TTntCustomRadioGroup); - destructor Destroy; override; - end; - -constructor TTntGroupButton.InternalCreate(RadioGroup: TTntCustomRadioGroup); -begin - inherited Create(RadioGroup); - RadioGroup.FButtons.Add(Self); - Visible := False; - Enabled := RadioGroup.Enabled; - ParentShowHint := False; - OnClick := RadioGroup.ButtonClick; - Parent := RadioGroup; -end; - -destructor TTntGroupButton.Destroy; -begin - TTntCustomRadioGroup(Owner).FButtons.Remove(Self); - inherited Destroy; -end; - -procedure TTntGroupButton.CNCommand(var Message: TWMCommand); -begin - if not FInClick then - begin - FInClick := True; - try - if ((Message.NotifyCode = BN_CLICKED) or - (Message.NotifyCode = BN_DOUBLECLICKED)) and - TTntCustomRadioGroup(Parent).CanModify then - inherited; - except - Application.HandleException(Self); - end; - FInClick := False; - end; -end; - -procedure TTntGroupButton.KeyPress(var Key: Char{TNT-ALLOW Char}); -begin - inherited KeyPress(Key); - TTntCustomRadioGroup(Parent).KeyPress(Key); - if (Key = #8) or (Key = ' ') then - begin - if not TTntCustomRadioGroup(Parent).CanModify then Key := #0; - end; -end; - -procedure TTntGroupButton.KeyDown(var Key: Word; Shift: TShiftState); -begin - inherited KeyDown(Key, Shift); - TTntCustomRadioGroup(Parent).KeyDown(Key, Shift); -end; - -{ TTntCustomRadioGroup } - -constructor TTntCustomRadioGroup.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - ControlStyle := [csSetCaption, csDoubleClicks {$IFDEF COMPILER_7_UP}, csParentBackground {$ENDIF}]; - FButtons := TList.Create; - FItems := TTntStringList.Create; - TTntStringList(FItems).OnChange := ItemsChange; - FItemIndex := -1; - FColumns := 1; -end; - -destructor TTntCustomRadioGroup.Destroy; -begin - SetButtonCount(0); - TTntStringList(FItems).OnChange := nil; - FItems.Free; - FButtons.Free; - inherited Destroy; -end; - -procedure TTntCustomRadioGroup.FlipChildren(AllLevels: Boolean); -begin - { The radio buttons are flipped using BiDiMode } -end; - -procedure TTntCustomRadioGroup.ArrangeButtons; -var - ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; - DC: HDC; - SaveFont: HFont; - Metrics: TTextMetric; - DeferHandle: THandle; - ALeft: Integer; -begin - if (FButtons.Count <> 0) and not FReading then - begin - DC := GetDC(0); - SaveFont := SelectObject(DC, Font.Handle); - GetTextMetrics(DC, Metrics); - SelectObject(DC, SaveFont); - ReleaseDC(0, DC); - ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; - ButtonWidth := (Width - 10) div FColumns; - I := Height - Metrics.tmHeight - 5; - ButtonHeight := I div ButtonsPerCol; - TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; - DeferHandle := BeginDeferWindowPos(FButtons.Count); - try - for I := 0 to FButtons.Count - 1 do - with TTntGroupButton(FButtons[I]) do - begin - BiDiMode := Self.BiDiMode; - ALeft := (I div ButtonsPerCol) * ButtonWidth + 8; - if UseRightToLeftAlignment then - ALeft := Self.ClientWidth - ALeft - ButtonWidth; - DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, - ALeft, - (I mod ButtonsPerCol) * ButtonHeight + TopMargin, - ButtonWidth, ButtonHeight, - SWP_NOZORDER or SWP_NOACTIVATE); - Visible := True; - end; - finally - EndDeferWindowPos(DeferHandle); - end; - end; -end; - -procedure TTntCustomRadioGroup.ButtonClick(Sender: TObject); -begin - if not FUpdating then - begin - FItemIndex := FButtons.IndexOf(Sender); - Changed; - Click; - end; -end; - -procedure TTntCustomRadioGroup.ItemsChange(Sender: TObject); -begin - if not FReading then - begin - if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1; - UpdateButtons; - end; -end; - -procedure TTntCustomRadioGroup.Loaded; -begin - inherited Loaded; - ArrangeButtons; -end; - -procedure TTntCustomRadioGroup.ReadState(Reader: TReader); -begin - FReading := True; - inherited ReadState(Reader); - FReading := False; - UpdateButtons; -end; - -procedure TTntCustomRadioGroup.SetButtonCount(Value: Integer); -begin - while FButtons.Count < Value do TTntGroupButton.InternalCreate(Self); - while FButtons.Count > Value do TTntGroupButton(FButtons.Last).Free; -end; - -procedure TTntCustomRadioGroup.SetColumns(Value: Integer); -begin - if Value < 1 then Value := 1; - if Value > 16 then Value := 16; - if FColumns <> Value then - begin - FColumns := Value; - ArrangeButtons; - Invalidate; - end; -end; - -procedure TTntCustomRadioGroup.SetItemIndex(Value: Integer); -begin - if FReading then FItemIndex := Value else - begin - if Value < -1 then Value := -1; - if Value >= FButtons.Count then Value := FButtons.Count - 1; - if FItemIndex <> Value then - begin - if FItemIndex >= 0 then - TTntGroupButton(FButtons[FItemIndex]).Checked := False; - FItemIndex := Value; - if FItemIndex >= 0 then - TTntGroupButton(FButtons[FItemIndex]).Checked := True; - end; - end; -end; - -procedure TTntCustomRadioGroup.SetItems(Value: TTntStrings); -begin - FItems.Assign(Value); -end; - -procedure TTntCustomRadioGroup.UpdateButtons; -var - I: Integer; -begin - SetButtonCount(FItems.Count); - for I := 0 to FButtons.Count - 1 do - TTntGroupButton(FButtons[I]).Caption := FItems[I]; - if FItemIndex >= 0 then - begin - FUpdating := True; - TTntGroupButton(FButtons[FItemIndex]).Checked := True; - FUpdating := False; - end; - ArrangeButtons; - Invalidate; -end; - -procedure TTntCustomRadioGroup.CMEnabledChanged(var Message: TMessage); -var - I: Integer; -begin - inherited; - for I := 0 to FButtons.Count - 1 do - TTntGroupButton(FButtons[I]).Enabled := Enabled; -end; - -procedure TTntCustomRadioGroup.CMFontChanged(var Message: TMessage); -begin - inherited; - ArrangeButtons; -end; - -procedure TTntCustomRadioGroup.WMSize(var Message: TWMSize); -begin - inherited; - ArrangeButtons; -end; - -function TTntCustomRadioGroup.CanModify: Boolean; -begin - Result := True; -end; - -procedure TTntCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); -begin -end; - -function TTntCustomRadioGroup.GetButtons(Index: Integer): TTntRadioButton; -begin - Result := TTntRadioButton(FButtons[Index]); -end; - -{ TTntSplitter } - -procedure TTntSplitter.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSplitter.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntSplitter.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntSplitter.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntSplitter.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntSplitter.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntSplitter.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas deleted file mode 100644 index 528c4f9f8f..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas +++ /dev/null @@ -1,317 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntExtDlgs; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Windows, TntDialogs, TntExtCtrls, TntStdCtrls, TntButtons; - -type -{TNT-WARN TOpenPictureDialog} - TTntOpenPictureDialog = class(TTntOpenDialog) - private - FPicturePanel: TTntPanel; - FPictureLabel: TTntLabel; - FPreviewButton: TTntSpeedButton; - FPaintPanel: TTntPanel; - FImageCtrl: TTntImage; - FSavedFilename: WideString; - function IsFilterStored: Boolean; - procedure PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); - protected - procedure PreviewClick(Sender: TObject); virtual; - procedure DoClose; override; - procedure DoSelectionChange; override; - procedure DoShow; override; - property ImageCtrl: TTntImage read FImageCtrl; - property PictureLabel: TTntLabel read FPictureLabel; - published - property Filter stored IsFilterStored; - public - constructor Create(AOwner: TComponent); override; - function Execute: Boolean; override; - {$IFDEF COMPILER_9_UP} - function Execute(ParentWnd: HWND): Boolean; override; - {$ENDIF} - end; - -{TNT-WARN TSavePictureDialog} - TTntSavePictureDialog = class(TTntOpenPictureDialog) - public - function Execute: Boolean; override; - {$IFDEF COMPILER_9_UP} - function Execute(ParentWnd: HWND): Boolean; override; - {$ENDIF} - end; - -implementation - -uses - ExtDlgs, {ExtDlgs is needed for a linked resource} Dialogs, Consts, Messages, - Graphics, Math, Controls, Forms, SysUtils, CommDlg, TntSysUtils, TntForms; - -{ TTntSilentPaintPanel } - -type - TTntSilentPaintPanel = class(TTntPanel) - protected - procedure WMPaint(var Msg: TWMPaint); message WM_PAINT; - end; - -procedure TTntSilentPaintPanel.WMPaint(var Msg: TWMPaint); -begin - try - inherited; - except - Caption := SInvalidImage; - end; -end; - -{ TTntOpenPictureDialog } - -constructor TTntOpenPictureDialog.Create(AOwner: TComponent); -begin - inherited; - Filter := GraphicFilter(TGraphic); - FPicturePanel := TTntPanel.Create(Self); - with FPicturePanel do - begin - Name := 'PicturePanel'; - Caption := ''; - SetBounds(204, 5, 169, 200); - BevelOuter := bvNone; - BorderWidth := 6; - TabOrder := 1; - FPictureLabel := TTntLabel.Create(Self); - with FPictureLabel do - begin - Name := 'PictureLabel'; - Caption := ''; - SetBounds(6, 6, 157, 23); - Align := alTop; - AutoSize := False; - Parent := FPicturePanel; - end; - FPreviewButton := TTntSpeedButton.Create(Self); - with FPreviewButton do - begin - Name := 'PreviewButton'; - SetBounds(77, 1, 23, 22); - Enabled := False; - Glyph.LoadFromResourceName(FindClassHInstance(TOpenPictureDialog{TNT-ALLOW TOpenPictureDialog}), 'PREVIEWGLYPH'); - Hint := SPreviewLabel; - ParentShowHint := False; - ShowHint := True; - OnClick := PreviewClick; - Parent := FPicturePanel; - end; - FPaintPanel := TTntSilentPaintPanel.Create(Self); - with FPaintPanel do - begin - Name := 'PaintPanel'; - Caption := ''; - SetBounds(6, 29, 157, 145); - Align := alClient; - BevelInner := bvRaised; - BevelOuter := bvLowered; - TabOrder := 0; - FImageCtrl := TTntImage.Create(Self); - Parent := FPicturePanel; - with FImageCtrl do - begin - Name := 'PaintBox'; - Align := alClient; - OnDblClick := PreviewClick; - Parent := FPaintPanel; - Proportional := True; - Stretch := True; - Center := True; - IncrementalDisplay := True; - end; - end; - end; -end; - -procedure TTntOpenPictureDialog.DoClose; -begin - inherited; - { Hide any hint windows left behind } - Application.HideHint; -end; - -procedure TTntOpenPictureDialog.DoSelectionChange; -var - FullName: WideString; - ValidPicture: Boolean; - - function ValidFile(const FileName: WideString): Boolean; - begin - Result := WideFileGetAttr(FileName) <> $FFFFFFFF; - end; - -begin - FullName := FileName; - if FullName <> FSavedFilename then - begin - FSavedFilename := FullName; - ValidPicture := WideFileExists(FullName) and ValidFile(FullName); - if ValidPicture then - try - FImageCtrl.Picture.LoadFromFile(FullName); - FPictureLabel.Caption := WideFormat(SPictureDesc, - [FImageCtrl.Picture.Width, FImageCtrl.Picture.Height]); - FPreviewButton.Enabled := True; - FPaintPanel.Caption := ''; - except - ValidPicture := False; - end; - if not ValidPicture then - begin - FPictureLabel.Caption := SPictureLabel; - FPreviewButton.Enabled := False; - FImageCtrl.Picture := nil; - FPaintPanel.Caption := srNone; - end; - end; - inherited; -end; - -procedure TTntOpenPictureDialog.DoShow; -var - PreviewRect, StaticRect: TRect; -begin - { Set preview area to entire dialog } - GetClientRect(Handle, PreviewRect); - StaticRect := GetStaticRect; - { Move preview area to right of static area } - PreviewRect.Left := StaticRect.Left + (StaticRect.Right - StaticRect.Left); - Inc(PreviewRect.Top, 4); - FPicturePanel.BoundsRect := PreviewRect; - FPreviewButton.Left := FPaintPanel.BoundsRect.Right - FPreviewButton.Width - 2; - FImageCtrl.Picture := nil; - FSavedFilename := ''; - FPaintPanel.Caption := srNone; - FPicturePanel.ParentWindow := Handle; - inherited; -end; - -function TTntOpenPictureDialog.Execute: Boolean; -begin - if NewStyleControls and not (ofOldStyleDialog in Options) then - Template := 'DLGTEMPLATE' else - Template := nil; - Result := inherited Execute; -end; - -{$IFDEF COMPILER_9_UP} -function TTntOpenPictureDialog.Execute(ParentWnd: HWND): Boolean; -begin - if NewStyleControls and not (ofOldStyleDialog in Options) then - Template := 'DLGTEMPLATE' else - Template := nil; - Result := inherited Execute(ParentWnd); -end; -{$ENDIF} - -function TTntOpenPictureDialog.IsFilterStored: Boolean; -begin - Result := not (Filter = GraphicFilter(TGraphic)); -end; - -procedure TTntOpenPictureDialog.PreviewClick(Sender: TObject); -var - PreviewForm: TTntForm; - Panel: TTntPanel; -begin - PreviewForm := TTntForm.Create(Self); - with PreviewForm do - try - Name := 'PreviewForm'; - BorderStyle := bsSizeToolWin; // By doing this first, it will work on WINE. - Visible := False; - Caption := SPreviewLabel; - KeyPreview := True; - Position := poScreenCenter; - OnKeyPress := PreviewKeyPress; - Panel := TTntPanel.Create(PreviewForm); - with Panel do - begin - Name := 'Panel'; - Caption := ''; - Align := alClient; - BevelOuter := bvNone; - BorderStyle := bsSingle; - BorderWidth := 5; - Color := clWindow; - Parent := PreviewForm; - DoubleBuffered := True; - with TTntImage.Create(PreviewForm) do - begin - Name := 'Image'; - Align := alClient; - Stretch := True; - Proportional := True; - Center := True; - Picture.Assign(FImageCtrl.Picture); - Parent := Panel; - end; - end; - if FImageCtrl.Picture.Width > 0 then - begin - ClientWidth := Min(Monitor.Width * 3 div 4, - FImageCtrl.Picture.Width + (ClientWidth - Panel.ClientWidth)+ 10); - ClientHeight := Min(Monitor.Height * 3 div 4, - FImageCtrl.Picture.Height + (ClientHeight - Panel.ClientHeight) + 10); - end; - ShowModal; - finally - Free; - end; -end; - -procedure TTntOpenPictureDialog.PreviewKeyPress(Sender: TObject; var Key: Char{TNT-ALLOW Char}); -begin - if Key = Char{TNT-ALLOW Char}(VK_ESCAPE) then - (Sender as TTntForm).Close; -end; - -{ TSavePictureDialog } -function TTntSavePictureDialog.Execute: Boolean; -begin - if NewStyleControls and not (ofOldStyleDialog in Options) then - Template := 'DLGTEMPLATE' else - Template := nil; - - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetSaveFileNameA) - else - Result := DoExecuteW(@GetSaveFileNameW); -end; - -{$IFDEF COMPILER_9_UP} -function TTntSavePictureDialog.Execute(ParentWnd: HWND): Boolean; -begin - if NewStyleControls and not (ofOldStyleDialog in Options) then - Template := 'DLGTEMPLATE' else - Template := nil; - - if (not Win32PlatformIsUnicode) then - Result := DoExecute(@GetSaveFileNameA, ParentWnd) - else - Result := DoExecuteW(@GetSaveFileNameW, ParentWnd); -end; -{$ENDIF} - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas deleted file mode 100644 index 892bd801ae..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas +++ /dev/null @@ -1,118 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntFileCtrl; - -{$INCLUDE TntCompilers.inc} - -interface - -{$WARN UNIT_PLATFORM OFF} - -uses - Classes, Windows, FileCtrl; - -{TNT-WARN SelectDirectory} -function WideSelectDirectory(const Caption: WideString; const Root: WideString; - var Directory: WideString): Boolean; - -implementation - -uses - SysUtils, Forms, ActiveX, ShlObj, ShellApi, TntSysUtils, TntWindows; - -function SelectDirCB_W(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall; -begin - if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then - SendMessageW(Wnd, BFFM_SETSELECTIONW, Integer(True), lpdata); - result := 0; -end; - -function WideSelectDirectory(const Caption: WideString; const Root: WideString; - var Directory: WideString): Boolean; -{$IFNDEF COMPILER_7_UP} -const - BIF_NEWDIALOGSTYLE = $0040; - BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX; -{$ENDIF} -var - WindowList: Pointer; - BrowseInfo: TBrowseInfoW; - Buffer: PWideChar; - OldErrorMode: Cardinal; - RootItemIDList, ItemIDList: PItemIDList; - ShellMalloc: IMalloc; - IDesktopFolder: IShellFolder; - Eaten, Flags: LongWord; - AnsiDirectory: AnsiString; -begin - if (not Win32PlatformIsUnicode) then begin - AnsiDirectory := Directory; - Result := SelectDirectory{TNT-ALLOW SelectDirectory}(Caption, Root, AnsiDirectory); - Directory := AnsiDirectory; - end else begin - Result := False; - if not WideDirectoryExists(Directory) then - Directory := ''; - FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); - if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then - begin - Buffer := ShellMalloc.Alloc(MAX_PATH * SizeOf(WideChar)); - try - RootItemIDList := nil; - if Root <> '' then - begin - SHGetDesktopFolder(IDesktopFolder); - IDesktopFolder.ParseDisplayName(Application.Handle, nil, - POleStr(Root), Eaten, RootItemIDList, Flags); - end; - with BrowseInfo do - begin - {$IFDEF COMPILER_9_UP} - hWndOwner := Application.ActiveFormHandle; - {$ELSE} - hWndOwner := Application.Handle; - {$ENDIF} - pidlRoot := RootItemIDList; - pszDisplayName := Buffer; - lpszTitle := PWideChar(Caption); - ulFlags := BIF_RETURNONLYFSDIRS; - if Win32MajorVersion >= 5 then - ulFlags := ulFlags or BIF_USENEWUI; - if Directory <> '' then - begin - lpfn := SelectDirCB_W; - lParam := Integer(PWideChar(Directory)); - end; - end; - WindowList := DisableTaskWindows(0); - OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); - try - ItemIDList := Tnt_ShBrowseForFolderW(BrowseInfo); - finally - SetErrorMode(OldErrorMode); - EnableTaskWindows(WindowList); - end; - Result := ItemIDList <> nil; - if Result then - begin - Tnt_ShGetPathFromIDListW(ItemIDList, Buffer); - ShellMalloc.Free(ItemIDList); - Directory := Buffer; - end; - finally - ShellMalloc.Free(Buffer); - end; - end; - end; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas deleted file mode 100644 index 1149ec8f32..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas +++ /dev/null @@ -1,503 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntFormatStrUtils; - -{$INCLUDE TntCompilers.inc} - -interface - -// this unit provides functions to work with format strings - -uses - TntSysUtils; - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{$ENDIF} -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; - -type - EFormatSpecError = class(ETntGeneralError); - -implementation - -uses - SysUtils, Math, TntClasses; - -resourcestring - SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; - SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; - SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; - -type - TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); - -function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; -var - LastChar: WideChar; -begin - LastChar := TntWideLastChar(FormatSpecifier); - case LastChar of - 'd', 'D', 'u', 'U', 'x', 'X': - result := fstInteger; - 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': - result := fstFloating; - 'p', 'P': - result := fstPointer; - 's', 'S': - result := fstString - else - raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); - end; -end; - -type - TFormatStrParser = class(TObject) - private - ParsedString: TBufferedWideString; - PFormatString: PWideChar; - LastIndex: Integer; - ExplicitCount: Integer; - ImplicitCount: Integer; - procedure RaiseInvalidFormatSpecifier; - function ParseChar(c: WideChar): Boolean; - procedure ForceParseChar(c: WideChar); - function ParseDigit: Boolean; - function ParseInteger: Boolean; - procedure ForceParseType; - function PeekDigit: Boolean; - function PeekIndexSpecifier(out Index: Integer): Boolean; - public - constructor Create(const _FormatString: WideString); - destructor Destroy; override; - function ParseFormatSpecifier: Boolean; - end; - -constructor TFormatStrParser.Create(const _FormatString: WideString); -begin - inherited Create; - PFormatString := PWideChar(_FormatString); - ExplicitCount := 0; - ImplicitCount := 0; - LastIndex := -1; - ParsedString := TBufferedWideString.Create; -end; - -destructor TFormatStrParser.Destroy; -begin - FreeAndNil(ParsedString); - inherited; -end; - -procedure TFormatStrParser.RaiseInvalidFormatSpecifier; -begin - raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); -end; - -function TFormatStrParser.ParseChar(c: WideChar): Boolean; -begin - result := False; - if PFormatString^ = c then begin - result := True; - ParsedString.AddChar(c); - Inc(PFormatString); - end; -end; - -procedure TFormatStrParser.ForceParseChar(c: WideChar); -begin - if not ParseChar(c) then - RaiseInvalidFormatSpecifier; -end; - -function TFormatStrParser.PeekDigit: Boolean; -begin - result := False; - if (PFormatString^ <> #0) - and (PFormatString^ >= '0') - and (PFormatString^ <= '9') then - result := True; -end; - -function TFormatStrParser.ParseDigit: Boolean; -begin - result := False; - if PeekDigit then begin - result := True; - ForceParseChar(PFormatString^); - end; -end; - -function TFormatStrParser.ParseInteger: Boolean; -const - MAX_INT_DIGITS = 6; -var - digitcount: integer; -begin - digitcount := 0; - While ParseDigit do begin - inc(digitcount); - end; - result := (digitcount > 0); - if digitcount > MAX_INT_DIGITS then - RaiseInvalidFormatSpecifier; -end; - -procedure TFormatStrParser.ForceParseType; -begin - if PFormatString^ = #0 then - RaiseInvalidFormatSpecifier; - - case PFormatString^ of - 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', - 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': - begin - // do nothing - end - else - RaiseInvalidFormatSpecifier; - end; - ForceParseChar(PFormatString^); -end; - -function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; -var - SaveParsedString: WideString; - SaveFormatString: PWideChar; -begin - SaveParsedString := ParsedString.Value; - SaveFormatString := PFormatString; - try - ParsedString.Clear; - Result := False; - Index := -1; - if ParseInteger then begin - Index := StrToInt(ParsedString.Value); - if ParseChar(':') then - Result := True; - end; - finally - ParsedString.Clear; - ParsedString.AddString(SaveParsedString); - PFormatString := SaveFormatString; - end; -end; - -function TFormatStrParser.ParseFormatSpecifier: Boolean; -var - ExplicitIndex: Integer; -begin - Result := False; - // Parse entire format specifier - ForceParseChar('%'); - if (PFormatString^ <> #0) - and (not ParseChar(' ')) - and (not ParseChar('%')) then begin - if PeekIndexSpecifier(ExplicitIndex) then begin - Inc(ExplicitCount); - LastIndex := Max(LastIndex, ExplicitIndex); - end else begin - Inc(ImplicitCount); - Inc(LastIndex); - ParsedString.AddString(IntToStr(LastIndex)); - ParsedString.AddChar(':'); - end; - if ParseChar('*') then - begin - Inc(ImplicitCount); - Inc(LastIndex); - ParseChar(':'); - end else if ParseInteger then - ParseChar(':'); - ParseChar('-'); - if ParseChar('*') then begin - Inc(ImplicitCount); - Inc(LastIndex); - end else - ParseInteger; - if ParseChar('.') then begin - if not ParseChar('*') then - ParseInteger; - end; - ForceParseType; - Result := True; - end; -end; - -//----------------------------------- - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - ParsedString.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParseFormatSpecifier; - finally - PosSpec := Pos('%', PFormatString); - end; - end; - if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} - or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then - result := _FormatString {original} - else - result := ParsedString.Value + PFormatString; - finally - Free; - end; -end; - -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{ This function replaces floating point format specifiers with their actual formatted values. - It also adds index specifiers so that the other format specifiers don't lose their place. - The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } -var - Parser: TFormatStrParser; - PosSpec: Integer; - Output: TBufferedWideString; -begin - Output := TBufferedWideString.Create; - try - Parser := TFormatStrParser.Create(_FormatString); - with Parser do - try - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Output.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParsedString.Clear; - if (not ParseFormatSpecifier) - or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then - Output.AddBuffer(ParsedString.BuffPtr, MaxInt) - {$IFDEF COMPILER_7_UP} - else if Assigned(FormatSettings) then - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) - {$ENDIF} - else - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); - finally - PosSpec := Pos('%', PFormatString); - end; - end; - Output.AddString(PFormatString); - finally - Free; - end; - Result := Output.Value; - finally - Output.Free; - end; -end; -{$ENDIF} - -procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - FormatArgs.Clear; - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Inc(PFormatString, PosSpec - 1); - // add format specifier to list - ParsedString.Clear; - if ParseFormatSpecifier then - FormatArgs.Add(ParsedString.Value); - finally - PosSpec := Pos('%', PFormatString); - end; - end; - finally - Free; - end; -end; - -function GetExplicitIndex(const FormatSpecifier: WideString): Integer; -var - IndexStr: WideString; - PosColon: Integer; -begin - result := -1; - PosColon := Pos(':', FormatSpecifier); - if PosColon <> 0 then begin - IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); - result := StrToInt(IndexStr); - end; -end; - -function GetMaxIndex(FormatArgs: TTntStrings): Integer; -var - i: integer; - RunningIndex: Integer; - ExplicitIndex: Integer; -begin - result := -1; - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - ExplicitIndex := GetExplicitIndex(FormatArgs[i]); - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - result := Max(result, RunningIndex); - end; -end; - -procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); -var - i: integer; - f: WideString; - SpecType: TFormatSpecifierType; - ExplicitIndex: Integer; - MaxIndex: Integer; - RunningIndex: Integer; -begin - // set count of TypeList to accomodate maximum index - MaxIndex := GetMaxIndex(FormatArgs); - TypeList.Clear; - for i := 0 to MaxIndex do - TypeList.Add(''); - - // for each arg... - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - f := FormatArgs[i]; - ExplicitIndex := GetExplicitIndex(f); - SpecType := GetFormatSpecifierType(f); - - // determine running arg index - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - - if TypeList[RunningIndex] <> '' then begin - // already exists in list, check for compatibility - if TypeList.Objects[RunningIndex] <> TObject(SpecType) then - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [RunningIndex, TypeList[RunningIndex], f]); - end else begin - // not in list so update it - TypeList[RunningIndex] := f; - TypeList.Objects[RunningIndex] := TObject(SpecType); - end; - end; -end; - -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - if TypeList1.Count <> TypeList2.Count then - raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); - - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [i, TypeList1[i], TypeList2[i]]); - end; - end; - - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - Result := (TypeList1.Count = TypeList2.Count); - if Result then begin - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - Result := False; - break; - end; - end; - end; - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas deleted file mode 100644 index 780005714e..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas +++ /dev/null @@ -1,873 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntForms; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, Windows, Messages, Controls, Forms, TntControls; - -type -{TNT-WARN TScrollBox} - TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox}) - private - FWMSizeCallCount: Integer; - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - procedure WMSize(var Message: TWMSize); message WM_SIZE; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCustomFrame} - TTntCustomFrame = class(TCustomFrame{TNT-ALLOW TCustomFrame}) - private - function IsHintStored: Boolean; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TFrame} - TTntFrame = class(TTntCustomFrame) - published - property Align; - property Anchors; - property AutoScroll; - property AutoSize; - property BiDiMode; - property Constraints; - property DockSite; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Color nodefault; - property Ctl3D; - property Font; - {$IFDEF COMPILER_10_UP} - property Padding; - {$ENDIF} - {$IFDEF COMPILER_7_UP} - property ParentBackground default True; - {$ENDIF} - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - {$IFDEF COMPILER_9_UP} - property OnAlignInsertBefore; - property OnAlignPosition; - {$ENDIF} - property OnCanResize; - property OnClick; - property OnConstrainedResize; - property OnContextPopup; - property OnDblClick; - property OnDockDrop; - property OnDockOver; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetSiteInfo; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnMouseWheelDown; - property OnMouseWheelUp; - property OnResize; - property OnStartDock; - property OnStartDrag; - property OnUnDock; - end; - -{TNT-WARN TForm} - TTntForm = class(TForm{TNT-ALLOW TForm}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT; - procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; - procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING; - protected - procedure UpdateActions; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DestroyWindowHandle; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function CreateDockManager: IDockManager; override; - public - constructor Create(AOwner: TComponent); override; - procedure DefaultHandler(var Message); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - - TTntApplication = class(TComponent) - private - FMainFormChecked: Boolean; - FHint: WideString; - FTntAppIdleEventControl: TControl; - FSettingChangeTime: Cardinal; - FTitle: WideString; - function GetHint: WideString; - procedure SetAnsiAppHint(const Value: AnsiString); - procedure SetHint(const Value: WideString); - function GetExeName: WideString; - function IsDlgMsg(var Msg: TMsg): Boolean; - procedure DoIdle; - function GetTitle: WideString; - procedure SetTitle(const Value: WideString); - procedure SetAnsiApplicationTitle(const Value: AnsiString); - function ApplicationMouseControlHint: WideString; - protected - function WndProc(var Message: TMessage): Boolean; - function ProcessMessage(var Msg: TMsg): Boolean; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Hint: WideString read GetHint write SetHint; - property ExeName: WideString read GetExeName; - property SettingChangeTime: Cardinal read FSettingChangeTime; - property Title: WideString read GetTitle write SetTitle; - end; - -{TNT-WARN IsAccel} -function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; - -{TNT-WARN PeekMessage} -{TNT-WARN PeekMessageA} -{TNT-WARN PeekMessageW} -procedure EnableManualPeekMessageWithRemove; -procedure DisableManualPeekMessageWithRemove; - -type - TFormProc = procedure (Form: TForm{TNT-ALLOW TForm}); - -var - TntApplication: TTntApplication; - -procedure InitTntEnvironment; - -implementation - -uses - SysUtils, Consts, RTLConsts, Menus, FlatSB, StdActns, - Graphics, TntSystem, TntSysUtils, TntMenus, TntActnList, TntStdActns, TntClasses; - -function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; -var - W: WideChar; -begin - W := KeyUnicode(CharCode); - Result := WideSameText(W, WideGetHotKey(Caption)); -end; - -{ TTntScrollBox } - -procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntScrollBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntScrollBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntScrollBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntScrollBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntScrollBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntScrollBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntScrollBox.WMSize(var Message: TWMSize); -begin - Inc(FWMSizeCallCount); - try - if FWMSizeCallCount < 32 then { Infinite recursion was encountered on Win 9x. } - inherited; - finally - Dec(FWMSizeCallCount); - end; -end; - -{ TTntCustomFrame } - -procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntCustomFrame.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomFrame.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomFrame.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomFrame.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomFrame.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomFrame.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntForm } - -constructor TTntForm.Create(AOwner: TComponent); -begin - // standard construction technique (look at TForm.Create) - GlobalNameSpace.BeginWrite; - try - CreateNew(AOwner); - if (ClassType <> TTntForm) and not (csDesigning in ComponentState) then - begin - Include(FFormState, fsCreating); - try - if not InitInheritedComponent(Self, TTntForm) then - raise EResNotFound.CreateFmt(SResNotFound, [ClassName]); - finally - Exclude(FFormState, fsCreating); - end; - if OldCreateOrder then DoCreate; - end; - finally - GlobalNameSpace.EndWrite; - end; -end; - -procedure TTntForm.CreateWindowHandle(const Params: TCreateParams); -var - NewParams: TCreateParams; - WideWinClassName: WideString; -begin - if (not Win32PlatformIsUnicode) then - inherited - else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then - begin - if (Application.MainForm = nil) or - (Application.MainForm.ClientHandle = 0) then - raise EInvalidOperation.Create(SNoMDIForm); - RegisterUnicodeClass(Params, WideWinClassName); - DefWndProc := @DefMDIChildProcW; - WindowHandle := CreateMDIWindowW(PWideChar(WideWinClassName), - nil, Params.style, Params.X, Params.Y, Params.Width, Params.Height, - Application.MainForm.ClientHandle, hInstance, Longint(Params.Param)); - if WindowHandle = 0 then - RaiseLastOSError; - SubClassUnicodeControl(Self, Params.Caption); - Include(FFormState, fsCreatedMDIChild); - end else - begin - NewParams := Params; - NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED; - CreateUnicodeHandle(Self, NewParams, ''); - Exclude(FFormState, fsCreatedMDIChild); - end; - if AlphaBlend then begin - // toggle AlphaBlend to force update - AlphaBlend := False; - AlphaBlend := True; - end else if TransparentColor then begin - // toggle TransparentColor to force update - TransparentColor := False; - TransparentColor := True; - end; -end; - -procedure TTntForm.DestroyWindowHandle; -begin - if Win32PlatformIsUnicode then - UninitializeFlatSB(Handle); { Bug in VCL: Without this there might be a resource leak. } - inherited; -end; - -procedure TTntForm.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntForm.DefaultHandler(var Message); -begin - if (ClientHandle <> 0) - and (Win32PlatformIsUnicode) then begin - with TMessage(Message) do begin - if (Msg = WM_SIZE) then - Result := DefWindowProcW(Handle, Msg, wParam, lParam) - else - Result := DefFrameProcW(Handle, ClientHandle, Msg, wParam, lParam); - if (Msg = WM_DESTROY) then - Perform(TNT_WM_DESTROY, 0, 0); { This ensures that the control is Unsubclassed. } - end; - end else - inherited DefaultHandler(Message); -end; - -function TTntForm.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntForm.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntForm.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value) -end; - -function TTntForm.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntForm.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntForm.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntForm.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntForm.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntForm.WMMenuSelect(var Message: TWMMenuSelect); -var - MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; - ID: Integer; - FindKind: TFindItemKind; -begin - if Menu <> nil then - with Message do - begin - MenuItem := nil; - if (MenuFlag <> $FFFF) or (IDItem <> 0) then - begin - FindKind := fkCommand; - ID := IDItem; - if MenuFlag and MF_POPUP <> 0 then - begin - FindKind := fkHandle; - ID := Integer(GetSubMenu(Menu, ID)); - end; - MenuItem := Self.Menu.FindItem(ID, FindKind); - end; - if MenuItem <> nil then - TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)) - else - TntApplication.Hint := ''; - end; -end; - -procedure TTntForm.UpdateActions; -begin - inherited; - TntApplication.DoIdle; -end; - -procedure TTntForm.CMBiDiModeChanged(var Message: TMessage); -var - Loop: Integer; -begin - inherited; - for Loop := 0 to ComponentCount - 1 do - if Components[Loop] is TMenu then - FixMenuBiDiProblem(TMenu(Components[Loop])); -end; - -procedure TTntForm.WMWindowPosChanging(var Message: TMessage); -begin - inherited; - // This message *sometimes* means that the Menu.BiDiMode changed. - FixMenuBiDiProblem(Menu); -end; - -function TTntForm.CreateDockManager: IDockManager; -begin - if (DockManager = nil) and DockSite and UseDockManager then - HandleNeeded; // force TNT subclassing to occur first - Result := inherited CreateDockManager; -end; - -{ TTntApplication } - -constructor TTntApplication.Create(AOwner: TComponent); -begin - inherited; - Application.HookMainWindow(WndProc); - FSettingChangeTime := GetTickCount; - TntSysUtils._SettingChangeTime := GetTickCount; -end; - -destructor TTntApplication.Destroy; -begin - FreeAndNil(FTntAppIdleEventControl); - Application.UnhookMainWindow(WndProc); - inherited; -end; - -function TTntApplication.GetHint: WideString; -begin - // check to see if the hint has already been set on application.idle - if Application.Hint = AnsiString(ApplicationMouseControlHint) then - FHint := ApplicationMouseControlHint; - // get the synced string - Result := GetSyncedWideString(FHint, Application.Hint) -end; - -procedure TTntApplication.SetAnsiAppHint(const Value: AnsiString); -begin - Application.Hint := Value; -end; - -procedure TTntApplication.SetHint(const Value: WideString); -begin - SetSyncedWideString(Value, FHint, Application.Hint, SetAnsiAppHint); -end; - -function TTntApplication.GetExeName: WideString; -begin - Result := WideParamStr(0); -end; - -function TTntApplication.GetTitle: WideString; -begin - if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin - SetLength(Result, DefWindowProcW(Application.Handle, WM_GETTEXTLENGTH, 0, 0) + 1); - DefWindowProcW(Application.Handle, WM_GETTEXT, Length(Result), Integer(PWideChar(Result))); - SetLength(Result, Length(Result) - 1); - end else - Result := GetSyncedWideString(FTitle, Application.Title); -end; - -procedure TTntApplication.SetAnsiApplicationTitle(const Value: AnsiString); -begin - Application.Title := Value; -end; - -procedure TTntApplication.SetTitle(const Value: WideString); -begin - if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin - if (GetTitle <> Value) or (FTitle <> '') then begin - DefWindowProcW(Application.Handle, WM_SETTEXT, 0, lParam(PWideChar(Value))); - FTitle := ''; - end - end else - SetSyncedWideString(Value, FTitle, Application.Title, SetAnsiApplicationTitle); -end; - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackApplication = class(TComponent) - protected - FxxxxxxxxxHandle: HWnd; - FxxxxxxxxxBiDiMode: TBiDiMode; - FxxxxxxxxxBiDiKeyboard: AnsiString; - FxxxxxxxxxNonBiDiKeyboard: AnsiString; - FxxxxxxxxxObjectInstance: Pointer; - FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; - FMouseControl: TControl; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackApplication = class(TComponent) - protected - FxxxxxxxxxHandle: HWnd; - FxxxxxxxxxBiDiMode: TBiDiMode; - FxxxxxxxxxBiDiKeyboard: AnsiString; - FxxxxxxxxxNonBiDiKeyboard: AnsiString; - FxxxxxxxxxObjectInstance: Pointer; - FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; - FMouseControl: TControl; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackApplication = class(TComponent) - protected - FxxxxxxxxxHandle: HWnd; - FxxxxxxxxxBiDiMode: TBiDiMode; - FxxxxxxxxxBiDiKeyboard: AnsiString; - FxxxxxxxxxNonBiDiKeyboard: AnsiString; - FxxxxxxxxxObjectInstance: Pointer; - FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; - FMouseControl: TControl; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackApplication = class(TComponent) - protected - FxxxxxxxxxHandle: HWnd; - FxxxxxxxxxBiDiMode: TBiDiMode; - FxxxxxxxxxBiDiKeyboard: AnsiString; - FxxxxxxxxxNonBiDiKeyboard: AnsiString; - FxxxxxxxxxObjectInstance: Pointer; - FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; - FMouseControl: TControl; - end; -{$ENDIF} - -function TTntApplication.ApplicationMouseControlHint: WideString; -var - MouseControl: TControl; -begin - MouseControl := THackApplication(Application).FMouseControl; - Result := WideGetLongHint(WideGetHint(MouseControl)); -end; - -procedure TTntApplication.DoIdle; -begin - // update TntApplication.Hint only when Ansi encodings are the same... (otherwise there are problems with action menus) - if Application.Hint = AnsiString(ApplicationMouseControlHint) then - Hint := ApplicationMouseControlHint; -end; - -function TTntApplication.IsDlgMsg(var Msg: TMsg): Boolean; -begin - Result := False; - if (Application.DialogHandle <> 0) then begin - if IsWindowUnicode(Application.DialogHandle) then - Result := IsDialogMessageW(Application.DialogHandle, Msg) - else - Result := IsDialogMessageA(Application.DialogHandle, Msg); - end; -end; - -type - TTntAppIdleEventControl = class(TControl) - protected - procedure OnIdle(Sender: TObject); - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - end; - -constructor TTntAppIdleEventControl.Create(AOwner: TComponent); -begin - inherited; - ParentFont := False; { This allows Parent (Application) to be in another module. } - Parent := Application.MainForm; - Visible := True; - Action := TTntAction.Create(Self); - Action.OnExecute := OnIdle; - Action.OnUpdate := OnIdle; - TntApplication.FTntAppIdleEventControl := Self; -end; - -destructor TTntAppIdleEventControl.Destroy; -begin - if TntApplication <> nil then - TntApplication.FTntAppIdleEventControl := nil; - inherited; -end; - -procedure TTntAppIdleEventControl.OnIdle(Sender: TObject); -begin - TntApplication.DoIdle; -end; - -function TTntApplication.ProcessMessage(var Msg: TMsg): Boolean; -var - Handled: Boolean; -begin - Result := False; - // Check Main Form - if (not FMainFormChecked) and (Application.MainForm <> nil) then begin - if not (Application.MainForm is TTntForm) then begin - // This control will help ensure that DoIdle is called - TTntAppIdleEventControl.Create(Application.MainForm); - end; - FMainFormChecked := True; - end; - // Check for Unicode char messages - if (Msg.message = WM_CHAR) - and (Msg.wParam > Integer(High(AnsiChar))) - and IsWindowUnicode(Msg.hwnd) - and ((Application.DialogHandle = 0) or IsWindowUnicode(Application.DialogHandle)) - then begin - Result := True; - // more than 8-bit WM_CHAR destined for Unicode window - Handled := False; - if Assigned(Application.OnMessage) then - Application.OnMessage(Msg, Handled); - Application.CancelHint; - // dispatch msg if not a dialog message - if (not Handled) and (not IsDlgMsg(Msg)) then - DispatchMessageW(Msg); - end; -end; - -function TTntApplication.WndProc(var Message: TMessage): Boolean; -var - BasicAction: TBasicAction; -begin - Result := False; { not handled } - if (Message.Msg = WM_SETTINGCHANGE) then begin - FSettingChangeTime := GetTickCount; - TntSysUtils._SettingChangeTime := FSettingChangeTime; - end; - if (Message.Msg = WM_CREATE) - and (FTitle <> '') then begin - SetTitle(FTitle); - FTitle := ''; - end; - if (Message.Msg = CM_ACTIONEXECUTE) then begin - BasicAction := TBasicAction(Message.LParam); - if (BasicAction.ClassType = THintAction{TNT-ALLOW THintAction}) - and (THintAction{TNT-ALLOW THintAction}(BasicAction).Hint = AnsiString(Hint)) - then begin - Result := True; - Message.Result := 1; - with TTntHintAction.Create(Self) do - begin - Hint := Self.Hint; - try - Execute; - finally - Free; - end; - end; - end; - end; -end; - -//=========================================================================== -// The NT GetMessage Hook is needed to support entering Unicode -// characters directly from the keyboard (bypassing the IME). -// Special thanks go to Francisco Leong for developing this solution. -// -// Example: -// 1. Install "Turkic" language support. -// 2. Add "Azeri (Latin)" as an input locale. -// 3. In an EDIT, enter Shift+I. (You should see a capital "I" with dot.) -// 4. In an EDIT, enter single quote (US Keyboard). (You should see an upturned "e".) -// -var - ManualPeekMessageWithRemove: Integer = 0; - -procedure EnableManualPeekMessageWithRemove; -begin - Inc(ManualPeekMessageWithRemove); -end; - -procedure DisableManualPeekMessageWithRemove; -begin - if (ManualPeekMessageWithRemove > 0) then - Dec(ManualPeekMessageWithRemove); -end; - -var - NTGetMessageHook: HHOOK; - -function GetMessageForNT(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall; -var - ThisMsg: PMSG; -begin - if (Code >= 0) - and (wParam = PM_REMOVE) - and (ManualPeekMessageWithRemove = 0) then - begin - ThisMsg := PMSG(lParam); - if (TntApplication <> nil) - and TntApplication.ProcessMessage(ThisMsg^) then - ThisMsg.message := WM_NULL; { clear for further processing } - end; - Result := CallNextHookEx(NTGetMessageHook, Code, wParam, lParam); -end; - -procedure CreateGetMessageHookForNT; -begin - Assert(Win32Platform = VER_PLATFORM_WIN32_NT); - NTGetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, GetMessageForNT, 0, GetCurrentThreadID); - if NTGetMessageHook = 0 then - RaiseLastOSError; -end; - -//--------------------------------------------------------------------------------------------- -// Tnt Environment Setup -//--------------------------------------------------------------------------------------------- - -procedure InitTntEnvironment; - - function GetDefaultFont: WideString; - - function RunningUnderIDE: Boolean; - begin - Result := ModuleIsPackage and - ( WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bds.exe') - or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'delphi32.exe') - or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bcb.exe')); - end; - - function GetProfileStr(const Section, Key, Default: AnsiString; MaxLen: Integer): AnsiString; - var - Len: Integer; - begin - SetLength(Result, MaxLen + 1); - Len := GetProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Default), - PAnsiChar(Result), Length(Result)); - SetLength(Result, Len); - end; - - procedure SetProfileStr(const Section, Key, Value: AnsiString); - var - DummyResult: Cardinal; - begin - try - Win32Check(WriteProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Value))); - if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then - WriteProfileString(nil, nil, nil); {this flushes the WIN.INI cache} - SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PAnsiChar(Section)), - SMTO_NORMAL, 250, DummyResult); - except - on E: Exception do begin - E.Message := 'Couldn''t create font substitutes.' + CRLF + E.Message; - Application.HandleException(nil); - end; - end; - end; - - var - ShellDlgFontName_1: WideString; - ShellDlgFontName_2: WideString; - begin - ShellDlgFontName_1 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg', '', LF_FACESIZE); - if ShellDlgFontName_1 = '' then begin - ShellDlgFontName_1 := 'MS Sans Serif'; - SetProfileStr('FontSubstitutes', 'MS Shell Dlg', ShellDlgFontName_1); - end; - ShellDlgFontName_2 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', '', LF_FACESIZE); - if ShellDlgFontName_2 = '' then begin - if Screen.Fonts.IndexOf('Tahoma') <> -1 then - ShellDlgFontName_2 := 'Tahoma' - else - ShellDlgFontName_2 := ShellDlgFontName_1; - SetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', ShellDlgFontName_2); - end; - if RunningUnderIDE then begin - Result := 'MS Shell Dlg 2' {Delphi is running} - end else - Result := ShellDlgFontName_2; - end; - -begin - // Tnt Environment Setup - InstallTntSystemUpdates; - DefFontData.Name := GetDefaultFont; - Forms.HintWindowClass := TntControls.TTntHintWindow; -end; - -initialization - TntApplication := TTntApplication.Create(nil); - if Win32Platform = VER_PLATFORM_WIN32_NT then - CreateGetMessageHookForNT; - -finalization - if NTGetMessageHook <> 0 then begin - UnhookWindowsHookEx(NTGetMessageHook) // no Win32Check, fails in too many cases, and doesn't matter - end; - FreeAndNil(TntApplication); - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas deleted file mode 100644 index 617b901f77..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas +++ /dev/null @@ -1,142 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntGraphics; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Graphics, Windows; - -{TNT-WARN TextRect} -procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); -{TNT-WARN TextOut} -procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); -{TNT-WARN TextExtent} -function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; -function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; -{TNT-WARN TextWidth} -function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; -{TNT-WARN TextHeight} -function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; - -type -{TNT-WARN TPicture} - TTntPicture = class(TPicture{TNT-ALLOW TPicture}) - public - procedure LoadFromFile(const Filename: WideString); - procedure SaveToFile(const Filename: WideString); - end; - -implementation - -uses - SysUtils, TntSysUtils; - -type - TAccessCanvas = class(TCanvas); - -procedure WideCanvasTextRect(Canvas: TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString); -var - Options: Longint; -begin - with TAccessCanvas(Canvas) do begin - Changing; - RequiredState([csHandleValid, csFontValid, csBrushValid]); - Options := ETO_CLIPPED or TextFlags; - if Brush.Style <> bsClear then - Options := Options or ETO_OPAQUE; - if ((TextFlags and ETO_RTLREADING) <> 0) and - (CanvasOrientation = coRightToLeft) then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); - Windows.ExtTextOutW(Handle, X, Y, Options, @Rect, PWideChar(Text), - Length(Text), nil); - Changed; - end; -end; - -procedure WideCanvasTextOut(Canvas: TCanvas; X, Y: Integer; const Text: WideString); -begin - with TAccessCanvas(Canvas) do begin - Changing; - RequiredState([csHandleValid, csFontValid, csBrushValid]); - if CanvasOrientation = coRightToLeft then Inc(X, WideCanvasTextWidth(Canvas, Text) + 1); - Windows.ExtTextOutW(Handle, X, Y, TextFlags, nil, PWideChar(Text), - Length(Text), nil); - MoveTo(X + WideCanvasTextWidth(Canvas, Text), Y); - Changed; - end; -end; - -function WideDCTextExtent(hDC: THandle; const Text: WideString): TSize; -begin - Result.cx := 0; - Result.cy := 0; - Windows.GetTextExtentPoint32W(hDC, PWideChar(Text), Length(Text), Result); -end; - -function WideCanvasTextExtent(Canvas: TCanvas; const Text: WideString): TSize; -begin - with TAccessCanvas(Canvas) do begin - RequiredState([csHandleValid, csFontValid]); - Result := WideDCTextExtent(Handle, Text); - end; -end; - -function WideCanvasTextWidth(Canvas: TCanvas; const Text: WideString): Integer; -begin - Result := WideCanvasTextExtent(Canvas, Text).cX; -end; - -function WideCanvasTextHeight(Canvas: TCanvas; const Text: WideString): Integer; -begin - Result := WideCanvasTextExtent(Canvas, Text).cY; -end; - -{ TTntPicture } - -procedure TTntPicture.LoadFromFile(const Filename: WideString); -var - ShortName: WideString; -begin - ShortName := WideExtractShortPathName(Filename); - if WideSameText(WideExtractFileExt(FileName), '.jpeg') // the short name ends with ".JPE"! - or (ShortName = '') then // GetShortPathName failed - inherited LoadFromFile(FileName) - else - inherited LoadFromFile(WideExtractShortPathName(Filename)); -end; - -procedure TTntPicture.SaveToFile(const Filename: WideString); -var - TempFile: WideString; -begin - if Graphic <> nil then begin - // create to temp file (ansi safe file name) - repeat - TempFile := WideExtractFilePath(Filename) + IntToStr(Random(MaxInt)) + WideExtractFileExt(Filename); - until not WideFileExists(TempFile); - CloseHandle(WideFileCreate(TempFile)); // make it a real file so that it has a temp - try - // save - Graphic.SaveToFile(WideExtractShortPathName(TempFile)); - // rename - WideDeleteFile(Filename); - if not WideRenameFile(TempFile, FileName) then - RaiseLastOSError; - finally - WideDeleteFile(TempFile); - end; - end; -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas deleted file mode 100644 index 8096cd445b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas +++ /dev/null @@ -1,675 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntGrids; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, TntClasses, Grids, Windows, Controls, Messages; - -type -{TNT-WARN TInplaceEdit} - TTntInplaceEdit = class(TInplaceEdit{TNT-ALLOW TInplaceEdit}) - private - function GetText: WideString; - procedure SetText(const Value: WideString); - protected - procedure UpdateContents; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - public - property Text: WideString read GetText write SetText; - end; - - TTntGetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; var Value: WideString) of object; - TTntSetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; const Value: WideString) of object; - -{TNT-WARN TCustomDrawGrid} - _TTntInternalCustomDrawGrid = class(TCustomDrawGrid{TNT-ALLOW TCustomDrawGrid}) - private - FSettingEditText: Boolean; - procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; - protected - procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; - end; - - TTntCustomDrawGrid = class(_TTntInternalCustomDrawGrid) - private - FOnGetEditText: TTntGetEditEvent; - FOnSetEditText: TTntSetEditEvent; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMChar(var Msg: TWMChar); message WM_CHAR; - protected - function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; - procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; - function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; - procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure ShowEditorChar(Ch: WideChar); dynamic; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; - property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TDrawGrid} - TTntDrawGrid = class(TTntCustomDrawGrid) - published - property Align; - property Anchors; - property BevelEdges; - property BevelInner; - property BevelKind; - property BevelOuter; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property Color; - property ColCount; - property Constraints; - property Ctl3D; - property DefaultColWidth; - property DefaultRowHeight; - property DefaultDrawing; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property FixedColor; - property FixedCols; - property RowCount; - property FixedRows; - property Font; - property GridLineWidth; - property Options; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ScrollBars; - property ShowHint; - property TabOrder; - property Visible; - property VisibleColCount; - property VisibleRowCount; - property OnClick; - property OnColumnMoved; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnDrawCell; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetEditMask; - property OnGetEditText; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnMouseWheelDown; - property OnMouseWheelUp; - property OnRowMoved; - property OnSelectCell; - property OnSetEditText; - property OnStartDock; - property OnStartDrag; - property OnTopLeftChanged; - end; - - TTntStringGrid = class; - -{TNT-WARN TStringGridStrings} - TTntStringGridStrings = class(TTntStrings) - private - FIsCol: Boolean; - FColRowIndex: Integer; - FGrid: TTntStringGrid; - function GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; - protected - function Get(Index: Integer): WideString; override; - procedure Put(Index: Integer; const S: WideString); override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - public - constructor Create(AGrid: TTntStringGrid; AIndex: Longint); - function Add(const S: WideString): Integer; override; - procedure Assign(Source: TPersistent); override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: WideString); override; - end; - -{TNT-WARN TStringGrid} - _TTntInternalStringGrid = class(TStringGrid{TNT-ALLOW TStringGrid}) - private - FSettingEditText: Boolean; - procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); dynamic; abstract; - protected - procedure SetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; - end; - - TTntStringGrid = class(_TTntInternalStringGrid) - private - FCreatedRowStrings: TStringList{TNT-ALLOW TStringList}; - FCreatedColStrings: TStringList{TNT-ALLOW TStringList}; - FOnGetEditText: TTntGetEditEvent; - FOnSetEditText: TTntSetEditEvent; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMChar(var Msg: TWMChar); message WM_CHAR; - function GetCells(ACol, ARow: Integer): WideString; - procedure SetCells(ACol, ARow: Integer; const Value: WideString); - function FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; - function GetCols(Index: Integer): TTntStrings; - function GetRows(Index: Integer): TTntStrings; - procedure SetCols(Index: Integer; const Value: TTntStrings); - procedure SetRows(Index: Integer; const Value: TTntStrings); - protected - function CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; override; - procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; - procedure InternalSetEditText(ACol, ARow: Longint; const Value: string{TNT-ALLOW string}); override; - function GetEditText(ACol, ARow: Longint): WideString; reintroduce; virtual; - procedure SetEditText(ACol, ARow: Longint; const Value: WideString); reintroduce; virtual; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure ShowEditorChar(Ch: WideChar); dynamic; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Cells[ACol, ARow: Integer]: WideString read GetCells write SetCells; - property Cols[Index: Integer]: TTntStrings read GetCols write SetCols; - property Rows[Index: Integer]: TTntStrings read GetRows write SetRows; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - property OnGetEditText: TTntGetEditEvent read FOnGetEditText write FOnGetEditText; - property OnSetEditText: TTntSetEditEvent read FOnSetEditText write FOnSetEditText; - end; - -implementation - -uses - SysUtils, TntSystem, TntGraphics, TntControls, TntStdCtrls, TntActnList, TntSysUtils; - -{ TBinaryCompareAnsiStringList } -type - TBinaryCompareAnsiStringList = class(TStringList{TNT-ALLOW TStringList}) - protected - function CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; override; - end; - -function TBinaryCompareAnsiStringList.CompareStrings(const S1, S2: string{TNT-ALLOW string}): Integer; -begin - // must compare strings via binary for speed - if S1 = S2 then - result := 0 - else if S1 < S2 then - result := -1 - else - result := 1; -end; - -{ TTntInplaceEdit } - -procedure TTntInplaceEdit.CreateWindowHandle(const Params: TCreateParams); -begin - TntCustomEdit_CreateWindowHandle(Self, Params); -end; - -function TTntInplaceEdit.GetText: WideString; -begin - if IsMasked then - Result := inherited Text - else - Result := TntControl_GetText(Self); -end; - -procedure TTntInplaceEdit.SetText(const Value: WideString); -begin - if IsMasked then - inherited Text := Value - else - TntControl_SetText(Self, Value); -end; - -type TAccessCustomGrid = class(TCustomGrid); - -procedure TTntInplaceEdit.UpdateContents; -begin - Text := ''; - with TAccessCustomGrid(Grid) do - Self.EditMask := GetEditMask(Col, Row); - if (Grid is TTntStringGrid) then - with (Grid as TTntStringGrid) do - Self.Text := GetEditText(Col, Row) - else if (Grid is TTntCustomDrawGrid) then - with (Grid as TTntCustomDrawGrid) do - Self.Text := GetEditText(Col, Row) - else - with TAccessCustomGrid(Grid) do - Self.Text := GetEditText(Col, Row); - with TAccessCustomGrid(Grid) do - Self.MaxLength := GetEditLimit; -end; - -{ _TTntInternalCustomDrawGrid } - -procedure _TTntInternalCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); -begin - if FSettingEditText then - inherited - else - InternalSetEditText(ACol, ARow, Value); -end; - - -{ TTntCustomDrawGrid } - -function TTntCustomDrawGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; -begin - Result := TTntInplaceEdit.Create(Self); -end; - -procedure TTntCustomDrawGrid.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntCustomDrawGrid.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomDrawGrid.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomDrawGrid.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomDrawGrid.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntCustomDrawGrid.GetEditText(ACol, ARow: Integer): WideString; -begin - Result := ''; - if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); -end; - -procedure TTntCustomDrawGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); -begin - if not FSettingEditText then - SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); -end; - -procedure TTntCustomDrawGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); -begin - if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); -end; - -procedure TTntCustomDrawGrid.WMChar(var Msg: TWMChar); -begin - if (goEditing in Options) - and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin - RestoreWMCharMsg(TMessage(Msg)); - ShowEditorChar(WideChar(Msg.CharCode)); - end else - inherited; -end; - -procedure TTntCustomDrawGrid.ShowEditorChar(Ch: WideChar); -begin - ShowEditor; - if InplaceEditor <> nil then begin - if Win32PlatformIsUnicode then - PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) - else - PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); - end; -end; - -procedure TTntCustomDrawGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomDrawGrid.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntStringGridStrings } - -procedure TTntStringGridStrings.Assign(Source: TPersistent); -var - UTF8Strings: TStringList{TNT-ALLOW TStringList}; - i: integer; -begin - UTF8Strings := TStringList{TNT-ALLOW TStringList}.Create; - try - if Source is TStrings{TNT-ALLOW TStrings} then begin - for i := 0 to TStrings{TNT-ALLOW TStrings}(Source).Count - 1 do - UTF8Strings.AddObject(WideStringToUTF8(WideString(TStrings{TNT-ALLOW TStrings}(Source).Strings[i])), - TStrings{TNT-ALLOW TStrings}(Source).Objects[i]); - GridAnsiStrings.Assign(UTF8Strings); - end else if Source is TTntStrings then begin - for i := 0 to TTntStrings(Source).Count - 1 do - UTF8Strings.AddObject(WideStringToUTF8(TTntStrings(Source).Strings[i]), - TTntStrings(Source).Objects[i]); - GridAnsiStrings.Assign(UTF8Strings); - end else - GridAnsiStrings.Assign(Source); - finally - UTF8Strings.Free; - end; -end; - -function TTntStringGridStrings.GridAnsiStrings: TStrings{TNT-ALLOW TStrings}; -begin - Assert(Assigned(FGrid)); - if FIsCol then - Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Cols[FColRowIndex] - else - Result := TStringGrid{TNT-ALLOW TStringGrid}(FGrid).Rows[FColRowIndex]; -end; - -procedure TTntStringGridStrings.Clear; -begin - GridAnsiStrings.Clear; -end; - -procedure TTntStringGridStrings.Delete(Index: Integer); -begin - GridAnsiStrings.Delete(Index); -end; - -function TTntStringGridStrings.GetCount: Integer; -begin - Result := GridAnsiStrings.Count; -end; - -function TTntStringGridStrings.Get(Index: Integer): WideString; -begin - Result := UTF8ToWideString(GridAnsiStrings[Index]); -end; - -procedure TTntStringGridStrings.Put(Index: Integer; const S: WideString); -begin - GridAnsiStrings[Index] := WideStringToUTF8(S); -end; - -procedure TTntStringGridStrings.Insert(Index: Integer; const S: WideString); -begin - GridAnsiStrings.Insert(Index, WideStringToUTF8(S)); -end; - -function TTntStringGridStrings.Add(const S: WideString): Integer; -begin - Result := GridAnsiStrings.Add(WideStringToUTF8(S)); -end; - -function TTntStringGridStrings.GetObject(Index: Integer): TObject; -begin - Result := GridAnsiStrings.Objects[Index]; -end; - -procedure TTntStringGridStrings.PutObject(Index: Integer; AObject: TObject); -begin - GridAnsiStrings.Objects[Index] := AObject; -end; - -type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); - -procedure TTntStringGridStrings.SetUpdateState(Updating: Boolean); -begin - TAccessStrings(GridAnsiStrings).SetUpdateState(Updating); -end; - -constructor TTntStringGridStrings.Create(AGrid: TTntStringGrid; AIndex: Integer); -begin - inherited Create; - FGrid := AGrid; - if AIndex > 0 then begin - FIsCol := False; - FColRowIndex := AIndex - 1; - end else begin - FIsCol := True; - FColRowIndex := -AIndex - 1; - end; -end; - -{ _TTntInternalStringGrid } - -procedure _TTntInternalStringGrid.SetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); -begin - if FSettingEditText then - inherited - else - InternalSetEditText(ACol, ARow, Value); -end; - -{ TTntStringGrid } - -constructor TTntStringGrid.Create(AOwner: TComponent); -begin - inherited; - FCreatedRowStrings := TBinaryCompareAnsiStringList.Create; - FCreatedRowStrings.Sorted := True; - FCreatedRowStrings.Duplicates := dupError; - FCreatedColStrings := TBinaryCompareAnsiStringList.Create; - FCreatedColStrings.Sorted := True; - FCreatedColStrings.Duplicates := dupError; -end; - -destructor TTntStringGrid.Destroy; -var - i: integer; -begin - for i := FCreatedColStrings.Count - 1 downto 0 do - FCreatedColStrings.Objects[i].Free; - for i := FCreatedRowStrings.Count - 1 downto 0 do - FCreatedRowStrings.Objects[i].Free; - FreeAndNil(FCreatedColStrings); - FreeAndNil(FCreatedRowStrings); - inherited; -end; - -function TTntStringGrid.CreateEditor: TInplaceEdit{TNT-ALLOW TInplaceEdit}; -begin - Result := TTntInplaceEdit.Create(Self); -end; - -procedure TTntStringGrid.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntStringGrid.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntStringGrid.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntStringGrid.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntStringGrid.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -function TTntStringGrid.GetCells(ACol, ARow: Integer): WideString; -begin - Result := UTF8ToWideString(inherited Cells[ACol, ARow]) -end; - -procedure TTntStringGrid.SetCells(ACol, ARow: Integer; const Value: WideString); -var - UTF8Str: AnsiString; -begin - UTF8Str := WideStringToUTF8(Value); - if inherited Cells[ACol, ARow] <> UTF8Str then - inherited Cells[ACol, ARow] := UTF8Str; -end; - -function TTntStringGrid.FindGridStrings(const IsCol: Boolean; const ListIndex: Integer): TTntStrings; -var - idx: integer; - SrcStrings: TStrings{TNT-ALLOW TStrings}; - RCIndex: Integer; -begin - if IsCol then - SrcStrings := FCreatedColStrings - else - SrcStrings := FCreatedRowStrings; - Assert(Assigned(SrcStrings)); - idx := SrcStrings.IndexOf(IntToStr(ListIndex)); - if idx <> -1 then - Result := SrcStrings.Objects[idx] as TTntStrings - else begin - if IsCol then RCIndex := -ListIndex - 1 else RCIndex := ListIndex + 1; - Result := TTntStringGridStrings.Create(Self, RCIndex); - SrcStrings.AddObject(IntToStr(ListIndex), Result); - end; -end; - -function TTntStringGrid.GetCols(Index: Integer): TTntStrings; -begin - Result := FindGridStrings(True, Index); -end; - -function TTntStringGrid.GetRows(Index: Integer): TTntStrings; -begin - Result := FindGridStrings(False, Index); -end; - -procedure TTntStringGrid.SetCols(Index: Integer; const Value: TTntStrings); -begin - FindGridStrings(True, Index).Assign(Value); -end; - -procedure TTntStringGrid.SetRows(Index: Integer; const Value: TTntStrings); -begin - FindGridStrings(False, Index).Assign(Value); -end; - -procedure TTntStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); -var - SaveDefaultDrawing: Boolean; -begin - if DefaultDrawing then - WideCanvasTextRect(Canvas, ARect, ARect.Left+2, ARect.Top+2, Cells[ACol, ARow]); - SaveDefaultDrawing := DefaultDrawing; - try - DefaultDrawing := False; - inherited DrawCell(ACol, ARow, ARect, AState); - finally - DefaultDrawing := SaveDefaultDrawing; - end; -end; - -function TTntStringGrid.GetEditText(ACol, ARow: Integer): WideString; -begin - Result := Cells[ACol, ARow]; - if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result); -end; - -procedure TTntStringGrid.InternalSetEditText(ACol, ARow: Integer; const Value: string{TNT-ALLOW string}); -begin - if not FSettingEditText then - SetEditText(ACol, ARow, TntControl_GetText(InplaceEditor)); -end; - -procedure TTntStringGrid.SetEditText(ACol, ARow: Integer; const Value: WideString); -begin - FSettingEditText := True; - try - inherited SetEditText(ACol, ARow, WideStringToUTF8(Value)); - finally - FSettingEditText := False; - end; - if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value); -end; - -procedure TTntStringGrid.WMChar(var Msg: TWMChar); -begin - if (goEditing in Options) - and (AnsiChar(Msg.CharCode) in [^H, #32..#255]) then begin - RestoreWMCharMsg(TMessage(Msg)); - ShowEditorChar(WideChar(Msg.CharCode)); - end else - inherited; -end; - -procedure TTntStringGrid.ShowEditorChar(Ch: WideChar); -begin - ShowEditor; - if InplaceEditor <> nil then begin - if Win32PlatformIsUnicode then - PostMessageW(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0) - else - PostMessageA(InplaceEditor.Handle, WM_CHAR, Word(Ch), 0); - end; -end; - -procedure TTntStringGrid.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntStringGrid.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas deleted file mode 100644 index 7219950865..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas +++ /dev/null @@ -1,1011 +0,0 @@ -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ } -{ Portions created by Wild Hunter are } -{ Copyright (c) 2003 Wild Hunter (raguotis@freemail.lt) } -{ } -{ Portions created by Stanley Xu are } -{ Copyright (c) 1999-2006 Stanley Xu } -{ (http://gosurfbrowser.com/?go=supportFeedback&ln=en) } -{ } -{ Portions created by Borland Software Corporation are } -{ Copyright (c) 1995-2001 Borland Software Corporation } -{ } -{*****************************************************************************} - -unit TntIniFiles; - -{$R-,T-,H+,X+} -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, IniFiles, - TntClasses; - -type - - TTntCustomIniFile = class({TCustomIniFile}TObject{TNT-ALLOW TObject}) - private - FFileName: WideString; - public - constructor Create(const FileName: WideString); - function SectionExists(const Section: WideString): Boolean; - function ReadString(const Section, Ident, Default: WideString): WideString; virtual; abstract; - procedure WriteString(const Section, Ident, Value: WideString); virtual; abstract; - function ReadInteger(const Section, Ident: WideString; Default: Longint): Longint; virtual; - procedure WriteInteger(const Section, Ident: WideString; Value: Longint); virtual; - function ReadBool(const Section, Ident: WideString; Default: Boolean): Boolean; virtual; - procedure WriteBool(const Section, Ident: WideString; Value: Boolean); virtual; - function ReadBinaryStream(const Section, Name: WideString; Value: TStream): Integer; virtual; - function ReadDate(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; - function ReadDateTime(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; - function ReadFloat(const Section, Name: WideString; Default: Double): Double; virtual; - function ReadTime(const Section, Name: WideString; Default: TDateTime): TDateTime; virtual; - procedure WriteBinaryStream(const Section, Name: WideString; Value: TStream); virtual; - procedure WriteDate(const Section, Name: WideString; Value: TDateTime); virtual; - procedure WriteDateTime(const Section, Name: WideString; Value: TDateTime); virtual; - procedure WriteFloat(const Section, Name: WideString; Value: Double); virtual; - procedure WriteTime(const Section, Name: WideString; Value: TDateTime); virtual; - procedure ReadSection(const Section: WideString; Strings: TTntStrings); virtual; abstract; - procedure ReadSections(Strings: TTntStrings); virtual; abstract; - procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); virtual; abstract; - procedure EraseSection(const Section: WideString); virtual; abstract; - procedure DeleteKey(const Section, Ident: WideString); virtual; abstract; - procedure UpdateFile; virtual; abstract; - function ValueExists(const Section, Ident: WideString): Boolean; - property FileName: WideString read FFileName; - end; - - { TTntStringHash - used internally by TTntMemIniFile to optimize searches. } - - PPTntHashItem = ^PTntHashItem; - PTntHashItem = ^TTntHashItem; - TTntHashItem = record - Next: PTntHashItem; - Key: WideString; - Value: Integer; - end; - - TTntStringHash = class - private - Buckets: array of PTntHashItem; - protected - function Find(const Key: WideString): PPTntHashItem; - function HashOf(const Key: WideString): Cardinal; virtual; - public - constructor Create(Size: Integer = 256); - destructor Destroy; override; - procedure Add(const Key: WideString; Value: Integer); - procedure Clear; - procedure Remove(const Key: WideString); - function Modify(const Key: WideString; Value: Integer): Boolean; - function ValueOf(const Key: WideString): Integer; - end; - - { TTntHashedStringList - A TTntStringList that uses TTntStringHash to improve the - speed of Find } - - TTntHashedStringList = class(TTntStringList) - private - FValueHash: TTntStringHash; - FNameHash: TTntStringHash; - FValueHashValid: Boolean; - FNameHashValid: Boolean; - procedure UpdateValueHash; - procedure UpdateNameHash; - protected - procedure Changed; override; - public - destructor Destroy; override; - function IndexOf(const S: WideString): Integer; override; - function IndexOfName(const Name: WideString): Integer; override; - end; - - { TTntMemIniFile - loads and entire ini file into memory and allows all - operations to be performed on the memory image. The image can then - be written out to the disk file } - - TTntMemIniFile = class(TTntCustomIniFile) - private - FSections: TTntStringList; - function AddSection(const Section: WideString): TTntStrings; - function GetCaseSensitive: Boolean; - procedure SetCaseSensitive(Value: Boolean); - procedure LoadValues; - public - constructor Create(const FileName: WideString); virtual; - destructor Destroy; override; - procedure Clear; - procedure DeleteKey(const Section, Ident: WideString); override; - procedure EraseSection(const Section: WideString); override; - procedure GetStrings(List: TTntStrings); - procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; - procedure ReadSections(Strings: TTntStrings); override; - procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; - function ReadString(const Section, Ident, Default: WideString): WideString; override; - procedure Rename(const FileName: WideString; Reload: Boolean); - procedure SetStrings(List: TTntStrings); - procedure UpdateFile; override; - procedure WriteString(const Section, Ident, Value: WideString); override; - property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive; - end; - -{$IFDEF MSWINDOWS} - { TTntIniFile - Encapsulates the Windows INI file interface - (Get/SetPrivateProfileXXX functions) } - - TTntIniFile = class(TTntCustomIniFile) - private - FAnsiIniFile: TIniFile; // For compatibility with Windows 95/98/Me - public - constructor Create(const FileName: WideString); virtual; - destructor Destroy; override; - function ReadString(const Section, Ident, Default: WideString): WideString; override; - procedure WriteString(const Section, Ident, Value: WideString); override; - procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; - procedure ReadSections(Strings: TTntStrings); override; - procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; - procedure EraseSection(const Section: WideString); override; - procedure DeleteKey(const Section, Ident: WideString); override; - procedure UpdateFile; override; - end; -{$ELSE} - TTntIniFile = class(TTntMemIniFile) - public - destructor Destroy; override; - end; -{$ENDIF} - - -implementation - -uses - RTLConsts, SysUtils, TntSysUtils -{$IFDEF COMPILER_9_UP} , WideStrUtils {$ELSE} , TntWideStrUtils {$ENDIF} -{$IFDEF MSWINDOWS} , Windows {$ENDIF}; - -{ TTntCustomIniFile } - -constructor TTntCustomIniFile.Create(const FileName: WideString); -begin - FFileName := FileName; -end; - -function TTntCustomIniFile.SectionExists(const Section: WideString): Boolean; -var - S: TTntStrings; -begin - S := TTntStringList.Create; - try - ReadSection(Section, S); - Result := S.Count > 0; - finally - S.Free; - end; -end; - -function TTntCustomIniFile.ReadInteger(const Section, Ident: WideString; - Default: Longint): Longint; -var - IntStr: WideString; -begin - IntStr := ReadString(Section, Ident, ''); - if (Length(IntStr) > 2) and (IntStr[1] = WideChar('0')) and - ((IntStr[2] = WideChar('X')) or (IntStr[2] = WideChar('x'))) then - IntStr := WideString('$') + Copy(IntStr, 3, Maxint); - Result := StrToIntDef(IntStr, Default); -end; - -procedure TTntCustomIniFile.WriteInteger(const Section, Ident: WideString; Value: Longint); -begin - WriteString(Section, Ident, IntToStr(Value)); -end; - -function TTntCustomIniFile.ReadBool(const Section, Ident: WideString; - Default: Boolean): Boolean; -begin - Result := ReadInteger(Section, Ident, Ord(Default)) <> 0; -end; - -function TTntCustomIniFile.ReadDate(const Section, Name: WideString; Default: TDateTime): TDateTime; -var - DateStr: WideString; -begin - DateStr := ReadString(Section, Name, ''); - Result := Default; - if DateStr <> '' then - try - Result := StrToDate(DateStr); - except - on EConvertError do - else raise; - end; -end; - -function TTntCustomIniFile.ReadDateTime(const Section, Name: WideString; Default: TDateTime): TDateTime; -var - DateStr: WideString; -begin - DateStr := ReadString(Section, Name, ''); - Result := Default; - if DateStr <> '' then - try - Result := StrToDateTime(DateStr); - except - on EConvertError do - else raise; - end; -end; - -function TTntCustomIniFile.ReadFloat(const Section, Name: WideString; Default: Double): Double; -var - FloatStr: WideString; -begin - FloatStr := ReadString(Section, Name, ''); - Result := Default; - if FloatStr <> '' then - try - Result := StrToFloat(FloatStr); - except - on EConvertError do - else raise; - end; -end; - -function TTntCustomIniFile.ReadTime(const Section, Name: WideString; Default: TDateTime): TDateTime; -var - TimeStr: WideString; -begin - TimeStr := ReadString(Section, Name, ''); - Result := Default; - if TimeStr <> '' then - try - Result := StrToTime(TimeStr); - except - on EConvertError do - else raise; - end; -end; - -procedure TTntCustomIniFile.WriteDate(const Section, Name: WideString; Value: TDateTime); -begin - WriteString(Section, Name, DateToStr(Value)); -end; - -procedure TTntCustomIniFile.WriteDateTime(const Section, Name: WideString; Value: TDateTime); -begin - WriteString(Section, Name, DateTimeToStr(Value)); -end; - -procedure TTntCustomIniFile.WriteFloat(const Section, Name: WideString; Value: Double); -begin - WriteString(Section, Name, FloatToStr(Value)); -end; - -procedure TTntCustomIniFile.WriteTime(const Section, Name: WideString; Value: TDateTime); -begin - WriteString(Section, Name, TimeToStr(Value)); -end; - -procedure TTntCustomIniFile.WriteBool(const Section, Ident: WideString; Value: Boolean); -const - Values: array[Boolean] of WideString = ('0', '1'); -begin - WriteString(Section, Ident, Values[Value]); -end; - -function TTntCustomIniFile.ValueExists(const Section, Ident: WideString): Boolean; -var - S: TTntStrings; -begin - S := TTntStringList.Create; - try - ReadSection(Section, S); - Result := S.IndexOf(Ident) > -1; - finally - S.Free; - end; -end; - -function TTntCustomIniFile.ReadBinaryStream(const Section, Name: WideString; - Value: TStream): Integer; -var - Text: String; // Not Unicode: Due to HexToBin is not Unicode - Stream: TMemoryStream; - Pos: Integer; -begin - Text := ReadString(Section, Name, ''); - if Text <> '' then - begin - if Value is TMemoryStream then - Stream := TMemoryStream(Value) - else Stream := TMemoryStream.Create; - try - Pos := Stream.Position; - Stream.SetSize(Stream.Size + Length(Text) div 2); - HexToBin(PChar(Text), PChar(Integer(Stream.Memory) + Stream.Position), Length(Text) div 2); - Stream.Position := Pos; - if Value <> Stream then Value.CopyFrom(Stream, Length(Text) div 2); - Result := Stream.Size - Pos; - finally - if Value <> Stream then Stream.Free; - end; - end else Result := 0; -end; - -procedure TTntCustomIniFile.WriteBinaryStream(const Section, Name: WideString; - Value: TStream); -var - Text: string; // Not Unicode: Due to BinToHex is not Unicode - Stream: TMemoryStream; -begin - SetLength(Text, (Value.Size - Value.Position) * 2); - if Length(Text) > 0 then - begin - if Value is TMemoryStream then - Stream := TMemoryStream(Value) - else Stream := TMemoryStream.Create; - try - if Stream <> Value then - begin - Stream.CopyFrom(Value, Value.Size - Value.Position); - Stream.Position := 0; - end; - BinToHex(PChar(Integer(Stream.Memory) + Stream.Position), PChar(Text), - Stream.Size - Stream.Position); - finally - if Value <> Stream then Stream.Free; - end; - end; - WriteString(Section, Name, Text); -end; - -{ TTntStringHash } - -procedure TTntStringHash.Add(const Key: WideString; Value: Integer); -var - Hash: Integer; - Bucket: PTntHashItem; -begin - Hash := HashOf(Key) mod Cardinal(Length(Buckets)); - New(Bucket); - Bucket^.Key := Key; - Bucket^.Value := Value; - Bucket^.Next := Buckets[Hash]; - Buckets[Hash] := Bucket; -end; - -procedure TTntStringHash.Clear; -var - I: Integer; - P, N: PTntHashItem; -begin - for I := 0 to Length(Buckets) - 1 do - begin - P := Buckets[I]; - while P <> nil do - begin - N := P^.Next; - Dispose(P); - P := N; - end; - Buckets[I] := nil; - end; -end; - -constructor TTntStringHash.Create(Size: Integer); -begin - inherited Create; - SetLength(Buckets, Size); -end; - -destructor TTntStringHash.Destroy; -begin - Clear; - inherited; -end; - -function TTntStringHash.Find(const Key: WideString): PPTntHashItem; -var - Hash: Integer; -begin - Hash := HashOf(Key) mod Cardinal(Length(Buckets)); - Result := @Buckets[Hash]; - while Result^ <> nil do - begin - if Result^.Key = Key then - Exit - else - Result := @Result^.Next; - end; -end; - -function TTntStringHash.HashOf(const Key: WideString): Cardinal; -var - I: Integer; -begin - Result := 0; - for I := 1 to Length(Key) do - Result := ((Result shl 2) or (Result shr (SizeOf(Result) * 8 - 2))) xor - Ord(Key[I]); // Is it OK for WideChar? -end; - -function TTntStringHash.Modify(const Key: WideString; Value: Integer): Boolean; -var - P: PTntHashItem; -begin - P := Find(Key)^; - if P <> nil then - begin - Result := True; - P^.Value := Value; - end - else - Result := False; -end; - -procedure TTntStringHash.Remove(const Key: WideString); -var - P: PTntHashItem; - Prev: PPTntHashItem; -begin - Prev := Find(Key); - P := Prev^; - if P <> nil then - begin - Prev^ := P^.Next; - Dispose(P); - end; -end; - -function TTntStringHash.ValueOf(const Key: WideString): Integer; -var - P: PTntHashItem; -begin - P := Find(Key)^; - if P <> nil then - Result := P^.Value else - Result := -1; -end; - -{ TTntHashedStringList } - -procedure TTntHashedStringList.Changed; -begin - inherited; - FValueHashValid := False; - FNameHashValid := False; -end; - -destructor TTntHashedStringList.Destroy; -begin - FValueHash.Free; - FNameHash.Free; - inherited; -end; - -function TTntHashedStringList.IndexOf(const S: WideString): Integer; -begin - UpdateValueHash; - if not CaseSensitive then - Result := FValueHash.ValueOf(WideUpperCase(S)) - else - Result := FValueHash.ValueOf(S); -end; - -function TTntHashedStringList.IndexOfName(const Name: WideString): Integer; -begin - UpdateNameHash; - if not CaseSensitive then - Result := FNameHash.ValueOf(WideUpperCase(Name)) - else - Result := FNameHash.ValueOf(Name); -end; - -procedure TTntHashedStringList.UpdateNameHash; -var - I: Integer; - P: Integer; - Key: WideString; -begin - if FNameHashValid then Exit; - if FNameHash = nil then - FNameHash := TTntStringHash.Create - else - FNameHash.Clear; - for I := 0 to Count - 1 do - begin - Key := Get(I); - P := Pos(NameValueSeparator, Key); - if P <> 0 then - begin - if not CaseSensitive then - Key := WideUpperCase(Copy(Key, 1, P - 1)) - else - Key := Copy(Key, 1, P - 1); - FNameHash.Add(Key, I); - end; - end; - FNameHashValid := True; -end; - -procedure TTntHashedStringList.UpdateValueHash; -var - I: Integer; -begin - if FValueHashValid then Exit; - if FValueHash = nil then - FValueHash := TTntStringHash.Create - else - FValueHash.Clear; - for I := 0 to Count - 1 do - if not CaseSensitive then - FValueHash.Add(WideUpperCase(Self[I]), I) - else - FValueHash.Add(Self[I], I); - FValueHashValid := True; -end; - -{ TTntMemIniFile } - -constructor TTntMemIniFile.Create(const FileName: WideString); -begin - inherited Create(FileName); - FSections := TTntHashedStringList.Create; - FSections.NameValueSeparator := '='; -{$IFDEF LINUX} - FSections.CaseSensitive := True; -{$ELSE} - FSections.CaseSensitive := False; -{$ENDIF} - LoadValues; -end; - -destructor TTntMemIniFile.Destroy; -begin - if FSections <> nil then Clear; - FSections.Free; - inherited; -end; - -function TTntMemIniFile.AddSection(const Section: WideString): TTntStrings; -begin - Result := TTntHashedStringList.Create; - try - TTntHashedStringList(Result).CaseSensitive := CaseSensitive; - FSections.AddObject(Section, Result); - except - Result.Free; - raise; - end; -end; - -procedure TTntMemIniFile.Clear; -var - I: Integer; -begin - for I := 0 to FSections.Count - 1 do - TObject(FSections.Objects[I]).Free; - FSections.Clear; -end; - -procedure TTntMemIniFile.DeleteKey(const Section, Ident: WideString); -var - I, J: Integer; - Strings: TTntStrings; -begin - I := FSections.IndexOf(Section); - if I >= 0 then - begin - Strings := TTntStrings(FSections.Objects[I]); - J := Strings.IndexOfName(Ident); - if J >= 0 then Strings.Delete(J); - end; -end; - -procedure TTntMemIniFile.EraseSection(const Section: WideString); -var - I: Integer; -begin - I := FSections.IndexOf(Section); - if I >= 0 then - begin - TStrings(FSections.Objects[I]).Free; - FSections.Delete(I); - end; -end; - -function TTntMemIniFile.GetCaseSensitive: Boolean; -begin - Result := FSections.CaseSensitive; -end; - -procedure TTntMemIniFile.GetStrings(List: TTntStrings); -var - I, J: Integer; - Strings: TTntStrings; -begin - List.BeginUpdate; - try - for I := 0 to FSections.Count - 1 do - begin - List.Add('[' + FSections[I] + ']'); - Strings := TTntStrings(FSections.Objects[I]); - for J := 0 to Strings.Count - 1 do - List.Add(Strings[J]); - List.Add(''); - end; - finally - List.EndUpdate; - end; -end; - -procedure TTntMemIniFile.LoadValues; -var - List: TTntStringList; -begin - if (FileName <> '') and WideFileExists(FileName) then - begin - List := TTntStringList.Create; - try - List.LoadFromFile(FileName); - SetStrings(List); - finally - List.Free; - end; - end else - Clear; -end; - -procedure TTntMemIniFile.ReadSection(const Section: WideString; - Strings: TTntStrings); -var - I, J: Integer; - SectionStrings: TTntStrings; -begin - Strings.BeginUpdate; - try - Strings.Clear; - I := FSections.IndexOf(Section); - if I >= 0 then - begin - SectionStrings := TTntStrings(FSections.Objects[I]); - for J := 0 to SectionStrings.Count - 1 do - Strings.Add(SectionStrings.Names[J]); - end; - finally - Strings.EndUpdate; - end; -end; - -procedure TTntMemIniFile.ReadSections(Strings: TTntStrings); -begin - Strings.Assign(FSections); -end; - -procedure TTntMemIniFile.ReadSectionValues(const Section: WideString; - Strings: TTntStrings); -var - I: Integer; -begin - Strings.BeginUpdate; - try - Strings.Clear; - I := FSections.IndexOf(Section); - if I >= 0 then Strings.Assign(TTntStrings(FSections.Objects[I])); - finally - Strings.EndUpdate; - end; -end; - -function TTntMemIniFile.ReadString(const Section, Ident, - Default: WideString): WideString; -var - I: Integer; - Strings: TTntStrings; -begin - I := FSections.IndexOf(Section); - if I >= 0 then - begin - Strings := TTntStrings(FSections.Objects[I]); - I := Strings.IndexOfName(Ident); - if I >= 0 then - begin - Result := Copy(Strings[I], Length(Ident) + 2, Maxint); - Exit; - end; - end; - Result := Default; -end; - -procedure TTntMemIniFile.Rename(const FileName: WideString; Reload: Boolean); -begin - FFileName := FileName; - if Reload then LoadValues; -end; - -procedure TTntMemIniFile.SetCaseSensitive(Value: Boolean); -var - I: Integer; -begin - if Value <> FSections.CaseSensitive then - begin - FSections.CaseSensitive := Value; - for I := 0 to FSections.Count - 1 do - with TTntHashedStringList(FSections.Objects[I]) do - begin - CaseSensitive := Value; - Changed; - end; - TTntHashedStringList(FSections).Changed; - end; -end; - -procedure TTntMemIniFile.SetStrings(List: TTntStrings); -var - I, J: Integer; - S: WideString; - Strings: TTntStrings; -begin - Clear; - Strings := nil; - for I := 0 to List.Count - 1 do - begin - S := Trim(List[I]); - if (S <> '') and (S[1] <> ';') then - if (S[1] = '[') and (S[Length(S)] = ']') then - begin - Delete(S, 1, 1); - SetLength(S, Length(S)-1); - Strings := AddSection(Trim(S)); - end - else - if Strings <> nil then - begin - J := Pos(FSections.NameValueSeparator, S); - if J > 0 then // remove spaces before and after NameValueSeparator - Strings.Add(Trim(Copy(S, 1, J-1)) + FSections.NameValueSeparator + TrimRight(Copy(S, J+1, MaxInt)) ) - else - Strings.Add(S); - end; - end; -end; - -procedure TTntMemIniFile.UpdateFile; -var - List: TTntStringList; -begin - List := TTntStringList.Create; - try - GetStrings(List); - List.SaveToFile(FFileName); - finally - List.Free; - end; -end; - -procedure TTntMemIniFile.WriteString(const Section, Ident, Value: WideString); -var - I: Integer; - S: WideString; - Strings: TTntStrings; -begin - I := FSections.IndexOf(Section); - if I >= 0 then - Strings := TTntStrings(FSections.Objects[I]) else - Strings := AddSection(Section); - S := Ident + FSections.NameValueSeparator + Value; - I := Strings.IndexOfName(Ident); - if I >= 0 then Strings[I] := S else Strings.Add(S); -end; - - - -{$IFDEF MSWINDOWS} -{ TTntIniFile } - -constructor TTntIniFile.Create(const FileName: WideString); -begin - inherited Create(FileName); - if (not Win32PlatformIsUnicode) then - FAnsiIniFile := TIniFile.Create(FileName); -end; - -destructor TTntIniFile.Destroy; -begin - UpdateFile; // flush changes to disk - if (not Win32PlatformIsUnicode) then - FAnsiIniFile.Free; - inherited Destroy; -end; - -function TTntIniFile.ReadString(const Section, Ident, Default: WideString): WideString; -var - Buffer: array[0..2047] of WideChar; -begin - if (not Win32PlatformIsUnicode) then - { Windows 95/98/Me } - Result := FAnsiIniFile.ReadString(Section, Ident, Default) - else begin - { Windows NT/2000/XP and later } - GetPrivateProfileStringW(PWideChar(Section), - PWideChar(Ident), PWideChar(Default), Buffer, Length(Buffer), PWideChar(FFileName)); - Result := WideString(Buffer); - end; -end; - -procedure TTntIniFile.WriteString(const Section, Ident, Value: WideString); -begin - if (not Win32PlatformIsUnicode) then - { Windows 95/98/Me } - FAnsiIniFile.WriteString(Section, Ident, Value) - else begin - { Windows NT/2000/XP and later } - if not WritePrivateProfileStringW(PWideChar(Section), PWideChar(Ident), - PWideChar(Value), PWideChar(FFileName)) then - raise EIniFileException.CreateResFmt(@SIniFileWriteError, [FileName]); - end; -end; - -procedure TTntIniFile.ReadSections(Strings: TTntStrings); -const - BufSize = 16384 * SizeOf(WideChar); -var - Buffer, P: PWideChar; -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.ReadSections(Strings.AnsiStrings); - end else - begin - { Windows NT/2000/XP and later } - GetMem(Buffer, BufSize); - try - Strings.BeginUpdate; - try - Strings.Clear; - if GetPrivateProfileStringW(nil, nil, nil, Buffer, BufSize, - PWideChar(FFileName)) <> 0 then - begin - P := Buffer; - while P^ <> WideChar(#0) do - begin - Strings.Add(P); - Inc(P, WStrLen(P) + 1); - end; - end; - finally - Strings.EndUpdate; - end; - finally - FreeMem(Buffer, BufSize); - end; - end; {else} -end; - -procedure TTntIniFile.ReadSection(const Section: WideString; Strings: TTntStrings); -const - BufSize = 16384 * SizeOf(WideChar); -var - Buffer, P: PWideChar; -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.ReadSection(Section, Strings.AnsiStrings); - end else - begin - { Windows NT/2000/XP and later } - GetMem(Buffer, BufSize); - try - Strings.BeginUpdate; - try - Strings.Clear; - if GetPrivateProfileStringW(PWideChar(Section), nil, nil, Buffer, BufSize, - PWideChar(FFileName)) <> 0 then - begin - P := Buffer; - while P^ <> #0 do - begin - Strings.Add(P); - Inc(P, WStrLen(P) + 1); - end; - end; - finally - Strings.EndUpdate; - end; - finally - FreeMem(Buffer, BufSize); - end; - end; -end; - -procedure TTntIniFile.ReadSectionValues(const Section: WideString; Strings: TTntStrings); -var - KeyList: TTntStringList; - I: Integer; -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.ReadSectionValues(Section, Strings.AnsiStrings); - end else - begin - { Windows NT/2000/XP and later } - KeyList := TTntStringList.Create; - try - ReadSection(Section, KeyList); - Strings.BeginUpdate; - try - Strings.Clear; - for I := 0 to KeyList.Count - 1 do - Strings.Add(KeyList[I] + '=' + ReadString(Section, KeyList[I], '')) - finally - Strings.EndUpdate; - end; - finally - KeyList.Free; - end; - end; {if} -end; - -procedure TTntIniFile.EraseSection(const Section: WideString); -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.EraseSection(Section); - end - else begin - { Windows NT/2000/XP and later } - if not WritePrivateProfileStringW(PWideChar(Section), nil, nil, - PWideChar(FFileName)) then - raise EIniFileException.CreateResFmt(@SIniFileWriteError, [FileName]); - end; {if} -end; - -procedure TTntIniFile.DeleteKey(const Section, Ident: WideString); -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.DeleteKey(Section, Ident); - end - else begin - { Windows NT/2000/XP and later } - WritePrivateProfileStringW(PWideChar(Section), PWideChar(Ident), nil, - PWideChar(FFileName)); - end; {if} -end; - -procedure TTntIniFile.UpdateFile; -begin - if (not Win32PlatformIsUnicode) then - begin - { Windows 95/98/Me } - FAnsiIniFile.UpdateFile - end - else begin - { Windows NT/2000/XP and later } - WritePrivateProfileStringW(nil, nil, nil, PWideChar(FFileName)); - end; {if} -end; - -{$ELSE} - -destructor TTntIniFile.Destroy; -begin - UpdateFile; - inherited Destroy; -end; - -{$ENDIF} - - - - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas deleted file mode 100644 index 87ec613976..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas +++ /dev/null @@ -1,205 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Extended TTntMemIniFile (compatible with all versions) } -{ } -{ Copyright (c) 1999-2007 Stanley Xu } -{ http://getgosurf.com/?go=supportFeedback&ln=en } -{ } -{*****************************************************************************} - -{*****************************************************************************} -{ } -{ BACKGROUND: } -{ TTntMemIniFile buffers all changes to the INI file in memory. To write } -{ the data from memory back to the associated INI file, call the } -{ UpdateFile() method. However, the whole content of this INI file will } -{ be overwritten. Even those sections that are not used. This will make } -{ troubles, if two instances try to change the same file at the same } -{ time, without some method of managing access the instances may well end } -{ up overwriting each other's work. } -{ } -{ IDEA: } -{ TTntMemIniFileEx implementes a simple idea: To check the timestamp } -{ before each operation. If the file is modified, TTntMemIniFileEx will } -{ reload the file to keep the content updated. } -{ } -{ CONCLUSION: } -{ # TTntMemIniFileEx and TTntMemIniFile are ideal for read-only access. } -{ For instance: To read localization files, etc. } -{ # To perform mass WriteString() operations, please use the following } -{ code. } -{ BeginUpdate(); } -{ try } -{ for I := 0 to 10000 do } -{ WriteString(...); } -{ finally; } -{ EndUpdate(); } -{ UpdateFile; } -{ end; } -{ } -{*****************************************************************************} - -unit TntIniFilesEx; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - TntClasses, TntIniFiles; - -type - TTntMemIniFileEx = class(TTntMemIniFile) - private - FUpdateCount: Integer; - FModified: Boolean; - FLastAccessed: Integer; - function FileRealLastAccessedTime: Integer; - procedure GetLatestVersion; - protected - procedure LoadValues; // Extended - public - constructor Create(const FileName: WideString); override; - procedure BeginUpdate; virtual; - procedure EndUpdate; virtual; - function ReadString(const Section, Ident, Default: WideString): WideString; override; - procedure WriteString(const Section, Ident, Value: WideString); override; - procedure ReadSection(const Section: WideString; Strings: TTntStrings); override; - procedure ReadSections(Strings: TTntStrings); override; - procedure ReadSectionValues(const Section: WideString; Strings: TTntStrings); override; - procedure DeleteKey(const Section, Ident: WideString); override; - procedure EraseSection(const Section: WideString); override; - procedure UpdateFile; override; - end; - - - -implementation - -uses - SysUtils, TntSysUtils; - - -{ TTntMemIniFileEx } - -function TTntMemIniFileEx.FileRealLastAccessedTime: Integer; -var - H: Integer; // file handle -begin - Result := 0; - H := WideFileOpen(FileName, fmOpenWrite); //fmOpenRead (?) - if H <> -1 then - try - Result := FileGetDate(H); - finally - FileClose(H); - end; -end; - -procedure TTntMemIniFileEx.GetLatestVersion; -begin - if FLastAccessed = FileRealLastAccessedTime then - Exit; - - LoadValues; - // FLastAccess will be updated in LoadValues(...) -end; - -procedure TTntMemIniFileEx.LoadValues; // Copied from TntIniFiles.pas -var - List: TTntStringList; -begin - if (FileName <> '') and WideFileExists(FileName) then - begin - List := TTntStringList.Create; - try - List.LoadFromFile(FileName); - FLastAccessed := FileRealLastAccessedTime; // Extra - FModified := False; // - SetStrings(List); - finally - List.Free; - end; - end else - Clear; -end; - -constructor TTntMemIniFileEx.Create(const FileName: WideString); -begin - inherited Create(FileName); - FUpdateCount := 0; -end; - -procedure TTntMemIniFileEx.BeginUpdate; -begin - Inc(FUpdateCount); -end; - -procedure TTntMemIniFileEx.EndUpdate; -begin - Dec(FUpdateCount); -end; - -function TTntMemIniFileEx.ReadString(const Section, Ident, Default: WideString): WideString; -begin - GetLatestVersion; - Result := inherited ReadString(Section, Ident, Default); -end; - -procedure TTntMemIniFileEx.WriteString(const Section, Ident, Value: WideString); -begin - GetLatestVersion; - inherited WriteString(Section, Ident, Value); - FModified := True; - UpdateFile; // Flush changes to disk -end; - -procedure TTntMemIniFileEx.ReadSection(const Section: WideString; Strings: TTntStrings); -begin - GetLatestVersion; - inherited ReadSection(Section, Strings); -end; - -procedure TTntMemIniFileEx.ReadSections(Strings: TTntStrings); -begin - GetLatestVersion; - inherited ReadSections(Strings); -end; - -procedure TTntMemIniFileEx.ReadSectionValues(const Section: WideString; Strings: TTntStrings); -begin - GetLatestVersion; - inherited ReadSectionValues(Section, Strings); -end; - -procedure TTntMemIniFileEx.DeleteKey(const Section, Ident: WideString); -begin - GetLatestVersion; - inherited DeleteKey(Section, Ident); - FModified := True; - UpdateFile; // Flush changes to disk -end; - -procedure TTntMemIniFileEx.EraseSection(const Section: WideString); -begin - GetLatestVersion; - inherited EraseSection(Section); - FModified := True; - UpdateFile; // Flush changes to disk -end; - -procedure TTntMemIniFileEx.UpdateFile; -begin - if not FModified or (FUpdateCount > 0) then - Exit; - inherited; -end; - - - - - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas deleted file mode 100644 index 00601c0449..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas +++ /dev/null @@ -1,207 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntListActns; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, TntActnList, ListActns; - -type -{TNT-WARN TCustomListAction} - TTntCustomListAction = class(TCustomListAction{TNT-ALLOW TCustomListAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TStaticListAction} - TTntStaticListAction = class(TStaticListAction{TNT-ALLOW TStaticListAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TVirtualListAction} - TTntVirtualListAction = class(TVirtualListAction{TNT-ALLOW TVirtualListAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -implementation - -uses - ActnList, TntClasses; - -{TNT-IGNORE-UNIT} - -type TAccessCustomListAction = class(TCustomListAction); - -procedure TntListActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntAction_AfterInherited_Assign(Action, Source); - // TCustomListAction - if (Action is TCustomListAction) and (Source is TCustomListAction) then begin - TAccessCustomListAction(Action).Images := TAccessCustomListAction(Source).Images; - TAccessCustomListAction(Action).OnGetItemCount := TAccessCustomListAction(Source).OnGetItemCount; - TAccessCustomListAction(Action).OnItemSelected := TAccessCustomListAction(Source).OnItemSelected; - TAccessCustomListAction(Action).Active := TAccessCustomListAction(Source).Active; - TAccessCustomListAction(Action).ItemIndex := TAccessCustomListAction(Source).ItemIndex; - end; - // TStaticListAction - if (Action is TStaticListAction) and (Source is TStaticListAction) then begin - TStaticListAction(Action).Items := TStaticListAction(Source).Items; - TStaticListAction(Action).OnGetItem := TStaticListAction(Source).OnGetItem; - end; - // TVirtualListAction - if (Action is TVirtualListAction) and (Source is TVirtualListAction) then begin - TVirtualListAction(Action).OnGetItem := TVirtualListAction(Source).OnGetItem; - end; -end; - -//------------------------- -// TNT LIST ACTNS -//------------------------- - -{ TTntCustomListAction } - -procedure TTntCustomListAction.Assign(Source: TPersistent); -begin - inherited; - TntListActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntCustomListAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomListAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntCustomListAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntCustomListAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntCustomListAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntStaticListAction } - -procedure TTntStaticListAction.Assign(Source: TPersistent); -begin - inherited; - TntListActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntStaticListAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntStaticListAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntStaticListAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntStaticListAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntStaticListAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntVirtualListAction } - -procedure TTntVirtualListAction.Assign(Source: TPersistent); -begin - inherited; - TntListActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntVirtualListAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntVirtualListAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntVirtualListAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntVirtualListAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntVirtualListAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas deleted file mode 100644 index 577764661c..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas +++ /dev/null @@ -1,1146 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntMenus; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, Classes, Menus, Graphics, Messages; - -type -{TNT-WARN TMenuItem} - TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem}) - private - FIgnoreMenuChanged: Boolean; - FCaption: WideString; - FHint: WideString; - FKeyboardLayout: HKL; - function GetCaption: WideString; - procedure SetInheritedCaption(const Value: AnsiString); - procedure SetCaption(const Value: WideString); - function IsCaptionStored: Boolean; - procedure UpdateMenuString(ParentMenu: TMenu); - function GetAlignmentDrawStyle: Word; - function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; - function GetHint: WideString; - procedure SetInheritedHint(const Value: AnsiString); - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TMenuActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure MenuChanged(Rebuild: Boolean); override; - procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; - State: TOwnerDrawState; TopLevel: Boolean); override; - procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString; - var Rect: TRect; Selected: Boolean; Flags: Integer); - procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override; - public - procedure InitiateAction; override; - procedure Loaded; override; - function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; - published - property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TMainMenu} - TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu}) - protected - procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; - public - {$IFDEF COMPILER_9_UP} - function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; - {$ENDIF} - end; - -{TNT-WARN TPopupMenu} - TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu}) - protected - procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - {$IFDEF COMPILER_9_UP} - function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override; - {$ENDIF} - destructor Destroy; override; - procedure Popup(X, Y: Integer); override; - end; - -{TNT-WARN NewSubMenu} -function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; - const AName: TComponentName; const Items: array of TTntMenuItem; - AEnabled: Boolean): TTntMenuItem; -{TNT-WARN NewItem} -function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; - AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; - const AName: TComponentName): TTntMenuItem; - -function MessageToShortCut(Msg: TWMKeyDown): TShortCut; - -{TNT-WARN ShortCutToText} -function WideShortCutToText(WordShortCut: Word): WideString; -{TNT-WARN TextToShortCut} -function WideTextToShortCut(Text: WideString): TShortCut; -{TNT-WARN GetHotKey} -function WideGetHotkey(const Text: WideString): WideString; -{TNT-WARN StripHotkey} -function WideStripHotkey(const Text: WideString): WideString; -{TNT-WARN AnsiSameCaption} -function WideSameCaption(const Text1, Text2: WideString): Boolean; - -function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; -function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; - -procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); - -procedure FixMenuBiDiProblem(Menu: TMenu); - -function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; - -type - TTntPopupList = class(TPopupList) - private - SavedPopupList: TPopupList; - protected - procedure WndProc(var Message: TMessage); override; - end; - -var - TntPopupList: TTntPopupList; - -implementation - -uses - Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics, - TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows; - -function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext; - const AName: TComponentName; const Items: array of TTntMenuItem; - AEnabled: Boolean): TTntMenuItem; -var - I: Integer; -begin - Result := TTntMenuItem.Create(nil); - for I := Low(Items) to High(Items) do - Result.Add(Items[I]); - Result.Caption := ACaption; - Result.HelpContext := hCtx; - Result.Name := AName; - Result.Enabled := AEnabled; -end; - -function WideNewItem(const ACaption: WideString; AShortCut: TShortCut; - AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext; - const AName: TComponentName): TTntMenuItem; -begin - Result := TTntMenuItem.Create(nil); - with Result do - begin - Caption := ACaption; - ShortCut := AShortCut; - OnClick := AOnClick; - HelpContext := hCtx; - Checked := AChecked; - Enabled := AEnabled; - Name := AName; - end; -end; - -function MessageToShortCut(Msg: TWMKeyDown): TShortCut; -var - ShiftState: TShiftState; -begin - ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData); - Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState); -end; - -function WideGetSpecialName(WordShortCut: Word): WideString; -var - ScanCode: Integer; - KeyName: array[0..255] of WideChar; -begin - Assert(Win32PlatformIsUnicode); - Result := ''; - ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16; - if ScanCode <> 0 then - begin - GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName)); - Result := KeyName; - end; -end; - -function WideGetKeyboardChar(Key: Word): WideChar; -var - LatinNumChar: WideChar; -begin - Assert(Win32PlatformIsUnicode); - Result := WideChar(MapVirtualKeyW(Key, 2)); - if (Key in [$30..$39]) then - begin - // Check to see if "0" - "9" can be used if all that differs is shift state - LatinNumChar := WideChar(Key - $30 + Ord('0')); - if (Result <> LatinNumChar) - and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then // .Hi would be the shift state - Result := LatinNumChar; - end; -end; - -function WideShortCutToText(WordShortCut: Word): WideString; -var - Name: WideString; -begin - if (not Win32PlatformIsUnicode) - or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav}, - $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}]) - then - Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut) - else begin - case WordRec(WordShortCut).Lo of - $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0} - $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z} - $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0} - else - Name := WideGetSpecialName(WordShortCut); - end; - if Name <> '' then - begin - Result := ''; - if WordShortCut and scShift <> 0 then Result := Result + SmkcShift; - if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl; - if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt; - Result := Result + Name; - end - else Result := ''; - end; -end; - -{ This function is *very* slow. Use sparingly. Return 0 if no VK code was - found for the text } - -function WideTextToShortCut(Text: WideString): TShortCut; - - { If the front of Text is equal to Front then remove the matching piece - from Text and return True, otherwise return False } - - function CompareFront(var Text: WideString; const Front: WideString): Boolean; - begin - Result := (Pos(Front, Text) = 1); - if Result then - Delete(Text, 1, Length(Front)); - end; - -var - Key: TShortCut; - Shift: TShortCut; -begin - Result := 0; - Shift := 0; - while True do - begin - if CompareFront(Text, SmkcShift) then Shift := Shift or scShift - else if CompareFront(Text, '^') then Shift := Shift or scCtrl - else if CompareFront(Text, SmkcCtrl) then Shift := Shift or scCtrl - else if CompareFront(Text, SmkcAlt) then Shift := Shift or scAlt - else Break; - end; - if Text = '' then Exit; - for Key := $08 to $255 do { Copy range from table in ShortCutToText } - if WideSameText(Text, WideShortCutToText(Key)) then - begin - Result := Key or Shift; - Exit; - end; -end; - -function WideGetHotkeyPos(const Text: WideString): Integer; -var - I, L: Integer; -begin - Result := 0; - I := 1; - L := Length(Text); - while I <= L do - begin - if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then - begin - Inc(I); - if Text[I] <> cHotkeyPrefix then - Result := I; // this might not be the last - end; - Inc(I); - end; -end; - -function WideGetHotkey(const Text: WideString): WideString; -var - I: Integer; -begin - I := WideGetHotkeyPos(Text); - if I = 0 then - Result := '' - else - Result := Text[I]; -end; - -function WideStripHotkey(const Text: WideString): WideString; -var - I: Integer; -begin - Result := Text; - I := 1; - while I <= Length(Result) do - begin - if Result[I] = cHotkeyPrefix then - if SysLocale.FarEast - and ((I > 1) and (Length(Result) - I >= 2) - and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin - Delete(Result, I - 1, 4); - Dec(I, 2); - end else - Delete(Result, I, 1); - Inc(I); - end; -end; - -function WideSameCaption(const Text1, Text2: WideString): Boolean; -begin - Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2)); -end; - -function WideSameCaptionStr(const Text1, Text2: WideString): Boolean; -begin - Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2)); -end; - -function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; -begin - if MenuItem is TTntMenuItem then - Result := TTntMenuItem(MenuItem).Caption - else - Result := MenuItem.Caption; -end; - -function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString; -begin - if MenuItem is TTntMenuItem then - Result := TTntMenuItem(MenuItem).Hint - else - Result := MenuItem.Hint; -end; - -procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu}); -{If top-level items are created as owner-drawn, they will not appear as raised -buttons when the mouse hovers over them. The VCL will often create top-level -items as owner-drawn even when they don't need to be (owner-drawn state can be -set on an item-by-item basis). This routine turns off the owner-drawn flag for -top-level items if it appears unnecessary} - - function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean; - var - Images: TCustomImageList; - begin - Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil'); - Images := Item.GetImageList; - Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count)) - or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty)) - end; - -var - HM: HMenu; - i: integer; - Info: TMenuItemInfoA; - Item: TMenuItem{TNT-ALLOW TMenuItem}; - Win98Plus: boolean; -begin - if Assigned(Menu) then begin - Win98Plus:= (Win32MajorVersion > 4) - or((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); - if not Win98Plus then - Exit; {exit if Windows 95 or NT 4.0} - HM:= Menu.Handle; - Info.cbSize:= sizeof(Info); - for i := 0 to GetMenuItemCount(HM) - 1 do begin - Info.fMask:= MIIM_FTYPE or MIIM_ID; - if not GetMenuItemInfo(HM, i, true, Info) then - Break; - if Info.fType and MFT_OWNERDRAW <> 0 then begin - Item:= Menu.FindItem(Info.wID, fkCommand); - if not Assigned(Item) then - continue; - if Assigned(Item.OnDrawItem) - or Assigned(Item.OnAdvancedDrawItem) - or ItemHasValidImage(Item) then - Continue; - Info.fMask:= MIIM_FTYPE or MIIM_STRING; - Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING; - if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin - // Unicode - TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption); - SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info)); - end else begin - // Ansi - Info.dwTypeData:= PAnsiChar(Item.Caption); - SetMenuItemInfoA(HM, i, true, Info); - end; - end; - end; - end; -end; - -{ TTntMenuItem's utility procs } - -procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString); -var - I: Integer; - FarEastHotString: WideString; -begin - if (AnsiString(Source) <> AnsiString(Dest)) - and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin - // when reduced to ansi, the only difference is hot key positions - Dest := WideStripHotkey(Dest); - I := 1; - while I <= Length(Source) do - begin - if Source[I] = cHotkeyPrefix then begin - if SysLocale.FarEast - and ((I > 1) and (Length(Source) - I >= 2) - and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin - FarEastHotString := Copy(Source, I - 1, 4); - Dec(I); - Insert(FarEastHotString, Dest, I); - Inc(I, 3); - end else begin - Insert(cHotkeyPrefix, Dest, I); - Inc(I); - end; - end; - Inc(I); - end; - // test work - if AnsiString(Source) <> AnsiString(Dest) then - raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").', - [AnsiString(Source), AnsiString(Dest)]); - end; -end; - -procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu); -var - i: integer; -begin - if (Items.ComponentState * [csReading, csDestroying] = []) then begin - for i := Items.Count - 1 downto 0 do - UpdateMenuItems(Items[i], ParentMenu); - if Items is TTntMenuItem then - TTntMenuItem(Items).UpdateMenuString(ParentMenu); - end; -end; - -procedure FixMenuBiDiProblem(Menu: TMenu); -var - i: integer; -begin - // TMenu sometimes sets bidi on first visible item which can convert caption to ansi - if (SysLocale.MiddleEast) - and (Menu <> nil) - and (Menu.Items.Count > 0) then - begin - for i := 0 to Menu.Items.Count - 1 do begin - if Menu.Items[i].Visible then begin - if (Menu.Items[i] is TTntMenuItem) then - (Menu.Items[i] as TTntMenuItem).UpdateMenuString(Menu); - break; // found first visible menu item! - end; - end; - end; -end; - - -{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 -type - THackMenuItem = class(TComponent) - protected - FxxxxCaption: Ansistring; - FxxxxHandle: HMENU; - FxxxxChecked: Boolean; - FxxxxEnabled: Boolean; - FxxxxDefault: Boolean; - FxxxxAutoHotkeys: TMenuItemAutoFlag; - FxxxxAutoLineReduction: TMenuItemAutoFlag; - FxxxxRadioItem: Boolean; - FxxxxVisible: Boolean; - FxxxxGroupIndex: Byte; - FxxxxImageIndex: TImageIndex; - FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; - FxxxxBreak: TMenuBreak; - FBitmap: TBitmap; - FxxxxCommand: Word; - FxxxxHelpContext: THelpContext; - FxxxxHint: AnsiString; - FxxxxItems: TList; - FxxxxShortCut: TShortCut; - FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; - FMerged: TMenuItem{TNT-ALLOW TMenuItem}; - FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; - end; -{$ENDIF} -{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 -type - THackMenuItem = class(TComponent) - protected - FxxxxCaption: AnsiString; - FxxxxHandle: HMENU; - FxxxxChecked: Boolean; - FxxxxEnabled: Boolean; - FxxxxDefault: Boolean; - FxxxxAutoHotkeys: TMenuItemAutoFlag; - FxxxxAutoLineReduction: TMenuItemAutoFlag; - FxxxxRadioItem: Boolean; - FxxxxVisible: Boolean; - FxxxxGroupIndex: Byte; - FxxxxImageIndex: TImageIndex; - FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; - FxxxxBreak: TMenuBreak; - FBitmap: TBitmap; - FxxxxCommand: Word; - FxxxxHelpContext: THelpContext; - FxxxxHint: AnsiString; - FxxxxItems: TList; - FxxxxShortCut: TShortCut; - FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; - FMerged: TMenuItem{TNT-ALLOW TMenuItem}; - FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; - end; -{$ENDIF} -{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 -type - THackMenuItem = class(TComponent) - protected - FxxxxCaption: AnsiString; - FxxxxHandle: HMENU; - FxxxxChecked: Boolean; - FxxxxEnabled: Boolean; - FxxxxDefault: Boolean; - FxxxxAutoHotkeys: TMenuItemAutoFlag; - FxxxxAutoLineReduction: TMenuItemAutoFlag; - FxxxxRadioItem: Boolean; - FxxxxVisible: Boolean; - FxxxxGroupIndex: Byte; - FxxxxImageIndex: TImageIndex; - FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; - FxxxxBreak: TMenuBreak; - FBitmap: TBitmap; - FxxxxCommand: Word; - FxxxxHelpContext: THelpContext; - FxxxxHint: AnsiString; - FxxxxItems: TList; - FxxxxShortCut: TShortCut; - FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; - FMerged: TMenuItem{TNT-ALLOW TMenuItem}; - FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; - end; -{$ENDIF} -{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 -type - THackMenuItem = class(TComponent) - protected - FxxxxCaption: AnsiString; - FxxxxHandle: HMENU; - FxxxxChecked: Boolean; - FxxxxEnabled: Boolean; - FxxxxDefault: Boolean; - FxxxxAutoHotkeys: TMenuItemAutoFlag; - FxxxxAutoLineReduction: TMenuItemAutoFlag; - FxxxxRadioItem: Boolean; - FxxxxVisible: Boolean; - FxxxxGroupIndex: Byte; - FxxxxImageIndex: TImageIndex; - FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink}; - FxxxxBreak: TMenuBreak; - FBitmap: TBitmap; - FxxxxCommand: Word; - FxxxxHelpContext: THelpContext; - FxxxxHint: AnsiString; - FxxxxItems: TList; - FxxxxShortCut: TShortCut; - FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem}; - FMerged: TMenuItem{TNT-ALLOW TMenuItem}; - FMergedWith: TMenuItem{TNT-ALLOW TMenuItem}; - end; -{$ENDIF} - -function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean; -begin - Result := Assigned(THackMenuItem(MenuItem).FBitmap); -end; - -{ TTntMenuItem } - -procedure TTntMenuItem.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -type TAccessActionlink = class(TActionLink); - -procedure TTntMenuItem.InitiateAction; -begin - if GetKeyboardLayout(0) <> FKeyboardLayout then - MenuChanged(False); - inherited; -end; - -function TTntMenuItem.IsCaptionStored: Boolean; -begin - Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked); -end; - -procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString); -begin - inherited Caption := Value; -end; - -function TTntMenuItem.GetCaption: WideString; -begin - if (AnsiString(FCaption) <> inherited Caption) - and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then - begin - // only difference is hotkey position, update caption with new hotkey position - SyncHotKeyPosition(inherited Caption, FCaption); - end; - Result := GetSyncedWideString(FCaption, (inherited Caption)); -end; - -procedure TTntMenuItem.SetCaption(const Value: WideString); -begin - GetCaption; // auto adjust for hot key changes - SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption); -end; - -function TTntMenuItem.GetHint: WideString; -begin - Result := GetSyncedWideString(FHint, inherited Hint); -end; - -procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString); -begin - inherited Hint := Value; -end; - -procedure TTntMenuItem.SetHint(const Value: WideString); -begin - SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint); -end; - -function TTntMenuItem.IsHintStored: Boolean; -begin - Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked; -end; - -procedure TTntMenuItem.Loaded; -begin - inherited; - UpdateMenuString(GetParentMenu); -end; - -procedure TTntMenuItem.MenuChanged(Rebuild: Boolean); -begin - if (not FIgnoreMenuChanged) then begin - inherited; - UpdateMenuItems(Self, GetParentMenu); - FixMenuBiDiProblem(GetParentMenu); - end; -end; - -procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu); -var - ParentHandle: THandle; - - function NativeMenuTypeIsString: Boolean; - var - MenuItemInfo: TMenuItemInfoW; - Buffer: array[0..79] of WideChar; - begin - MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 - MenuItemInfo.fMask := MIIM_TYPE; - MenuItemInfo.dwTypeData := Buffer; // ?? - MenuItemInfo.cch := Length(Buffer); // ?? - Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) - and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) - end; - - function NativeMenuString: WideString; - var - Len: Integer; - begin - Assert(Win32PlatformIsUnicode); - Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND); - if Len = 0 then - Result := '' - else begin - SetLength(Result, Len + 1); - Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND); - SetLength(Result, Len); - end; - end; - - procedure SetMenuString(const Value: WideString); - var - MenuItemInfo: TMenuItemInfoW; - Buffer: array[0..79] of WideChar; - begin - MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0 - MenuItemInfo.fMask := MIIM_TYPE; - MenuItemInfo.dwTypeData := Buffer; // ?? - MenuItemInfo.cch := Length(Buffer); // ?? - if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo) - and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then - begin - MenuItemInfo.dwTypeData := PWideChar(Value); - MenuItemInfo.cch := Length(Value); - Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)); - end; - end; - - function SameEvent(A, B: TMenuMeasureItemEvent): Boolean; - begin - Result := @A = @B; - end; - -var - MenuCaption: WideString; -begin - FKeyboardLayout := GetKeyboardLayout(0); - if Parent = nil then - ParentHandle := 0 - else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then - ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle - else - ParentHandle := Parent.Handle; - - if (Win32PlatformIsUnicode) - and (Parent <> nil) and (ParentMenu <> nil) - and (ComponentState * [csReading, csDestroying] = []) - and (Visible) - and (NativeMenuTypeIsString) then begin - MenuCaption := Caption; - if (Count = 0) - and ((ShortCut <> scNone) - and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then - MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut); - if (NativeMenuString <> MenuCaption) then - begin - SetMenuString(MenuCaption); - if ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil)) - and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu}) - and (ParentMenu.WindowHandle <> 0) then - DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items} - end; - end; -end; - -function TTntMenuItem.GetAlignmentDrawStyle: Word; -const - Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); -var - ParentMenu: TMenu; - Alignment: TPopupAlignment; -begin - ParentMenu := GetParentMenu; - if ParentMenu is TMenu then - Alignment := paLeft - else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then - Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment - else - Alignment := paLeft; - Result := Alignments[Alignment]; -end; - -procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; - State: TOwnerDrawState; TopLevel: Boolean); - - procedure DrawMenuText(BiDi: Boolean); - var - ImageList: TCustomImageList; - DrawImage, DrawGlyph: Boolean; - GlyphRect, SaveRect: TRect; - DrawStyle: Longint; - Selected: Boolean; - Win98Plus: Boolean; - Win2K: Boolean; - begin - ImageList := GetImageList; - Selected := odSelected in State; - Win98Plus := (Win32MajorVersion > 4) or - ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)); - Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT); - with ACanvas do - begin - GlyphRect.Left := ARect.Left + 1; - DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and - (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or - Bitmap.Empty)); - if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then - begin - DrawGlyph := True; - if DrawImage then - GlyphRect.Right := GlyphRect.Left + ImageList.Width - else begin - { Need to add BitmapWidth/Height properties for TMenuItem if we're to - support them. Right now let's hardcode them to 16x16. } - GlyphRect.Right := GlyphRect.Left + 16; - end; - { Draw background pattern brush if selected } - if Checked then - begin - Inc(GlyphRect.Right); - if not Selected then - Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); - Inc(GlyphRect.Left); - end; - if Checked then - Dec(GlyphRect.Right); - end else begin - if (ImageList <> nil) and (not TopLevel) then - GlyphRect.Right := GlyphRect.Left + ImageList.Width - else - GlyphRect.Right := GlyphRect.Left; - DrawGlyph := False; - end; - if BiDi then begin - SaveRect := GlyphRect; - GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left); - GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left); - end; - with GlyphRect do begin - Dec(Left); - Inc(Right, 2); - end; - if Selected then begin - if DrawGlyph then begin - if BiDi then - ARect.Right := GlyphRect.Left - 1 - else - ARect.Left := GlyphRect.Right + 1; - end; - if not (Win98Plus and TopLevel) then - Brush.Color := clHighlight; - end; - if TopLevel and Win98Plus and (not Selected) - {$IFDEF COMPILER_7_UP} - and (not Win32PlatformIsXP) - {$ENDIF} - then - OffsetRect(ARect, 0, -1); - if not (Selected and DrawGlyph) then begin - if BiDi then - ARect.Right := GlyphRect.Left - 1 - else - ARect.Left := GlyphRect.Right + 1; - end; - Inc(ARect.Left, 2); - Dec(ARect.Right, 1); - DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle; - if Win2K and (odNoAccel in State) then - DrawStyle := DrawStyle or DT_HIDEPREFIX; - { Calculate vertical layout } - SaveRect := ARect; - if odDefault in State then - Font.Style := [fsBold]; - DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP); - if BiDi then begin - { the DT_CALCRECT does not take into account alignment } - ARect.Left := SaveRect.Left; - ARect.Right := SaveRect.Right; - end; - OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2); - if TopLevel and Selected and Win98Plus - {$IFDEF COMPILER_7_UP} - and (not Win32PlatformIsXP) - {$ENDIF} - then - OffsetRect(ARect, 1, 0); - DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle); - if (ShortCut <> scNone) and not TopLevel then - begin - if BiDi then begin - ARect.Left := 10; - ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut)); - end else begin - ARect.Left := ARect.Right; - ARect.Right := SaveRect.Right - 10; - end; - DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT); - end; - end; - end; - -var - ParentMenu: TMenu; - SaveCaption: WideString; - SaveShortCut: TShortCut; -begin - ParentMenu := GetParentMenu; - if (not Win32PlatformIsUnicode) - or (Self.IsLine) - or ( (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil)) - and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem)) ) then - inherited - else begin - SaveCaption := Caption; - SaveShortCut := ShortCut; - try - FIgnoreMenuChanged := True; - try - Caption := ''; - ShortCut := scNone; - finally - FIgnoreMenuChanged := False; - end; - inherited; - finally - FIgnoreMenuChanged := True; - try - Caption := SaveCaption; - ShortCut := SaveShortcut; - finally - FIgnoreMenuChanged := False; - end; - end; - DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft)) - end; -end; - -procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString; - var Rect: TRect; Selected: Boolean; Flags: Longint); -var - Text: WideString; - ParentMenu: TMenu; -begin - if (not Win32PlatformIsUnicode) - or (IsLine) then - inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags) - else begin - ParentMenu := GetParentMenu; - if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then - begin - if Flags and DT_LEFT = DT_LEFT then - Flags := Flags and (not DT_LEFT) or DT_RIGHT - else if Flags and DT_RIGHT = DT_RIGHT then - Flags := Flags and (not DT_RIGHT) or DT_LEFT; - Flags := Flags or DT_RTLREADING; - end; - Text := ACaption; - if (Flags and DT_CALCRECT <> 0) and ((Text = '') or - (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' '; - with ACanvas do - begin - Brush.Style := bsClear; - if Default then - Font.Style := Font.Style + [fsBold]; - if not Enabled then - begin - if not Selected then - begin - OffsetRect(Rect, 1, 1); - Font.Color := clBtnHighlight; - Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); - OffsetRect(Rect, -1, -1); - end; - if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then - Font.Color := clBtnHighlight else - Font.Color := clBtnShadow; - end; - Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags); - end; - end; -end; - -function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer; -var - R: TRect; -begin - FillChar(R, SizeOf(R), 0); - DoDrawText(ACanvas, Text, R, False, - GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT); - Result := R.Right - R.Left; -end; - -procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); -var - SaveMeasureItemEvent: TMenuMeasureItemEvent; -begin - if (not Win32PlatformIsUnicode) - or (Self.IsLine) then - inherited - else begin - SaveMeasureItemEvent := inherited OnMeasureItem; - try - inherited OnMeasureItem := nil; - inherited; - Inc(Width, MeasureItemTextWidth(ACanvas, Caption)); - Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption)); - if ShortCut <> scNone then begin - Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut))); - Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut))); - end; - finally - inherited OnMeasureItem := SaveMeasureItemEvent; - end; - if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height); - end; -end; - -function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem}; -var - I: Integer; -begin - Result := nil; - ACaption := WideStripHotkey(ACaption); - for I := 0 to Count - 1 do - if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then - begin - Result := Items[I]; - System.Break; - end; -end; - -function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass; -begin - Result := TTntMenuActionLink; -end; - -procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin - if not CheckDefaults or (Caption = '') then - Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); - if not CheckDefaults or (Hint = '') then - Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender)); - end; - inherited; -end; - -{ TTntMainMenu } - -{$IFDEF COMPILER_9_UP} -function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; -begin - Result := TTntMenuItem.Create(Self); -end; -{$ENDIF} - -procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); -begin - inherited; - UpdateMenuItems(Items, Self); - if (THackMenuItem(Items).FMerged <> nil) then begin - UpdateMenuItems(THackMenuItem(Items).FMerged, Self); - end; -end; - -{ TTntPopupMenu } - -constructor TTntPopupMenu.Create(AOwner: TComponent); -begin - inherited; - PopupList.Remove(Self); - if TntPopupList <> nil then - TntPopupList.Add(Self); -end; - -{$IFDEF COMPILER_9_UP} -function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; -begin - Result := TTntMenuItem.Create(Self); -end; -{$ENDIF} - -destructor TTntPopupMenu.Destroy; -begin - if TntPopupList <> nil then - TntPopupList.Remove(Self); - PopupList.Add(Self); - inherited; -end; - -procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); -begin - inherited; - UpdateMenuItems(Items, Self); -end; - -procedure TTntPopupMenu.Popup(X, Y: Integer); -begin - Menus.PopupList := TntPopupList; - try - inherited; - finally - Menus.PopupList := TntPopupList.SavedPopupList; - end; -end; - -{ TTntPopupList } - -procedure TTntPopupList.WndProc(var Message: TMessage); -var - I, Item: Integer; - MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; - FindKind: TFindItemKind; -begin - case Message.Msg of - WM_ENTERMENULOOP: - begin - Menus.PopupList := SavedPopupList; - for i := 0 to Count - 1 do - FixMenuBiDiProblem(Items[i]); - end; - WM_MENUSELECT: - with TWMMenuSelect(Message) do - begin - FindKind := fkCommand; - if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle; - for I := 0 to Count - 1 do - begin - if FindKind = fkHandle then - begin - if Menu <> 0 then - Item := Integer(GetSubMenu(Menu, IDItem)) else - Item := -1; - end - else - Item := IDItem; - MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind); - if MenuItem <> nil then - begin - TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)); - Exit; - end; - end; - TntApplication.Hint := ''; - end; - end; - inherited; -end; - -initialization - TntPopupList := TTntPopupList.Create; - TntPopupList.SavedPopupList := Menus.PopupList; - -finalization - FreeAndNil(TntPopupList); - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas deleted file mode 100644 index e3f445f92b..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas +++ /dev/null @@ -1,148 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntRegistry; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Registry, Windows, TntClasses; - -{TNT-WARN TRegistry} -type - TTntRegistry = class(TRegistry{TNT-ALLOW TRegistry}) - private - procedure WriteStringEx(dwType: DWORD; const Name, Value: WideString); - public - procedure GetKeyNames(Strings: TTntStrings); - procedure GetValueNames(Strings: TTntStrings); - function ReadString(const Name: WideString): WideString; - procedure WriteString(const Name, Value: WideString); - procedure WriteExpandString(const Name, Value: WideString); - end; - -implementation - -uses - RTLConsts, SysUtils, TntSysUtils; - -{ TTntRegistry } - -procedure TTntRegistry.GetKeyNames(Strings: TTntStrings); -var - Len: DWORD; - I: Integer; - Info: TRegKeyInfo; - S: WideString; -begin - if (not Win32PlatformIsUnicode) then - inherited GetKeyNames(Strings.AnsiStrings) - else begin - Strings.Clear; - if GetKeyInfo(Info) then - begin - SetLength(S, (Info.MaxSubKeyLen + 1) * 2); - for I := 0 to Info.NumSubKeys - 1 do - begin - Len := (Info.MaxSubKeyLen + 1) * 2; - if RegEnumKeyExW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil) = ERROR_SUCCESS then - Strings.Add(PWideChar(S)); - end; - end; - end; -end; - -{$IFNDEF COMPILER_9_UP} // fix declaration for RegEnumValueW (lpValueName is a PWideChar) -function RegEnumValueW(hKey: HKEY; dwIndex: DWORD; lpValueName: PWideChar; - var lpcbValueName: DWORD; lpReserved: Pointer; lpType: PDWORD; - lpData: PByte; lpcbData: PDWORD): Longint; stdcall; external advapi32 name 'RegEnumValueW'; -{$ENDIF} - -procedure TTntRegistry.GetValueNames(Strings: TTntStrings); -var - Len: DWORD; - I: Integer; - Info: TRegKeyInfo; - S: WideString; -begin - if (not Win32PlatformIsUnicode) then - inherited GetValueNames(Strings.AnsiStrings) - else begin - Strings.Clear; - if GetKeyInfo(Info) then - begin - SetLength(S, Info.MaxValueLen + 1); - for I := 0 to Info.NumValues - 1 do - begin - Len := Info.MaxValueLen + 1; - RegEnumValueW(CurrentKey, I, PWideChar(S), Len, nil, nil, nil, nil); - Strings.Add(PWideChar(S)); - end; - end; - end; -end; - -function TTntRegistry.ReadString(const Name: WideString): WideString; -var - DataType: Cardinal; - BufSize: Cardinal; -begin - if (not Win32PlatformIsUnicode) then - result := inherited ReadString(Name) - else begin - // get length and type - DataType := REG_NONE; - if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, - @DataType, nil, @BufSize) <> ERROR_SUCCESS then - Result := '' - else begin - // check type - if not (DataType in [REG_SZ, REG_EXPAND_SZ]) then - raise ERegistryException.CreateFmt(SInvalidRegType, [Name]); - if BufSize = 1 then - BufSize := SizeOf(WideChar); // sometimes this occurs for single character values! - SetLength(Result, BufSize div SizeOf(WideChar)); - if RegQueryValueExW(CurrentKey, PWideChar(Name), nil, - @DataType, PByte(PWideChar(Result)), @BufSize) <> ERROR_SUCCESS then - raise ERegistryException.CreateFmt(SRegGetDataFailed, [Name]); - Result := PWideChar(Result); - end - end -end; - -procedure TTntRegistry.WriteStringEx(dwType: DWORD; const Name, Value: WideString); -begin - Assert(dwType in [REG_SZ, REG_EXPAND_SZ]); - if (not Win32PlatformIsUnicode) then begin - if dwType = REG_SZ then - inherited WriteString(Name, Value) - else - inherited WriteExpandString(Name, Value); - end else begin - if RegSetValueExW(CurrentKey, PWideChar(Name), 0, dwType, - PWideChar(Value), (Length(Value) + 1) * SizeOf(WideChar)) <> ERROR_SUCCESS then - raise ERegistryException.CreateFmt(SRegSetDataFailed, [Name]); - end; -end; - -procedure TTntRegistry.WriteString(const Name, Value: WideString); -begin - WriteStringEx(REG_SZ, Name, Value); -end; - -procedure TTntRegistry.WriteExpandString(const Name, Value: WideString); -begin - WriteStringEx(REG_EXPAND_SZ, Name, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas deleted file mode 100644 index 118e806336..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas +++ /dev/null @@ -1,1922 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntStdActns; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Classes, ActnList, TntActnList, StdActns, TntDialogs; - -type -{TNT-WARN THintAction} - TTntHintAction = class(THintAction{TNT-ALLOW THintAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - published - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditAction} - TTntEditAction = class(TEditAction{TNT-ALLOW TEditAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditCut} - TTntEditCut = class(TEditCut{TNT-ALLOW TEditCut}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditCopy} - TTntEditCopy = class(TEditCopy{TNT-ALLOW TEditCopy}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditPaste} - TTntEditPaste = class(TEditPaste{TNT-ALLOW TEditPaste}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditSelectAll} - TTntEditSelectAll = class(TEditSelectAll{TNT-ALLOW TEditSelectAll}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditUndo} - TTntEditUndo = class(TEditUndo{TNT-ALLOW TEditUndo}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TEditDelete} - TTntEditDelete = class(TEditDelete{TNT-ALLOW TEditDelete}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - procedure UpdateTarget(Target: TObject); override; - procedure ExecuteTarget(Target: TObject); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowAction} - TTntWindowAction = class(TWindowAction{TNT-ALLOW TWindowAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowClose} - TTntWindowClose = class(TWindowClose{TNT-ALLOW TWindowClose}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowCascade} - TTntWindowCascade = class(TWindowCascade{TNT-ALLOW TWindowCascade}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowTileHorizontal} - TTntWindowTileHorizontal = class(TWindowTileHorizontal{TNT-ALLOW TWindowTileHorizontal}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowTileVertical} - TTntWindowTileVertical = class(TWindowTileVertical{TNT-ALLOW TWindowTileVertical}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowMinimizeAll} - TTntWindowMinimizeAll = class(TWindowMinimizeAll{TNT-ALLOW TWindowMinimizeAll}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TWindowArrange} - TTntWindowArrange = class(TWindowArrange{TNT-ALLOW TWindowArrange}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN THelpAction} - TTntHelpAction = class(THelpAction{TNT-ALLOW THelpAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN THelpContents} - TTntHelpContents = class(THelpContents{TNT-ALLOW THelpContents}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN THelpTopicSearch} - TTntHelpTopicSearch = class(THelpTopicSearch{TNT-ALLOW THelpTopicSearch}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN THelpOnHelp} - TTntHelpOnHelp = class(THelpOnHelp{TNT-ALLOW THelpOnHelp}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN THelpContextAction} - TTntHelpContextAction = class(THelpContextAction{TNT-ALLOW THelpContextAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TCommonDialogAction} - TTntCommonDialogAction = class(TCommonDialogAction{TNT-ALLOW TCommonDialogAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFileAction} - TTntFileAction = class(TFileAction{TNT-ALLOW TFileAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFileOpen} - TTntFileOpen = class(TFileOpen{TNT-ALLOW TFileOpen}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function GetDialog: TTntOpenDialog; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetDialogClass: TCommonDialogClass; override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Dialog: TTntOpenDialog read GetDialog; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFileOpenWith} - TTntFileOpenWith = class(TFileOpenWith{TNT-ALLOW TFileOpenWith}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function GetDialog: TTntOpenDialog; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetDialogClass: TCommonDialogClass; override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Dialog: TTntOpenDialog read GetDialog; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFileSaveAs} - TTntFileSaveAs = class(TFileSaveAs{TNT-ALLOW TFileSaveAs}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function GetDialog: TTntSaveDialog; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetDialogClass: TCommonDialogClass; override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Dialog: TTntSaveDialog read GetDialog; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFilePrintSetup} - TTntFilePrintSetup = class(TFilePrintSetup{TNT-ALLOW TFilePrintSetup}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - - {$IFDEF COMPILER_7_UP} -{TNT-WARN TFilePageSetup} - TTntFilePageSetup = class(TFilePageSetup{TNT-ALLOW TFilePageSetup}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - {$ENDIF} - -{TNT-WARN TFileExit} - TTntFileExit = class(TFileExit{TNT-ALLOW TFileExit}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSearchAction} - TTntSearchAction = class(TSearchAction{TNT-ALLOW TSearchAction}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - public - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSearchFind} - TTntSearchFind = class(TSearchFind{TNT-ALLOW TSearchFind}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSearchReplace} - TTntSearchReplace = class(TSearchReplace{TNT-ALLOW TSearchReplace}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSearchFindFirst} - TTntSearchFindFirst = class(TSearchFindFirst{TNT-ALLOW TSearchFindFirst}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TSearchFindNext} - TTntSearchFindNext = class(TSearchFindNext{TNT-ALLOW TSearchFindNext}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TFontEdit} - TTntFontEdit = class(TFontEdit{TNT-ALLOW TFontEdit}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TColorSelect} - TTntColorSelect = class(TColorSelect{TNT-ALLOW TColorSelect}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -{TNT-WARN TPrintDlg} - TTntPrintDlg = class(TPrintDlg{TNT-ALLOW TPrintDlg}, ITntAction) - private - function GetCaption: WideString; - procedure SetCaption(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - protected - procedure DefineProperties(Filer: TFiler); override; - public - procedure Assign(Source: TPersistent); override; - published - property Caption: WideString read GetCaption write SetCaption; - property Hint: WideString read GetHint write SetHint; - end; - -procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); - -implementation - -uses - Dialogs, TntClasses; - -{TNT-IGNORE-UNIT} - -procedure TntStdActn_AfterInherited_Assign(Action: TCustomAction{TNT-ALLOW TCustomAction}; Source: TPersistent); -begin - TntAction_AfterInherited_Assign(Action, Source); - // TCommonDialogAction - if (Action is TCommonDialogAction) and (Source is TCommonDialogAction) then begin - TCommonDialogAction(Action).BeforeExecute := TCommonDialogAction(Source).BeforeExecute; - TCommonDialogAction(Action).OnAccept := TCommonDialogAction(Source).OnAccept; - TCommonDialogAction(Action).OnCancel := TCommonDialogAction(Source).OnCancel; - end; - // TFileOpen - if (Action is TFileOpen) and (Source is TFileOpen) then begin - {$IFDEF COMPILER_7_UP} - TFileOpen(Action).UseDefaultApp := TFileOpen(Source).UseDefaultApp; - {$ENDIF} - end; - // TFileOpenWith - if (Action is TFileOpenWith) and (Source is TFileOpenWith) then begin - TFileOpenWith(Action).FileName := TFileOpenWith(Source).FileName; - {$IFDEF COMPILER_7_UP} - TFileOpenWith(Action).AfterOpen := TFileOpenWith(Source).AfterOpen; - {$ENDIF} - end; - // TSearchFindNext - if (Action is TSearchFindNext) and (Source is TSearchFindNext) then begin - TSearchFindNext(Action).SearchFind := TSearchFindNext(Source).SearchFind; - end; -end; - -//------------------------- -// TNT STD ACTNS -//------------------------- - -{ TTntHintAction } - -procedure TTntHintAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHintAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHintAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHintAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHintAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHintAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditAction } - -procedure TTntEditAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditCut } - -procedure TTntEditCut.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditCut.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditCut.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditCut.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditCut.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditCut.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditCopy } - -procedure TTntEditCopy.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditCopy.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditCopy.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditCopy.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditCopy.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditCopy.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditPaste } - -procedure TTntEditPaste.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditPaste.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditPaste.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditPaste.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditPaste.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditPaste.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditSelectAll } - -procedure TTntEditSelectAll.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditSelectAll.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditSelectAll.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditSelectAll.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditSelectAll.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditSelectAll.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditUndo } - -procedure TTntEditUndo.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditUndo.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditUndo.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditUndo.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditUndo.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditUndo.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntEditDelete } - -procedure TTntEditDelete.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntEditDelete.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntEditDelete.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntEditDelete.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntEditDelete.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntEditDelete.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -procedure TTntEditDelete.UpdateTarget(Target: TObject); -begin - Enabled := True; -end; - -procedure TTntEditDelete.ExecuteTarget(Target: TObject); -begin - if GetControl(Target).SelLength = 0 then - GetControl(Target).SelLength := 1; - GetControl(Target).ClearSelection -end; - -{ TTntWindowAction } - -procedure TTntWindowAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowClose } - -procedure TTntWindowClose.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowClose.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowClose.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowClose.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowClose.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowClose.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowCascade } - -procedure TTntWindowCascade.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowCascade.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowCascade.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowCascade.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowCascade.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowCascade.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowTileHorizontal } - -procedure TTntWindowTileHorizontal.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowTileHorizontal.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowTileHorizontal.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowTileHorizontal.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowTileHorizontal.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowTileHorizontal.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowTileVertical } - -procedure TTntWindowTileVertical.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowTileVertical.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowTileVertical.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowTileVertical.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowTileVertical.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowTileVertical.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowMinimizeAll } - -procedure TTntWindowMinimizeAll.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowMinimizeAll.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowMinimizeAll.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowMinimizeAll.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowMinimizeAll.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowMinimizeAll.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntWindowArrange } - -procedure TTntWindowArrange.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntWindowArrange.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntWindowArrange.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntWindowArrange.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntWindowArrange.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntWindowArrange.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntHelpAction } - -procedure TTntHelpAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHelpAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHelpAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHelpAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHelpAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHelpAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntHelpContents } - -procedure TTntHelpContents.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHelpContents.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHelpContents.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHelpContents.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHelpContents.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHelpContents.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntHelpTopicSearch } - -procedure TTntHelpTopicSearch.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHelpTopicSearch.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHelpTopicSearch.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHelpTopicSearch.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHelpTopicSearch.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHelpTopicSearch.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntHelpOnHelp } - -procedure TTntHelpOnHelp.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHelpOnHelp.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHelpOnHelp.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHelpOnHelp.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHelpOnHelp.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHelpOnHelp.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntHelpContextAction } - -procedure TTntHelpContextAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntHelpContextAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntHelpContextAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntHelpContextAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntHelpContextAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntHelpContextAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntCommonDialogAction } - -procedure TTntCommonDialogAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntCommonDialogAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCommonDialogAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntCommonDialogAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntCommonDialogAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntCommonDialogAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntFileAction } - -procedure TTntFileAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntFileOpen } - -procedure TTntFileOpen.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileOpen.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileOpen.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileOpen.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileOpen.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileOpen.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -function TTntFileOpen.GetDialog: TTntOpenDialog; -begin - Result := inherited Dialog as TTntOpenDialog; -end; - -function TTntFileOpen.GetDialogClass: TCommonDialogClass; -begin - Result := TTntOpenDialog; -end; - -{ TTntFileOpenWith } - -procedure TTntFileOpenWith.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileOpenWith.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileOpenWith.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileOpenWith.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileOpenWith.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileOpenWith.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -function TTntFileOpenWith.GetDialog: TTntOpenDialog; -begin - Result := inherited Dialog as TTntOpenDialog; -end; - -function TTntFileOpenWith.GetDialogClass: TCommonDialogClass; -begin - Result := TTntOpenDialog; -end; - -{ TTntFileSaveAs } - -procedure TTntFileSaveAs.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileSaveAs.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileSaveAs.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileSaveAs.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileSaveAs.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileSaveAs.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -function TTntFileSaveAs.GetDialog: TTntSaveDialog; -begin - Result := TOpenDialog(inherited Dialog) as TTntSaveDialog; -end; - -function TTntFileSaveAs.GetDialogClass: TCommonDialogClass; -begin - Result := TTntSaveDialog; -end; - -{ TTntFilePrintSetup } - -procedure TTntFilePrintSetup.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFilePrintSetup.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFilePrintSetup.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFilePrintSetup.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFilePrintSetup.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFilePrintSetup.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - - {$IFDEF COMPILER_7_UP} - -{ TTntFilePageSetup } - -procedure TTntFilePageSetup.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFilePageSetup.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFilePageSetup.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFilePageSetup.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFilePageSetup.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFilePageSetup.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - {$ENDIF} - -{ TTntFileExit } - -procedure TTntFileExit.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFileExit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFileExit.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFileExit.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFileExit.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFileExit.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSearchAction } - -procedure TTntSearchAction.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSearchAction.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSearchAction.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSearchAction.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSearchAction.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSearchAction.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSearchFind } - -procedure TTntSearchFind.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSearchFind.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSearchFind.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSearchFind.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSearchFind.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSearchFind.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSearchReplace } - -procedure TTntSearchReplace.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSearchReplace.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSearchReplace.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSearchReplace.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSearchReplace.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSearchReplace.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSearchFindFirst } - -procedure TTntSearchFindFirst.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSearchFindFirst.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSearchFindFirst.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSearchFindFirst.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSearchFindFirst.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSearchFindFirst.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntSearchFindNext } - -procedure TTntSearchFindNext.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntSearchFindNext.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntSearchFindNext.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntSearchFindNext.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntSearchFindNext.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntSearchFindNext.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntFontEdit } - -procedure TTntFontEdit.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntFontEdit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntFontEdit.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntFontEdit.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntFontEdit.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntFontEdit.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntColorSelect } - -procedure TTntColorSelect.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntColorSelect.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntColorSelect.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntColorSelect.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntColorSelect.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntColorSelect.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -{ TTntPrintDlg } - -procedure TTntPrintDlg.Assign(Source: TPersistent); -begin - inherited; - TntStdActn_AfterInherited_Assign(Self, Source); -end; - -procedure TTntPrintDlg.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntPrintDlg.GetCaption: WideString; -begin - Result := TntAction_GetCaption(Self); -end; - -procedure TTntPrintDlg.SetCaption(const Value: WideString); -begin - TntAction_SetCaption(Self, Value); -end; - -function TTntPrintDlg.GetHint: WideString; -begin - Result := TntAction_GetHint(Self); -end; - -procedure TTntPrintDlg.SetHint(const Value: WideString); -begin - TntAction_SetHint(Self, Value); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas deleted file mode 100644 index 09c7da4573..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas +++ /dev/null @@ -1,3215 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntStdCtrls; - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Implement TCustomListBox.KeyPress, OnDataFind. } - -uses - Windows, Messages, Classes, Controls, TntControls, StdCtrls, Graphics, - TntClasses, TntSysUtils; - -{TNT-WARN TCustomEdit} -type - TTntCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}) - private - FPasswordChar: WideChar; - procedure SetSelText(const Value: WideString); - function GetText: WideString; - procedure SetText(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - function GetPasswordChar: WideChar; - procedure SetPasswordChar(const Value: WideChar); - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function GetSelStart: Integer; reintroduce; virtual; - procedure SetSelStart(const Value: Integer); reintroduce; virtual; - function GetSelLength: Integer; reintroduce; virtual; - procedure SetSelLength(const Value: Integer); reintroduce; virtual; - function GetSelText: WideString; reintroduce; virtual; - property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; - public - property SelText: WideString read GetSelText write SetSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TEdit} - TTntEdit = class(TTntCustomEdit) - published - property Align; - property Anchors; - property AutoSelect; - property AutoSize; - property BevelEdges; - property BevelInner; - property BevelKind default bkNone; - property BevelOuter; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property CharCase; - property Color; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property ImeMode; - property ImeName; - property MaxLength; - property OEMConvert; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PasswordChar; - property PopupMenu; - property ReadOnly; - property ShowHint; - property TabOrder; - property TabStop; - property Text; - property Visible; - property OnChange; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - -type - TTntCustomMemo = class; - - TTntMemoStrings = class(TTntStrings) - protected - FMemo: TCustomMemo{TNT-ALLOW TCustomMemo}; - FMemoLines: TStrings{TNT-ALLOW TStrings}; - FRichEditMode: Boolean; - FLineBreakStyle: TTntTextLineBreakStyle; - function Get(Index: Integer): WideString; override; - function GetCount: Integer; override; - function GetTextStr: WideString; override; - procedure Put(Index: Integer; const S: WideString); override; - procedure SetUpdateState(Updating: Boolean); override; - public - constructor Create; - procedure SetTextStr(const Value: WideString); override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: WideString); override; - end; - -{TNT-WARN TCustomMemo} - TTntCustomMemo = class(TCustomMemo{TNT-ALLOW TCustomMemo}) - private - FLines: TTntStrings; - procedure SetSelText(const Value: WideString); - function GetText: WideString; - procedure SetText(const Value: WideString); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure SetLines(const Value: TTntStrings); virtual; - function GetSelStart: Integer; reintroduce; virtual; - procedure SetSelStart(const Value: Integer); reintroduce; virtual; - function GetSelLength: Integer; reintroduce; virtual; - procedure SetSelLength(const Value: Integer); reintroduce; virtual; - function GetSelText: WideString; reintroduce; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property SelText: WideString read GetSelText write SetSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - property Lines: TTntStrings read FLines write SetLines; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TMemo} - TTntMemo = class(TTntCustomMemo) - published - property Align; - property Alignment; - property Anchors; - property BevelEdges; - property BevelInner; - property BevelKind default bkNone; - property BevelOuter; - property BiDiMode; - property BorderStyle; - property Color; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property HideSelection; - property ImeMode; - property ImeName; - property Lines; - property MaxLength; - property OEMConvert; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ReadOnly; - property ScrollBars; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - property WantReturns; - property WantTabs; - property WordWrap; - property OnChange; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - - TTntComboBoxStrings = class(TTntStrings) - protected - function Get(Index: Integer): WideString; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - public - ComboBox: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - function Add(const S: WideString): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - function IndexOf(const S: WideString): Integer; override; - procedure Insert(Index: Integer; const S: WideString); override; - end; - -type - TWMCharMsgHandler = procedure(var Message: TWMChar) of object; - -{$IFDEF DELPHI_7} // fix for Delphi 7 only -{ TD7PatchedComboBoxStrings } -type - TD7PatchedComboBoxStrings = class(TCustomComboBoxStrings) - protected - function Get(Index: Integer): string{TNT-ALLOW string}; override; - public - function Add(const S: string{TNT-ALLOW string}): Integer; override; - procedure Insert(Index: Integer; const S: string{TNT-ALLOW string}); override; - end; -{$ENDIF} - -type - ITntComboFindString = interface - ['{63BEBEF4-B1A2-495A-B558-7487B66F6827}'] - function FindString(const Value: WideString; StartPos: Integer): Integer; - end; - -{TNT-WARN TCustomComboBox} -type - TTntCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}, - IWideCustomListControl) - private - FItems: TTntStrings; - FSaveItems: TTntStrings; - FSaveItemIndex: Integer; - FFilter: WideString; - FLastTime: Cardinal; - function GetItems: TTntStrings; - function GetSelStart: Integer; - procedure SetSelStart(const Value: Integer); - function GetSelLength: Integer; - procedure SetSelLength(const Value: Integer); - function GetSelText: WideString; - procedure SetSelText(const Value: WideString); - function GetText: WideString; - procedure SetText(const Value: WideString); - procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure DestroyWnd; override; - function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; - function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; - procedure DoEditCharMsg(var Message: TWMChar); virtual; - procedure CreateWnd; override; - procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; - procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; - procedure KeyPress(var Key: AnsiChar); override; - {$IFDEF DELPHI_7} // fix for Delphi 7 only - function GetItemsClass: TCustomComboBoxStringsClass; override; - {$ENDIF} - procedure SetItems(const Value: TTntStrings); reintroduce; virtual; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure CopySelection(Destination: TCustomListControl); override; - procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; - public - property SelText: WideString read GetSelText write SetSelText; - property SelStart: Integer read GetSelStart write SetSelStart; - property SelLength: Integer read GetSelLength write SetSelLength; - property Text: WideString read GetText write SetText; - property Items: TTntStrings read GetItems write SetItems; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TComboBox} - TTntComboBox = class(TTntCustomComboBox) - published - property Align; - property AutoComplete default True; - {$IFDEF COMPILER_9_UP} - property AutoCompleteDelay default 500; - {$ENDIF} - property AutoDropDown default False; - {$IFDEF COMPILER_7_UP} - property AutoCloseUp default False; - {$ENDIF} - property BevelEdges; - property BevelInner; - property BevelKind default bkNone; - property BevelOuter; - property Style; {Must be published before Items} - property Anchors; - property BiDiMode; - property CharCase; - property Color; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property DropDownCount; - property Enabled; - property Font; - property ImeMode; - property ImeName; - property ItemHeight; - property ItemIndex default -1; - property MaxLength; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property Sorted; - property TabOrder; - property TabStop; - property Text; - property Visible; - property OnChange; - property OnClick; - property OnCloseUp; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnDrawItem; - property OnDropDown; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - property OnMeasureItem; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnSelect; - property OnStartDock; - property OnStartDrag; - property Items; { Must be published after OnMeasureItem } - end; - - TLBGetWideDataEvent = procedure(Control: TWinControl; Index: Integer; - var Data: WideString) of object; - - TAccessCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}); - - TTntListBoxStrings = class(TTntStrings) - private - FListBox: TAccessCustomListBox; - function GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; - procedure SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); - protected - procedure Put(Index: Integer; const S: WideString); override; - function Get(Index: Integer): WideString; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - public - function Add(const S: WideString): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Exchange(Index1, Index2: Integer); override; - function IndexOf(const S: WideString): Integer; override; - procedure Insert(Index: Integer; const S: WideString); override; - procedure Move(CurIndex, NewIndex: Integer); override; - property ListBox: TCustomListBox{TNT-ALLOW TCustomListBox} read GetListBox write SetListBox; - end; - -{TNT-WARN TCustomListBox} -type - TTntCustomListBox = class(TCustomListBox{TNT-ALLOW TCustomListBox}, IWideCustomListControl) - private - FItems: TTntStrings; - FSaveItems: TTntStrings; - FSaveTopIndex: Integer; - FSaveItemIndex: Integer; - FOnData: TLBGetWideDataEvent; - procedure SetItems(const Value: TTntStrings); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - procedure LBGetText(var Message: TMessage); message LB_GETTEXT; - procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - procedure CreateWnd; override; - procedure DestroyWnd; override; - procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; - property OnData: TLBGetWideDataEvent read FOnData write FOnData; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure CopySelection(Destination: TCustomListControl); override; - procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; - property Items: TTntStrings read FItems write SetItems; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TListBox} - TTntListBox = class(TTntCustomListBox) - published - property Style; - property AutoComplete; - {$IFDEF COMPILER_9_UP} - property AutoCompleteDelay; - {$ENDIF} - property Align; - property Anchors; - property BevelEdges; - property BevelInner; - property BevelKind default bkNone; - property BevelOuter; - property BevelWidth; - property BiDiMode; - property BorderStyle; - property Color; - property Columns; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property ExtendedSelect; - property Font; - property ImeMode; - property ImeName; - property IntegralHeight; - property ItemHeight; - property Items; - property MultiSelect; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ScrollWidth; - property ShowHint; - property Sorted; - property TabOrder; - property TabStop; - property TabWidth; - property Visible; - property OnClick; - property OnContextPopup; - property OnData; - property OnDataFind; - property OnDataObject; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnDrawItem; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - property OnMeasureItem; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - -{TNT-WARN TCustomLabel} - TTntCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - function GetLabelText: WideString; reintroduce; virtual; - procedure DoDrawText(var Rect: TRect; Flags: Longint); override; - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TLabel} - TTntLabel = class(TTntCustomLabel) - published - property Align; - property Alignment; - property Anchors; - property AutoSize; - property BiDiMode; - property Caption; - property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; - property Constraints; - property DragCursor; - property DragKind; - property DragMode; - {$IFDEF COMPILER_9_UP} - property EllipsisPosition; - {$ENDIF} - property Enabled; - property FocusControl; - property Font; - property ParentBiDiMode; - property ParentColor; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowAccelChar; - property ShowHint; - property Transparent; - property Layout; - property Visible; - property WordWrap; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - property OnMouseMove; - property OnMouseUp; - property OnMouseEnter; - property OnMouseLeave; - property OnStartDock; - property OnStartDrag; - end; - -{TNT-WARN TButton} - TTntButton = class(TButton{TNT-ALLOW TButton}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCustomCheckBox} - TTntCustomCheckBox = class(TCustomCheckBox{TNT-ALLOW TCustomCheckBox}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - public - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCheckBox} - TTntCheckBox = class(TTntCustomCheckBox) - published - property Action; - property Align; - property Alignment; - property AllowGrayed; - property Anchors; - property BiDiMode; - property Caption; - property Checked; - property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; - property Constraints; - property Ctl3D; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property State; - property TabOrder; - property TabStop; - property Visible; - {$IFDEF COMPILER_7_UP} - property WordWrap; - {$ENDIF} - property OnClick; - property OnContextPopup; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - -{TNT-WARN TRadioButton} - TTntRadioButton = class(TRadioButton{TNT-ALLOW TRadioButton}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TScrollBar} - TTntScrollBar = class(TScrollBar{TNT-ALLOW TScrollBar}) - private - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsHintStored: Boolean; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TCustomGroupBox} - TTntCustomGroupBox = class(TCustomGroupBox{TNT-ALLOW TCustomGroupBox}) - private - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure Paint; override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TGroupBox} - TTntGroupBox = class(TTntCustomGroupBox) - published - property Align; - property Anchors; - property BiDiMode; - property Caption; - property Color; - property Constraints; - property Ctl3D; - property DockSite; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property Font; - {$IFDEF COMPILER_10_UP} - property Padding; - {$ENDIF} - {$IFDEF COMPILER_7_UP} - property ParentBackground default True; - {$ENDIF} - property ParentBiDiMode; - property ParentColor; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowHint; - property TabOrder; - property TabStop; - property Visible; - {$IFDEF COMPILER_9_UP} - property OnAlignInsertBefore; - property OnAlignPosition; - {$ENDIF} - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDockDrop; - property OnDockOver; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnGetSiteInfo; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - property OnUnDock; - end; - -{TNT-WARN TCustomStaticText} - TTntCustomStaticText = class(TCustomStaticText{TNT-ALLOW TCustomStaticText}) - private - procedure AdjustBounds; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - function GetHint: WideString; - procedure SetHint(const Value: WideString); - function IsCaptionStored: Boolean; - function IsHintStored: Boolean; - procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; - protected - procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; - procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; - procedure Loaded; override; - procedure SetAutoSize(AValue: boolean); override; - procedure CreateWindowHandle(const Params: TCreateParams); override; - procedure DefineProperties(Filer: TFiler); override; - function GetActionLinkClass: TControlActionLinkClass; override; - procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; - property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; - public - constructor Create(AOwner: TComponent); override; - published - property Hint: WideString read GetHint write SetHint stored IsHintStored; - end; - -{TNT-WARN TStaticText} - TTntStaticText = class(TTntCustomStaticText) - published - property Align; - property Alignment; - property Anchors; - property AutoSize; - property BevelEdges; - property BevelInner; - property BevelKind default bkNone; - property BevelOuter; - property BiDiMode; - property BorderStyle; - property Caption; - property Color {$IFDEF COMPILER_7_UP} nodefault {$ENDIF}; - property Constraints; - property DragCursor; - property DragKind; - property DragMode; - property Enabled; - property FocusControl; - property Font; - property ParentBiDiMode; - property ParentColor; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property ShowAccelChar; - property ShowHint; - property TabOrder; - property TabStop; - {$IFDEF COMPILER_7_UP} - property Transparent; - {$ENDIF} - property Visible; - property OnClick; - property OnContextPopup; - property OnDblClick; - property OnDragDrop; - property OnDragOver; - property OnEndDock; - property OnEndDrag; - {$IFDEF COMPILER_9_UP} - property OnMouseActivate; - {$ENDIF} - property OnMouseDown; - {$IFDEF COMPILER_10_UP} - property OnMouseEnter; - property OnMouseLeave; - {$ENDIF} - property OnMouseMove; - property OnMouseUp; - property OnStartDock; - property OnStartDrag; - end; - -procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); -procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; - var SavedText: WideString); -function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; -function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; -function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; -procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); -function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; -procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); -function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; -procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); -procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); -procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); -procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); -procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); -procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; - Destination: TCustomListControl); -procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); -procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var Message: TWMChar; - AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); -procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; - State: TOwnerDrawState; Items: TTntStrings); - -procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); -procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); -function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; -procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); -function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; -procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); -function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; -procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); -function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; -procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); - - -function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; -function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; - -procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; - var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); -procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; - var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); -procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); -procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); -procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; - Items: TTntStrings; Destination: TCustomListControl); -function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; -function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; - -function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; -procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); - -procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); - -implementation - -uses - Forms, SysUtils, Consts, RichEdit, ComStrs, - RTLConsts, {$IFDEF THEME_7_UP} Themes, {$ENDIF} - TntForms, TntGraphics, TntActnList, TntWindows, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -{ TTntCustomEdit } - -procedure TntCustomEdit_CreateWindowHandle(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Params: TCreateParams); -var - P: TCreateParams; -begin - if SysLocale.FarEast - and (not Win32PlatformIsUnicode) - and ((Params.Style and ES_READONLY) <> 0) then begin - // Work around Far East Win95 API/IME bug. - P := Params; - P.Style := P.Style and (not ES_READONLY); - CreateUnicodeHandle(Edit, P, 'EDIT'); - if Edit.HandleAllocated then - SendMessage(Edit.Handle, EM_SETREADONLY, Ord(True), 0); - end else - CreateUnicodeHandle(Edit, Params, 'EDIT'); -end; - -procedure TntCustomEdit_AfterInherited_CreateWnd(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar); -var - PasswordChar: WideChar; -begin - PasswordChar := TntCustomEdit_GetPasswordChar(Edit, FPasswordChar); - if Win32PlatformIsUnicode then - SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(PasswordChar), 0); -end; - -function TntCustomEdit_GetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; -begin - if Win32PlatformIsUnicode then - Result := Edit.SelStart - else - Result := Length(WideString(Copy(Edit.Text, 1, Edit.SelStart))); -end; - -procedure TntCustomEdit_SetSelStart(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); -begin - if Win32PlatformIsUnicode then - Edit.SelStart := Value - else - Edit.SelStart := Length(AnsiString(Copy(TntControl_GetText(Edit), 1, Value))); -end; - -function TntCustomEdit_GetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): Integer; -begin - if Win32PlatformIsUnicode then - Result := Edit.SelLength - else - Result := Length(TntCustomEdit_GetSelText(Edit)); -end; - -procedure TntCustomEdit_SetSelLength(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: Integer); -var - StartPos: Integer; -begin - if Win32PlatformIsUnicode then - Edit.SelLength := Value - else begin - StartPos := TntCustomEdit_GetSelStart(Edit); - Edit.SelLength := Length(AnsiString(Copy(TntControl_GetText(Edit), StartPos + 1, Value))); - end; -end; - -function TntCustomEdit_GetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}): WideString; -begin - if Win32PlatformIsUnicode then - Result := Copy(TntControl_GetText(Edit), Edit.SelStart + 1, Edit.SelLength) - else - Result := Edit.SelText -end; - -procedure TntCustomEdit_SetSelText(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; const Value: WideString); -begin - if Win32PlatformIsUnicode then - SendMessageW(Edit.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value))) - else - Edit.SelText := Value; -end; - -function WideCharToAnsiChar(const C: WideChar): AnsiChar; -begin - if C <= High(AnsiChar) then - Result := AnsiChar(C) - else - Result := '*'; -end; - -type TAccessCustomEdit = class(TCustomEdit{TNT-ALLOW TCustomEdit}); - -function TntCustomEdit_GetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar): WideChar; -begin - if TAccessCustomEdit(Edit).PasswordChar <> WideCharToAnsiChar(FPasswordChar) then - FPasswordChar := WideChar(TAccessCustomEdit(Edit).PasswordChar); - Result := FPasswordChar; -end; - -procedure TntCustomEdit_SetPasswordChar(Edit: TCustomEdit{TNT-ALLOW TCustomEdit}; var FPasswordChar: WideChar; const Value: WideChar); -var - SaveWindowHandle: Integer; - PasswordCharSetHere: Boolean; -begin - if TntCustomEdit_GetPasswordChar(Edit, FPasswordChar) <> Value then - begin - FPasswordChar := Value; - PasswordCharSetHere := Win32PlatformIsUnicode and Edit.HandleAllocated; - SaveWindowHandle := TAccessCustomEdit(Edit).WindowHandle; - try - if PasswordCharSetHere then - TAccessCustomEdit(Edit).WindowHandle := 0; // this prevents TCustomEdit from actually changing it - TAccessCustomEdit(Edit).PasswordChar := WideCharToAnsiChar(FPasswordChar); - finally - TAccessCustomEdit(Edit).WindowHandle := SaveWindowHandle; - end; - if PasswordCharSetHere then - begin - Assert(Win32PlatformIsUnicode); - Assert(Edit.HandleAllocated); - SendMessageW(Edit.Handle, EM_SETPASSWORDCHAR, Ord(FPasswordChar), 0); - Edit.Invalidate; - end; - end; -end; - -procedure TTntCustomEdit.CreateWindowHandle(const Params: TCreateParams); -begin - TntCustomEdit_CreateWindowHandle(Self, Params); -end; - -procedure TTntCustomEdit.CreateWnd; -begin - inherited; - TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); -end; - -procedure TTntCustomEdit.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomEdit.GetSelStart: Integer; -begin - Result := TntCustomEdit_GetSelStart(Self); -end; - -procedure TTntCustomEdit.SetSelStart(const Value: Integer); -begin - TntCustomEdit_SetSelStart(Self, Value); -end; - -function TTntCustomEdit.GetSelLength: Integer; -begin - Result := TntCustomEdit_GetSelLength(Self); -end; - -procedure TTntCustomEdit.SetSelLength(const Value: Integer); -begin - TntCustomEdit_SetSelLength(Self, Value); -end; - -function TTntCustomEdit.GetSelText: WideString; -begin - Result := TntCustomEdit_GetSelText(Self); -end; - -procedure TTntCustomEdit.SetSelText(const Value: WideString); -begin - TntCustomEdit_SetSelText(Self, Value); -end; - -function TTntCustomEdit.GetPasswordChar: WideChar; -begin - Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar); -end; - -procedure TTntCustomEdit.SetPasswordChar(const Value: WideChar); -begin - TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); -end; - -function TTntCustomEdit.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntCustomEdit.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -function TTntCustomEdit.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomEdit.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomEdit.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomEdit.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntMemoStrings } - -constructor TTntMemoStrings.Create; -begin - inherited; - FLineBreakStyle := tlbsCRLF; -end; - -function TTntMemoStrings.GetCount: Integer; -begin - Result := FMemoLines.Count; -end; - -function TntMemo_LineStart(Handle: THandle; Index: Integer): Integer; -begin - Assert(Win32PlatformIsUnicode); - Result := SendMessageW(Handle, EM_LINEINDEX, Index, 0); -end; - -function TntMemo_LineLength(Handle: THandle; Index: Integer; StartPos: Integer = -1): Integer; -begin - Assert(Win32PlatformIsUnicode); - if StartPos = -1 then - StartPos := TntMemo_LineStart(Handle, Index); - if StartPos < 0 then - Result := 0 - else - Result := SendMessageW(Handle, EM_LINELENGTH, StartPos, 0); -end; - -function TTntMemoStrings.Get(Index: Integer): WideString; -var - Len: Integer; -begin - if (not IsWindowUnicode(FMemo.Handle)) then - Result := FMemoLines[Index] - else begin - SetLength(Result, TntMemo_LineLength(FMemo.Handle, Index)); - if Length(Result) > 0 then begin - if Length(Result) > High(Word) then - raise EOutOfResources.Create(SOutlineLongLine); - Word((PWideChar(Result))^) := Length(Result); - Len := SendMessageW(FMemo.Handle, EM_GETLINE, Index, Longint(PWideChar(Result))); - SetLength(Result, Len); - end; - end; -end; - -procedure TTntMemoStrings.Put(Index: Integer; const S: WideString); -var - StartPos: Integer; -begin - if (not IsWindowUnicode(FMemo.Handle)) then - FMemoLines[Index] := S - else begin - StartPos := TntMemo_LineStart(FMemo.Handle, Index); - if StartPos >= 0 then - begin - SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos + TntMemo_LineLength(FMemo.Handle, Index)); - SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(S))); - end; - end; -end; - -procedure TTntMemoStrings.Insert(Index: Integer; const S: Widestring); - - function RichEditSelStartW: Integer; - var - CharRange: TCharRange; - begin - SendMessageW(FMemo.Handle, EM_EXGETSEL, 0, Longint(@CharRange)); - Result := CharRange.cpMin; - end; - -var - StartPos, LineLen: Integer; - Line: WideString; -begin - if (not IsWindowUnicode(FMemo.Handle)) then - FMemoLines.Insert(Index, S) - else begin - if Index >= 0 then - begin - StartPos := TntMemo_LineStart(FMemo.Handle, Index); - if StartPos >= 0 then - Line := S + CRLF - else begin - StartPos := TntMemo_LineStart(FMemo.Handle, Index - 1); - LineLen := TntMemo_LineLength(FMemo.Handle, Index - 1); - if LineLen = 0 then - Exit; - Inc(StartPos, LineLen); - Line := CRLF + s; - end; - SendMessageW(FMemo.Handle, EM_SETSEL, StartPos, StartPos); - - if (FRichEditMode) - and (FLineBreakStyle <> tlbsCRLF) then begin - Line := TntAdjustLineBreaks(Line, FLineBreakStyle); - if Line = CR then - Line := CRLF; { This helps a ReadOnly RichEdit 4.1 control to insert a blank line. } - SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); - if Line = CRLF then - Line := CR; - end else - SendMessageW(FMemo.Handle, EM_REPLACESEL, 0, Longint(PWideChar(Line))); - - if (FRichEditMode) - and (RichEditSelStartW <> (StartPos + Length(Line))) then - raise EOutOfResources.Create(sRichEditInsertError); - end; - end; -end; - -procedure TTntMemoStrings.Delete(Index: Integer); -begin - FMemoLines.Delete(Index); -end; - -procedure TTntMemoStrings.Clear; -begin - FMemoLines.Clear; -end; - -type TAccessStrings = class(TStrings{TNT-ALLOW TStrings}); - -procedure TTntMemoStrings.SetUpdateState(Updating: Boolean); -begin - TAccessStrings(FMemoLines).SetUpdateState(Updating); -end; - -function TTntMemoStrings.GetTextStr: WideString; -begin - if (not FRichEditMode) then - Result := TntControl_GetText(FMemo) - else - Result := inherited GetTextStr; -end; - -procedure TTntMemoStrings.SetTextStr(const Value: WideString); -var - NewText: WideString; -begin - NewText := TntAdjustLineBreaks(Value, FLineBreakStyle); - if NewText <> GetTextStr then begin - FMemo.HandleNeeded; - TntControl_SetText(FMemo, NewText); - end; -end; - -{ TTntCustomMemo } - -constructor TTntCustomMemo.Create(AOwner: TComponent); -begin - inherited; - FLines := TTntMemoStrings.Create; - TTntMemoStrings(FLines).FMemo := Self; - TTntMemoStrings(FLines).FMemoLines := TCustomMemo{TNT-ALLOW TCustomMemo}(Self).Lines; -end; - -destructor TTntCustomMemo.Destroy; -begin - FreeAndNil(FLines); - inherited; -end; - -procedure TTntCustomMemo.SetLines(const Value: TTntStrings); -begin - FLines.Assign(Value); -end; - -procedure TTntCustomMemo.CreateWindowHandle(const Params: TCreateParams); -begin - TntCustomEdit_CreateWindowHandle(Self, Params); -end; - -procedure TTntCustomMemo.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomMemo.GetSelStart: Integer; -begin - Result := TntCustomEdit_GetSelStart(Self); -end; - -procedure TTntCustomMemo.SetSelStart(const Value: Integer); -begin - TntCustomEdit_SetSelStart(Self, Value); -end; - -function TTntCustomMemo.GetSelLength: Integer; -begin - Result := TntCustomEdit_GetSelLength(Self); -end; - -procedure TTntCustomMemo.SetSelLength(const Value: Integer); -begin - TntCustomEdit_SetSelLength(Self, Value); -end; - -function TTntCustomMemo.GetSelText: WideString; -begin - Result := TntCustomEdit_GetSelText(Self); -end; - -procedure TTntCustomMemo.SetSelText(const Value: WideString); -begin - TntCustomEdit_SetSelText(Self, Value); -end; - -function TTntCustomMemo.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntCustomMemo.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -function TTntCustomMemo.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self); -end; - -function TTntCustomMemo.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomMemo.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomMemo.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomMemo.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{$IFDEF DELPHI_7} // fix for Delphi 7 only -function TD7PatchedComboBoxStrings.Get(Index: Integer): string{TNT-ALLOW string}; -var - Len: Integer; -begin - Len := SendMessage(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); - if Len > 0 then - begin - SetLength(Result, Len); - SendMessage(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PChar{TNT-ALLOW PChar}(Result))); - end - else - SetLength(Result, 0); -end; - -function TD7PatchedComboBoxStrings.Add(const S: string{TNT-ALLOW string}): Integer; -begin - Result := SendMessage(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PChar{TNT-ALLOW PChar}(S))); - if Result < 0 then - raise EOutOfResources.Create(SInsertLineError); -end; - -procedure TD7PatchedComboBoxStrings.Insert(Index: Integer; const S: string{TNT-ALLOW string}); -begin - if SendMessage(ComboBox.Handle, CB_INSERTSTRING, Index, - Longint(PChar{TNT-ALLOW PChar}(S))) < 0 then - raise EOutOfResources.Create(SInsertLineError); -end; -{$ENDIF} - -{ TTntComboBoxStrings } - -function TTntComboBoxStrings.GetCount: Integer; -begin - Result := ComboBox.Items.Count; -end; - -function TTntComboBoxStrings.Get(Index: Integer): WideString; -var - Len: Integer; -begin - if (not IsWindowUnicode(ComboBox.Handle)) then - Result := ComboBox.Items[Index] - else begin - Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXTLEN, Index, 0); - if Len = CB_ERR then - Result := '' - else begin - SetLength(Result, Len + 1); - Len := SendMessageW(ComboBox.Handle, CB_GETLBTEXT, Index, Longint(PWideChar(Result))); - if Len = CB_ERR then - Result := '' - else - Result := PWideChar(Result); - end; - end; -end; - -function TTntComboBoxStrings.GetObject(Index: Integer): TObject; -begin - Result := ComboBox.Items.Objects[Index]; -end; - -procedure TTntComboBoxStrings.PutObject(Index: Integer; AObject: TObject); -begin - ComboBox.Items.Objects[Index] := AObject; -end; - -function TTntComboBoxStrings.Add(const S: WideString): Integer; -begin - if (not IsWindowUnicode(ComboBox.Handle)) then - Result := ComboBox.Items.Add(S) - else begin - Result := SendMessageW(ComboBox.Handle, CB_ADDSTRING, 0, Longint(PWideChar(S))); - if Result < 0 then - raise EOutOfResources.Create(SInsertLineError); - end; -end; - -procedure TTntComboBoxStrings.Insert(Index: Integer; const S: WideString); -begin - if (not IsWindowUnicode(ComboBox.Handle)) then - ComboBox.Items.Insert(Index, S) - else begin - if SendMessageW(ComboBox.Handle, CB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then - raise EOutOfResources.Create(SInsertLineError); - end; -end; - -procedure TTntComboBoxStrings.Delete(Index: Integer); -begin - ComboBox.Items.Delete(Index); -end; - -procedure TTntComboBoxStrings.Clear; -var - S: WideString; -begin - S := TntControl_GetText(ComboBox); - SendMessage(ComboBox.Handle, CB_RESETCONTENT, 0, 0); - TntControl_SetText(ComboBox, S); - ComboBox.Update; -end; - -procedure TTntComboBoxStrings.SetUpdateState(Updating: Boolean); -begin - TAccessStrings(ComboBox.Items).SetUpdateState(Updating); -end; - -function TTntComboBoxStrings.IndexOf(const S: WideString): Integer; -begin - if (not IsWindowUnicode(ComboBox.Handle)) then - Result := ComboBox.Items.IndexOf(S) - else - Result := SendMessageW(ComboBox.Handle, CB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); -end; - -{ TTntCustomComboBox } - -type TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); - -procedure TntCombo_AfterInherited_CreateWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var FSaveItems: TTntStrings; FSaveItemIndex: integer; PreInheritedAnsiText: AnsiString); -begin - if (not Win32PlatformIsUnicode) then begin - TAccessCustomComboBox(Combo).Text := PreInheritedAnsiText; - end else begin - with TAccessCustomComboBox(Combo) do - begin - if ListHandle <> 0 then begin - // re-extract FDefListProc as a Unicode proc - SetWindowLongA(ListHandle, GWL_WNDPROC, Integer(FDefListProc)); - FDefListProc := Pointer(GetWindowLongW(ListHandle, GWL_WNDPROC)); - // override with FListInstance as a Unicode proc - SetWindowLongW(ListHandle, GWL_WNDPROC, Integer(FListInstance)); - end; - SetWindowLongW(EditHandle, GWL_WNDPROC, GetWindowLong(EditHandle, GWL_WNDPROC)); - end; - if FSaveItems <> nil then - begin - Items.Assign(FSaveItems); - FreeAndNil(FSaveItems); - if FSaveItemIndex <> -1 then - begin - if Items.Count < FSaveItemIndex then FSaveItemIndex := Items.Count; - SendMessage(Combo.Handle, CB_SETCURSEL, FSaveItemIndex, 0); - end; - end; - TntControl_SetText(Combo, TntControl_GetStoredText(Combo, TAccessCustomComboBox(Combo).Text)); - end; -end; - -procedure TntCombo_BeforeInherited_DestroyWnd(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var FSaveItems: TTntStrings; ItemIndex: integer; var FSaveItemIndex: integer; - var SavedText: WideString); -begin - Assert(not (csDestroyingHandle in Combo.ControlState)); - if (Win32PlatformIsUnicode) then begin - SavedText := TntControl_GetText(Combo); - if (Items.Count > 0) then - begin - FSaveItems := TTntStringList.Create; - FSaveItems.Assign(Items); - FSaveItemIndex:= ItemIndex; - Items.Clear; { This keeps TCustomComboBox from creating its own FSaveItems. (this kills the original ItemIndex) } - end; - end; -end; - -function TntCombo_ComboWndProc(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer; DoEditCharMsg: TWMCharMsgHandler): Boolean; - - procedure CallDefaultWindowProc; - begin - with Message do begin { call default wnd proc } - if IsWindowUnicode(ComboWnd) then - Result := CallWindowProcW(ComboProc, ComboWnd, Msg, WParam, LParam) - else - Result := CallWindowProcA(ComboProc, ComboWnd, Msg, WParam, LParam); - end; - end; - - function DoWideKeyPress(Message: TWMChar): Boolean; - begin - DoEditCharMsg(Message); - Result := (Message.CharCode = 0); - end; - -begin - Result := False; - try - if (Message.Msg = WM_CHAR) then begin - // WM_CHAR - Result := True; - if IsWindowUnicode(ComboWnd) then - MakeWMCharMsgSafeForAnsi(Message); - try - if TAccessCustomComboBox(Combo).DoKeyPress(TWMKey(Message)) then Exit; - if DoWideKeyPress(TWMKey(Message)) then Exit; - finally - if IsWindowUnicode(ComboWnd) then - RestoreWMCharMsg(Message); - end; - with TWMKey(Message) do begin - if ((CharCode = VK_RETURN) or (CharCode = VK_ESCAPE)) and Combo.DroppedDown then begin - Combo.DroppedDown := False; - Exit; - end; - end; - CallDefaultWindowProc; - end else if (IsWindowUnicode(ComboWnd)) then begin - // UNICODE - if IsTextMessage(Message.Msg) - or (Message.Msg = EM_REPLACESEL) - or (Message.Msg = WM_IME_COMPOSITION) - then begin - // message w/ text parameter - Result := True; - CallDefaultWindowProc; - end else if (Message.Msg = WM_IME_CHAR) then begin - // WM_IME_CHAR - Result := True; - with Message do { convert to WM_CHAR } - Result := SendMessageW(ComboWnd, WM_CHAR, WParam, LParam); - end; - end; - except - Application.HandleException(Combo); - end; -end; - -function TntCombo_CNCommand(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; var Message: TWMCommand): Boolean; -begin - Result := False; - if Message.NotifyCode = CBN_SELCHANGE then begin - Result := True; - TntControl_SetText(Combo, Items[Combo.ItemIndex]); - TAccessCustomComboBox(Combo).Click; - TAccessCustomComboBox(Combo).Select; - end; -end; - -function TntCombo_GetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; -begin - if Win32PlatformIsUnicode then - Result := Combo.SelStart - else - Result := Length(WideString(Copy(TAccessCustomComboBox(Combo).Text, 1, Combo.SelStart))); -end; - -procedure TntCombo_SetSelStart(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); -begin - if Win32PlatformIsUnicode then - Combo.SelStart := Value - else - Combo.SelStart := Length(AnsiString(Copy(TntControl_GetText(Combo), 1, Value))); -end; - -function TntCombo_GetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): Integer; -begin - if Win32PlatformIsUnicode then - Result := Combo.SelLength - else - Result := Length(TntCombo_GetSelText(Combo)); -end; - -procedure TntCombo_SetSelLength(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: Integer); -var - StartPos: Integer; -begin - if Win32PlatformIsUnicode then - Combo.SelLength := Value - else begin - StartPos := TntCombo_GetSelStart(Combo); - Combo.SelLength := Length(AnsiString(Copy(TntControl_GetText(Combo), StartPos + 1, Value))); - end; -end; - -function TntCombo_GetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}): WideString; -begin - if Win32PlatformIsUnicode then begin - Result := ''; - if TAccessCustomComboBox(Combo).Style < csDropDownList then - Result := Copy(TntControl_GetText(Combo), Combo.SelStart + 1, Combo.SelLength); - end else - Result := Combo.SelText -end; - -procedure TntCombo_SetSelText(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; const Value: WideString); -begin - if Win32PlatformIsUnicode then begin - if TAccessCustomComboBox(Combo).Style < csDropDownList then - begin - Combo.HandleNeeded; - SendMessageW(TAccessCustomComboBox(Combo).EditHandle, EM_REPLACESEL, 0, Longint(PWideChar(Value))); - end; - end else - Combo.SelText := Value -end; - -procedure TntCombo_BeforeKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); -begin - SaveAutoComplete := TAccessCustomComboBox(Combo).AutoComplete; - TAccessCustomComboBox(Combo).AutoComplete := False; -end; - -procedure TntCombo_AfterKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; var SaveAutoComplete: Boolean); -begin - TAccessCustomComboBox(Combo).AutoComplete := SaveAutoComplete; -end; - -procedure TntCombo_DropDown_PreserveSelection(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}); -var - OldSelStart, OldSelLength: Integer; - OldText: WideString; -begin - OldText := TntControl_GetText(Combo); - OldSelStart := TntCombo_GetSelStart(Combo); - OldSelLength := TntCombo_GetSelLength(Combo); - Combo.DroppedDown := True; - TntControl_SetText(Combo, OldText); - TntCombo_SetSelStart(Combo, OldSelStart); - TntCombo_SetSelLength(Combo ,OldSelLength); -end; - -procedure TntComboBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); -begin - Items.AddObject(Item, AObject); -end; - -procedure TntComboBox_CopySelection(Items: TTntStrings; ItemIndex: Integer; - Destination: TCustomListControl); -begin - if ItemIndex <> -1 then - WideListControl_AddItem(Destination, Items[ItemIndex], Items.Objects[ItemIndex]); -end; - -function TntCombo_FindString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - StartPos: Integer; const Text: WideString): Integer; -var - ComboFindString: ITntComboFindString; -begin - if Combo.GetInterface(ITntComboFindString, ComboFindString) then - Result := ComboFindString.FindString(Text, StartPos) - else if IsWindowUnicode(Combo.Handle) then - Result := SendMessageW(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PWideChar(Text))) - else - Result := SendMessageA(Combo.Handle, CB_FINDSTRING, StartPos, Integer(PAnsiChar(AnsiString(Text)))) -end; - -function TntCombo_FindUniqueString(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - StartPos: Integer; const Text: WideString): Integer; -var - Match_1, Match_2: Integer; -begin - Result := CB_ERR; - Match_1 := TntCombo_FindString(Combo, -1, Text); - if Match_1 <> CB_ERR then begin - Match_2 := TntCombo_FindString(Combo, Match_1, Text); - if Match_2 = Match_1 then - Result := Match_1; - end; -end; - -function TntCombo_AutoSelect(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; Items: TTntStrings; - const SearchText: WideString; UniqueMatchOnly: Boolean; UseDataEntryCase: Boolean): Boolean; -var - Idx: Integer; - ValueChange: Boolean; -begin - if UniqueMatchOnly then - Idx := TntCombo_FindUniqueString(Combo, -1, SearchText) - else - Idx := TntCombo_FindString(Combo, -1, SearchText); - Result := (Idx <> CB_ERR); - if Result then begin - if TAccessCustomComboBox(Combo).Style = csDropDown then - ValueChange := not WideSameStr(TntControl_GetText(Combo), Items[Idx]) - else - ValueChange := Idx <> Combo.ItemIndex; - {$IFDEF COMPILER_7_UP} - // auto-closeup - if Combo.AutoCloseUp and (Items.IndexOf(SearchText) <> -1) then - Combo.DroppedDown := False; - {$ENDIF} - // select item - Combo.ItemIndex := Idx; - // update edit - if (TAccessCustomComboBox(Combo).Style in [csDropDown, csSimple]) then begin - if UseDataEntryCase then begin - // preserve case of characters as they are entered - TntControl_SetText(Combo, SearchText + Copy(Items[Combo.ItemIndex], Length(SearchText) + 1, MaxInt)); - end else begin - TntControl_SetText(Combo, Items[Idx]); - end; - // select the rest of the string - TntCombo_SetSelStart(Combo, Length(SearchText)); - TntCombo_SetSelLength(Combo, Length(TntControl_GetText(Combo)) - TntCombo_GetSelStart(Combo)); - end; - // notify events - if ValueChange then begin - TAccessCustomComboBox(Combo).Click; - TAccessCustomComboBox(Combo).Select; - end; - end; -end; - -procedure TntCombo_AutoSearchKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var Message: TWMChar; var FFilter: WideString; var FLastTime: Cardinal); -var - Key: WideChar; -begin - if TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown] then - exit; - if not Combo.AutoComplete then - exit; - Key := GetWideCharFromWMCharMsg(Message); - try - case Ord(Key) of - VK_ESCAPE: - exit; - VK_TAB: - if Combo.AutoDropDown and Combo.DroppedDown then - Combo.DroppedDown := False; - VK_BACK: - Delete(FFilter, Length(FFilter), 1); - else begin - if Combo.AutoDropDown and (not Combo.DroppedDown) then - Combo.DroppedDown := True; - // reset FFilter if it's been too long (1.25 sec) { Windows XP is actually 2 seconds! } - if GetTickCount - FLastTime >= 1250 then - FFilter := ''; - FLastTime := GetTickCount; - // if AutoSelect works, remember new FFilter - if TntCombo_AutoSelect(Combo, Items, FFilter + Key, False, True) then begin - FFilter := FFilter + Key; - Key := #0; - end; - end; - end; - finally - SetWideCharForWMCharMsg(Message, Key); - end; -end; - -procedure TntCombo_AutoCompleteKeyPress(Combo: TCustomComboBox{TNT-ALLOW TCustomComboBox}; - Items: TTntStrings; var Message: TWMChar; - AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase: Boolean); -var - Key: WideChar; - FindText: WideString; -begin - Assert(TAccessCustomComboBox(Combo).Style in [csSimple, csDropDown], 'Internal Error: TntCombo_AutoCompleteKeyPress is only for csSimple and csDropDown style combo boxes.'); - if not Combo.AutoComplete then exit; - Key := GetWideCharFromWMCharMsg(Message); - try - case Ord(Key) of - VK_ESCAPE: - exit; - VK_TAB: - if Combo.AutoDropDown and Combo.DroppedDown then - Combo.DroppedDown := False; - VK_BACK: - exit; - else begin - if Combo.AutoDropDown and (not Combo.DroppedDown) then - TntCombo_DropDown_PreserveSelection(Combo); - // AutoComplete only if the selection is at the very end - if ((TntCombo_GetSelStart(Combo) + TntCombo_GetSelLength(Combo)) - = Length(TntControl_GetText(Combo))) then - begin - FindText := Copy(TntControl_GetText(Combo), 1, TntCombo_GetSelStart(Combo)) + Key; - if TntCombo_AutoSelect(Combo, Items, FindText, AutoComplete_UniqueMatchOnly, AutoComplete_PreserveDataEntryCase) then - begin - Key := #0; - end; - end; - end; - end; - finally - SetWideCharForWMCharMsg(Message, Key); - end; -end; - -//-- -constructor TTntCustomComboBox.Create(AOwner: TComponent); -begin - inherited; - FItems := TTntComboBoxStrings.Create; - TTntComboBoxStrings(FItems).ComboBox := Self; -end; - -destructor TTntCustomComboBox.Destroy; -begin - FreeAndNil(FItems); - FreeAndNil(FSaveItems); - inherited; -end; - -procedure TTntCustomComboBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'COMBOBOX'); -end; - -procedure TTntCustomComboBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomComboBox.CreateWnd; -var - PreInheritedAnsiText: AnsiString; -begin - PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; - inherited; - TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); -end; - -procedure TTntCustomComboBox.DestroyWnd; -var - SavedText: WideString; -begin - if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } - TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); - inherited; - TntControl_SetStoredText(Self, SavedText); - end; -end; - -procedure TTntCustomComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); -begin - if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then - inherited; -end; - -procedure TTntCustomComboBox.KeyPress(var Key: AnsiChar); -var - SaveAutoComplete: Boolean; -begin - TntCombo_BeforeKeyPress(Self, SaveAutoComplete); - try - inherited; - finally - TntCombo_AfterKeyPress(Self, SaveAutoComplete); - end; -end; - -procedure TTntCustomComboBox.DoEditCharMsg(var Message: TWMChar); -begin - TntCombo_AutoCompleteKeyPress(Self, Items, Message, - GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); -end; - -procedure TTntCustomComboBox.WMChar(var Message: TWMChar); -begin - TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); - if Message.CharCode <> 0 then - inherited; -end; - -procedure TntCombo_DefaultDrawItem(Canvas: TCanvas; Index: Integer; Rect: TRect; - State: TOwnerDrawState; Items: TTntStrings); -begin - Canvas.FillRect(Rect); - if Index >= 0 then - WideCanvasTextOut(Canvas, Rect.Left + 2, Rect.Top, Items[Index]); -end; - -procedure TTntCustomComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); -begin - TControlCanvas(Canvas).UpdateTextFlags; - if Assigned(OnDrawItem) then - OnDrawItem(Self, Index, Rect, State) - else - TntCombo_DefaultDrawItem(Canvas, Index, Rect, State, Items); -end; - -function TTntCustomComboBox.GetItems: TTntStrings; -begin - Result := FItems; -end; - -procedure TTntCustomComboBox.SetItems(const Value: TTntStrings); -begin - FItems.Assign(Value); -end; - -function TTntCustomComboBox.GetSelStart: Integer; -begin - Result := TntCombo_GetSelStart(Self); -end; - -procedure TTntCustomComboBox.SetSelStart(const Value: Integer); -begin - TntCombo_SetSelStart(Self, Value); -end; - -function TTntCustomComboBox.GetSelLength: Integer; -begin - Result := TntCombo_GetSelLength(Self); -end; - -procedure TTntCustomComboBox.SetSelLength(const Value: Integer); -begin - TntCombo_SetSelLength(Self, Value); -end; - -function TTntCustomComboBox.GetSelText: WideString; -begin - Result := TntCombo_GetSelText(Self); -end; - -procedure TTntCustomComboBox.SetSelText(const Value: WideString); -begin - TntCombo_SetSelText(Self, Value); -end; - -function TTntCustomComboBox.GetText: WideString; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntCustomComboBox.SetText(const Value: WideString); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomComboBox.CNCommand(var Message: TWMCommand); -begin - if not TntCombo_CNCommand(Self, Items, Message) then - inherited; -end; - -function TTntCustomComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; -begin - Result := True; -end; - -function TTntCustomComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; -begin - Result := False; -end; - -function TTntCustomComboBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomComboBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomComboBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomComboBox.AddItem(const Item: WideString; AObject: TObject); -begin - TntComboBox_AddItem(Items, Item, AObject); -end; - -procedure TTntCustomComboBox.CopySelection(Destination: TCustomListControl); -begin - TntComboBox_CopySelection(Items, ItemIndex, Destination); -end; - -procedure TTntCustomComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomComboBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{$IFDEF DELPHI_7} // fix for Delphi 7 only -function TTntCustomComboBox.GetItemsClass: TCustomComboBoxStringsClass; -begin - Result := TD7PatchedComboBoxStrings; -end; -{$ENDIF} - -{ TTntListBoxStrings } - -function TTntListBoxStrings.GetListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; -begin - Result := TCustomListBox{TNT-ALLOW TCustomListBox}(FListBox); -end; - -procedure TTntListBoxStrings.SetListBox(const Value: TCustomListBox{TNT-ALLOW TCustomListBox}); -begin - FListBox := TAccessCustomListBox(Value); -end; - -function TTntListBoxStrings.GetCount: Integer; -begin - Result := ListBox.Items.Count; -end; - -function TTntListBoxStrings.Get(Index: Integer): WideString; -var - Len: Integer; -begin - if (not IsWindowUnicode(ListBox.Handle)) then - Result := ListBox.Items[Index] - else begin - Len := SendMessageW(ListBox.Handle, LB_GETTEXTLEN, Index, 0); - if Len = LB_ERR then - Error(SListIndexError, Index) - else begin - SetLength(Result, Len + 1); - Len := SendMessageW(ListBox.Handle, LB_GETTEXT, Index, Longint(PWideChar(Result))); - if Len = LB_ERR then - Result := '' - else - Result := PWideChar(Result); - end; - end; -end; - -function TTntListBoxStrings.GetObject(Index: Integer): TObject; -begin - Result := ListBox.Items.Objects[Index]; -end; - -procedure TTntListBoxStrings.Put(Index: Integer; const S: WideString); -var - I: Integer; - TempData: Longint; -begin - I := ListBox.ItemIndex; - TempData := FListBox.InternalGetItemData(Index); - // Set the Item to 0 in case it is an object that gets freed during Delete - FListBox.InternalSetItemData(Index, 0); - Delete(Index); - InsertObject(Index, S, nil); - FListBox.InternalSetItemData(Index, TempData); - ListBox.ItemIndex := I; -end; - -procedure TTntListBoxStrings.PutObject(Index: Integer; AObject: TObject); -begin - ListBox.Items.Objects[Index] := AObject; -end; - -function TTntListBoxStrings.Add(const S: WideString): Integer; -begin - if (not IsWindowUnicode(ListBox.Handle)) then - Result := ListBox.Items.Add(S) - else begin - Result := SendMessageW(ListBox.Handle, LB_ADDSTRING, 0, Longint(PWideChar(S))); - if Result < 0 then - raise EOutOfResources.Create(SInsertLineError); - end; -end; - -procedure TTntListBoxStrings.Insert(Index: Integer; const S: WideString); -begin - if (not IsWindowUnicode(ListBox.Handle)) then - ListBox.Items.Insert(Index, S) - else begin - if SendMessageW(ListBox.Handle, LB_INSERTSTRING, Index, Longint(PWideChar(S))) < 0 then - raise EOutOfResources.Create(SInsertLineError); - end; -end; - -procedure TTntListBoxStrings.Delete(Index: Integer); -begin - FListBox.DeleteString(Index); -end; - -procedure TTntListBoxStrings.Exchange(Index1, Index2: Integer); -var - TempData: Longint; - TempString: WideString; -begin - BeginUpdate; - try - TempString := Strings[Index1]; - TempData := FListBox.InternalGetItemData(Index1); - Strings[Index1] := Strings[Index2]; - FListBox.InternalSetItemData(Index1, FListBox.InternalGetItemData(Index2)); - Strings[Index2] := TempString; - FListBox.InternalSetItemData(Index2, TempData); - if ListBox.ItemIndex = Index1 then - ListBox.ItemIndex := Index2 - else if ListBox.ItemIndex = Index2 then - ListBox.ItemIndex := Index1; - finally - EndUpdate; - end; -end; - -procedure TTntListBoxStrings.Clear; -begin - FListBox.ResetContent; -end; - -procedure TTntListBoxStrings.SetUpdateState(Updating: Boolean); -begin - TAccessStrings(ListBox.Items).SetUpdateState(Updating); -end; - -function TTntListBoxStrings.IndexOf(const S: WideString): Integer; -begin - if (not IsWindowUnicode(ListBox.Handle)) then - Result := ListBox.Items.IndexOf(S) - else - Result := SendMessageW(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LongInt(PWideChar(S))); -end; - -procedure TTntListBoxStrings.Move(CurIndex, NewIndex: Integer); -var - TempData: Longint; - TempString: WideString; -begin - BeginUpdate; - FListBox.FMoving := True; - try - if CurIndex <> NewIndex then - begin - TempString := Get(CurIndex); - TempData := FListBox.InternalGetItemData(CurIndex); - FListBox.InternalSetItemData(CurIndex, 0); - Delete(CurIndex); - Insert(NewIndex, TempString); - FListBox.InternalSetItemData(NewIndex, TempData); - end; - finally - FListBox.FMoving := False; - EndUpdate; - end; -end; - -//-- list box helper procs - -procedure TntListBox_AfterInherited_CreateWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; - var FSaveItems: TTntStrings; FItems: TTntStrings; FSaveTopIndex, FSaveItemIndex: Integer); -begin - if FSaveItems <> nil then - begin - FItems.Assign(FSaveItems); - FreeAndNil(FSaveItems); - ListBox.TopIndex := FSaveTopIndex; - ListBox.ItemIndex := FSaveItemIndex; - end; -end; - -procedure TntListBox_BeforeInherited_DestroyWnd(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; - var FSaveItems: TTntStrings; const FItems: TTntStrings; var FSaveTopIndex, FSaveItemIndex: Integer); -begin - if (FItems.Count > 0) - and (not (TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw])) - then begin - FSaveItems := TTntStringList.Create; - FSaveItems.Assign(FItems); - FSaveTopIndex := ListBox.TopIndex; - FSaveItemIndex := ListBox.ItemIndex; - ListBox.Items.Clear; { This keeps TCustomListBox from creating its own FSaveItems. (this kills the original ItemIndex) } - end; -end; - -procedure TntListBox_DrawItem_Text(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; Items: TTntStrings; Index: Integer; Rect: TRect); -var - Flags: Integer; - Canvas: TCanvas; -begin - Canvas := TAccessCustomListBox(ListBox).Canvas; - Canvas.FillRect(Rect); - if Index < Items.Count then - begin - Flags := ListBox.DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); - if not ListBox.UseRightToLeftAlignment then - Inc(Rect.Left, 2) - else - Dec(Rect.Right, 2); - Tnt_DrawTextW(Canvas.Handle, PWideChar(Items[Index]), Length(Items[Index]), Rect, Flags); - end; -end; - -procedure TntListBox_AddItem(Items: TTntStrings; const Item: WideString; AObject: TObject); -begin - Items.AddObject(PWideChar(Item), AObject); -end; - -procedure TntListBox_CopySelection(ListBox: TCustomListbox{TNT-ALLOW TCustomListbox}; - Items: TTntStrings; Destination: TCustomListControl); -var - I: Integer; -begin - if ListBox.MultiSelect then - begin - for I := 0 to Items.Count - 1 do - if ListBox.Selected[I] then - WideListControl_AddItem(Destination, PWideChar(Items[I]), Items.Objects[I]); - end - else - if Listbox.ItemIndex <> -1 then - WideListControl_AddItem(Destination, PWideChar(Items[ListBox.ItemIndex]), Items.Objects[ListBox.ItemIndex]); -end; - -function TntCustomListBox_GetOwnerData(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; Index: Integer; out Data: WideString): Boolean; -var - AnsiData: AnsiString; -begin - Result := False; - Data := ''; - if (Index > -1) and (Index < ListBox.Count) then begin - if Assigned(OnData) then begin - OnData(ListBox, Index, Data); - Result := True; - end else if Assigned(TAccessCustomListBox(ListBox).OnData) then begin - AnsiData := ''; - TAccessCustomListBox(ListBox).OnData(ListBox, Index, AnsiData); - Data := AnsiData; - Result := True; - end; - end; -end; - -function TntCustomListBox_LBGetText(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; -var - S: WideString; - AnsiS: AnsiString; -begin - if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then - begin - Result := True; - if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin - if Win32PlatformIsUnicode then begin - WStrCopy(PWideChar(Message.LParam), PWideChar(S)); - Message.Result := Length(S); - end else begin - AnsiS := S; - StrCopy{TNT-ALLOW StrCopy}(PAnsiChar(Message.LParam), PAnsiChar(AnsiS)); - Message.Result := Length(AnsiS); - end; - end - else - Message.Result := LB_ERR; - end - else - Result := False; -end; - -function TntCustomListBox_LBGetTextLen(ListBox: TCustomListBox{TNT-ALLOW TCustomListBox}; OnData: TLBGetWideDataEvent; var Message: TMessage): Boolean; -var - S: WideString; -begin - if TAccessCustomListBox(ListBox).Style in [lbVirtual, lbVirtualOwnerDraw] then - begin - Result := True; - if TntCustomListBox_GetOwnerData(ListBox, OnData, Message.WParam, S) then begin - if Win32PlatformIsUnicode then - Message.Result := Length(S) - else - Message.Result := Length(AnsiString(S)); - end else - Message.Result := LB_ERR; - end - else - Result := False; -end; - -{ TTntCustomListBox } - -constructor TTntCustomListBox.Create(AOwner: TComponent); -begin - inherited; - FItems := TTntListBoxStrings.Create; - TTntListBoxStrings(FItems).ListBox := Self; -end; - -destructor TTntCustomListBox.Destroy; -begin - FreeAndNil(FItems); - FreeAndNil(FSaveItems); - inherited; -end; - -procedure TTntCustomListBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'LISTBOX'); -end; - -procedure TTntCustomListBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomListBox.CreateWnd; -begin - inherited; - TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); -end; - -procedure TTntCustomListBox.DestroyWnd; -begin - TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex); - inherited; -end; - -procedure TTntCustomListBox.SetItems(const Value: TTntStrings); -begin - FItems.Assign(Value); -end; - -procedure TTntCustomListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); -begin - if Assigned(OnDrawItem) then - OnDrawItem(Self, Index, Rect, State) - else - TntListBox_DrawItem_Text(Self, Items, Index, Rect); -end; - -function TTntCustomListBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomListBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomListBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomListBox.AddItem(const Item: WideString; AObject: TObject); -begin - TntListBox_AddItem(Items, Item, AObject); -end; - -procedure TTntCustomListBox.CopySelection(Destination: TCustomListControl); -begin - TntListBox_CopySelection(Self, Items, Destination); -end; - -procedure TTntCustomListBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomListBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -procedure TTntCustomListBox.LBGetText(var Message: TMessage); -begin - if not TntCustomListBox_LBGetText(Self, OnData, Message) then - inherited; -end; - -procedure TTntCustomListBox.LBGetTextLen(var Message: TMessage); -begin - if not TntCustomListBox_LBGetTextLen(Self, OnData, Message) then - inherited; -end; - -// --- label helper procs - -type TAccessCustomLabel = class(TCustomLabel{TNT-ALLOW TCustomLabel}); - -function TntLabel_DoDrawText(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Rect: TRect; Flags: Integer; const GetLabelText: WideString): Boolean; -{$IFDEF COMPILER_9_UP} -const - EllipsisStr = '...'; - Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS, - DT_END_ELLIPSIS, DT_WORD_ELLIPSIS); -{$ENDIF} -var - Text: WideString; - ShowAccelChar: Boolean; - Canvas: TCanvas; - {$IFDEF COMPILER_9_UP} - DText: WideString; - NewRect: TRect; - Height: Integer; - Delim: Integer; - {$ENDIF} -begin - Result := False; - if Win32PlatformIsUnicode then begin - Result := True; - Text := GetLabelText; - ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; - Canvas := Control.Canvas; - if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and - (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' '; - if not ShowAccelChar then Flags := Flags or DT_NOPREFIX; - Flags := Control.DrawTextBiDiModeFlags(Flags); - Canvas.Font := TAccessCustomLabel(Control).Font; - {$IFDEF COMPILER_9_UP} - if (TAccessCustomLabel(Control).EllipsisPosition <> epNone) - and (not TAccessCustomLabel(Control).AutoSize) then - begin - DText := Text; - Flags := Flags and not (DT_EXPANDTABS or DT_CALCRECT); - Flags := Flags or Ellipsis[TAccessCustomLabel(Control).EllipsisPosition]; - if TAccessCustomLabel(Control).WordWrap - and (TAccessCustomLabel(Control).EllipsisPosition in [epEndEllipsis, epWordEllipsis]) then - begin - repeat - NewRect := Rect; - Dec(NewRect.Right, WideCanvasTextWidth(Canvas, EllipsisStr)); - Tnt_DrawTextW(Canvas.Handle, PWideChar(DText), Length(DText), NewRect, Flags or DT_CALCRECT); - Height := NewRect.Bottom - NewRect.Top; - if (Height > TAccessCustomLabel(Control).ClientHeight) - and (Height > Canvas.Font.Height) then - begin - Delim := WideLastDelimiter(' '#9, Text); - if Delim = 0 then - Delim := Length(Text); - Dec(Delim); - Text := Copy(Text, 1, Delim); - DText := Text + EllipsisStr; - if Text = '' then - Break; - end else - Break; - until False; - end; - if Text <> '' then - Text := DText; - end; - {$ENDIF} - if not Control.Enabled then - begin - OffsetRect(Rect, 1, 1); - Canvas.Font.Color := clBtnHighlight; - Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); - OffsetRect(Rect, -1, -1); - Canvas.Font.Color := clBtnShadow; - Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); - end - else - Tnt_DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Flags); - end; -end; - -procedure TntLabel_CMDialogChar(Control: TCustomLabel{TNT-ALLOW TCustomLabel}; var Message: TCMDialogChar; const Caption: WideString); -var - FocusControl: TWinControl; - ShowAccelChar: Boolean; -begin - FocusControl := TAccessCustomLabel(Control).FocusControl; - ShowAccelChar := TAccessCustomLabel(Control).ShowAccelChar; - if (FocusControl <> nil) and Control.Enabled and ShowAccelChar and - IsWideCharAccel(Message.CharCode, Caption) then - with FocusControl do - if CanFocus then - begin - SetFocus; - Message.Result := 1; - end; -end; - -{ TTntCustomLabel } - -procedure TTntCustomLabel.CMDialogChar(var Message: TCMDialogChar); -begin - TntLabel_CMDialogChar(Self, Message, Caption); -end; - -function TTntCustomLabel.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntCustomLabel.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self); -end; - -procedure TTntCustomLabel.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomLabel.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntCustomLabel.GetLabelText: WideString; -begin - Result := Caption; -end; - -procedure TTntCustomLabel.DoDrawText(var Rect: TRect; Flags: Integer); -begin - if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then - inherited; -end; - -function TTntCustomLabel.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomLabel.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomLabel.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomLabel.CMHintShow(var Message: TMessage); -begin - ProcessCMHintShowMsg(Message); - inherited; -end; - -procedure TTntCustomLabel.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomLabel.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntButton } - -procedure TntButton_CMDialogChar(Button: TButton{TNT-ALLOW TButton}; var Message: TCMDialogChar); -begin - with Message do - if IsWideCharAccel(Message.CharCode, TntControl_GetText(Button)) - and Button.CanFocus then - begin - Button.Click; - Result := 1; - end else - Button.Broadcast(Message); -end; - -procedure TTntButton.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'BUTTON'); -end; - -procedure TTntButton.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntButton.CMDialogChar(var Message: TCMDialogChar); -begin - TntButton_CMDialogChar(Self, Message); -end; - -function TTntButton.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntButton.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntButton.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntButton.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntButton.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntButton.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntButton.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomCheckBox } - -procedure TTntCustomCheckBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'BUTTON'); -end; - -procedure TTntCustomCheckBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomCheckBox.CMDialogChar(var Message: TCMDialogChar); -begin - with Message do - if IsWideCharAccel(Message.CharCode, Caption) - and CanFocus then - begin - SetFocus; - if Focused then Toggle; - Result := 1; - end else - Broadcast(Message); -end; - -function TTntCustomCheckBox.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -function TTntCustomCheckBox.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomCheckBox.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntCustomCheckBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomCheckBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomCheckBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomCheckBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntRadioButton } - -procedure TTntRadioButton.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'BUTTON'); -end; - -procedure TTntRadioButton.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntRadioButton.CMDialogChar(var Message: TCMDialogChar); -begin - with Message do - if IsWideCharAccel(Message.CharCode, Caption) - and CanFocus then - begin - SetFocus; - Result := 1; - end else - Broadcast(Message); -end; - -function TTntRadioButton.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntRadioButton.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntRadioButton.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntRadioButton.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntRadioButton.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntRadioButton.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntRadioButton.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntRadioButton.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntScrollBar } - -procedure TTntScrollBar.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'SCROLLBAR'); -end; - -procedure TTntScrollBar.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -function TTntScrollBar.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntScrollBar.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntScrollBar.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntScrollBar.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntScrollBar.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomGroupBox } - -procedure TTntCustomGroupBox.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -procedure TTntCustomGroupBox.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomGroupBox.CMDialogChar(var Message: TCMDialogChar); -begin - with Message do - if IsWideCharAccel(Message.CharCode, Caption) - and CanFocus then - begin - SelectFirst; - Result := 1; - end else - Broadcast(Message); -end; - -function TTntCustomGroupBox.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self); -end; - -function TTntCustomGroupBox.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomGroupBox.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomGroupBox.Paint; - - {$IFDEF THEME_7_UP} - procedure PaintThemedGroupBox; - var - CaptionRect: TRect; - OuterRect: TRect; - Size: TSize; - Box: TThemedButton; - Details: TThemedElementDetails; - begin - with Canvas do begin - if Caption <> '' then - begin - GetTextExtentPoint32W(Handle, PWideChar(Caption), Length(Caption), Size); - CaptionRect := Rect(0, 0, Size.cx, Size.cy); - if not UseRightToLeftAlignment then - OffsetRect(CaptionRect, 8, 0) - else - OffsetRect(CaptionRect, Width - 8 - CaptionRect.Right, 0); - end - else - CaptionRect := Rect(0, 0, 0, 0); - - OuterRect := ClientRect; - OuterRect.Top := (CaptionRect.Bottom - CaptionRect.Top) div 2; - with CaptionRect do - ExcludeClipRect(Handle, Left, Top, Right, Bottom); - if Enabled then - Box := tbGroupBoxNormal - else - Box := tbGroupBoxDisabled; - Details := ThemeServices.GetElementDetails(Box); - ThemeServices.DrawElement(Handle, Details, OuterRect); - - SelectClipRgn(Handle, 0); - if Text <> '' then - ThemeServices.DrawText{TNT-ALLOW DrawText}(Handle, Details, Caption, CaptionRect, DT_LEFT, 0); - end; - end; - {$ENDIF} - - procedure PaintGroupBox; - var - H: Integer; - R: TRect; - Flags: Longint; - begin - with Canvas do begin - H := WideCanvasTextHeight(Canvas, '0'); - R := Rect(0, H div 2 - 1, Width, Height); - if Ctl3D then - begin - Inc(R.Left); - Inc(R.Top); - Brush.Color := clBtnHighlight; - FrameRect(R); - OffsetRect(R, -1, -1); - Brush.Color := clBtnShadow; - end else - Brush.Color := clWindowFrame; - FrameRect(R); - if Caption <> '' then - begin - if not UseRightToLeftAlignment then - R := Rect(8, 0, 0, H) - else - R := Rect(R.Right - WideCanvasTextWidth(Canvas, Caption) - 8, 0, 0, H); - Flags := DrawTextBiDiModeFlags(DT_SINGLELINE); - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags or DT_CALCRECT); - Brush.Color := Color; - Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), R, Flags); - end; - end; - end; - -begin - if (not Win32PlatformIsUnicode) then - inherited - else - begin - Canvas.Font := Self.Font; - {$IFDEF THEME_7_UP} - if ThemeServices.ThemesEnabled then - PaintThemedGroupBox - else - PaintGroupBox; - {$ELSE} - PaintGroupBox; - {$ENDIF} - end; -end; - -function TTntCustomGroupBox.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomGroupBox.GetHint: WideString; -begin - Result := TntControl_GetHint(Self); -end; - -procedure TTntCustomGroupBox.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomGroupBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomGroupBox.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -{ TTntCustomStaticText } - -constructor TTntCustomStaticText.Create(AOwner: TComponent); -begin - inherited; - AdjustBounds; -end; - -procedure TTntCustomStaticText.CMFontChanged(var Message: TMessage); -begin - inherited; - AdjustBounds; -end; - -procedure TTntCustomStaticText.CMTextChanged(var Message: TMessage); -begin - inherited; - AdjustBounds; -end; - -procedure TTntCustomStaticText.Loaded; -begin - inherited; - AdjustBounds; -end; - -procedure TTntCustomStaticText.SetAutoSize(AValue: boolean); -begin - inherited; - if AValue then - AdjustBounds; -end; - -procedure TTntCustomStaticText.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, 'STATIC'); -end; - -procedure TTntCustomStaticText.DefineProperties(Filer: TFiler); -begin - inherited; - TntPersistent_AfterInherited_DefineProperties(Filer, Self); -end; - -procedure TTntCustomStaticText.CMDialogChar(var Message: TCMDialogChar); -begin - if (FocusControl <> nil) and Enabled and ShowAccelChar and - IsWideCharAccel(Message.CharCode, Caption) then - with FocusControl do - if CanFocus then - begin - SetFocus; - Message.Result := 1; - end; -end; - -function TTntCustomStaticText.IsCaptionStored: Boolean; -begin - Result := TntControl_IsCaptionStored(Self) -end; - -procedure TTntCustomStaticText.AdjustBounds; -var - DC: HDC; - SaveFont: HFont; - TextSize: TSize; -begin - if not (csReading in ComponentState) and AutoSize then - begin - DC := GetDC(0); - SaveFont := SelectObject(DC, Font.Handle); - GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), TextSize); - SelectObject(DC, SaveFont); - ReleaseDC(0, DC); - SetBounds(Left, Top, - TextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 4), - TextSize.cy + (GetSystemMetrics(SM_CYBORDER) * 4)); - end; -end; - -function TTntCustomStaticText.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomStaticText.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -function TTntCustomStaticText.IsHintStored: Boolean; -begin - Result := TntControl_IsHintStored(Self) -end; - -function TTntCustomStaticText.GetHint: WideString; -begin - Result := TntControl_GetHint(Self) -end; - -procedure TTntCustomStaticText.SetHint(const Value: WideString); -begin - TntControl_SetHint(Self, Value); -end; - -procedure TTntCustomStaticText.ActionChange(Sender: TObject; CheckDefaults: Boolean); -begin - TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); - inherited; -end; - -function TTntCustomStaticText.GetActionLinkClass: TControlActionLinkClass; -begin - Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas deleted file mode 100644 index f6cd3e2ebb..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas +++ /dev/null @@ -1,1699 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntSysUtils; - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: more filename functions from SysUtils } -{ TODO: Consider: string functions from StrUtils. } - -uses - Types, SysUtils, Windows; - -//--------------------------------------------------------------------------------------------- -// Tnt - Types -//--------------------------------------------------------------------------------------------- - -// ......... introduced ......... -type - // The user of the application did something plainly wrong. - ETntUserError = class(Exception); - // A general error occured. (ie. file didn't exist, server didn't return data, etc.) - ETntGeneralError = class(Exception); - // Like Assert(). An error occured that should never have happened, send me a bug report now! - ETntInternalError = class(Exception); - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas ......... - -{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr} -{TNT-WARN SameStr} {TNT-WARN AnsiSameStr} -{TNT-WARN SameText} {TNT-WARN AnsiSameText} -{TNT-WARN CompareText} {TNT-WARN AnsiCompareText} -{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase} -{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase} - -{TNT-WARN AnsiPos} { --> Pos() supports WideString. } -{TNT-WARN FmtStr} -{TNT-WARN Format} -{TNT-WARN FormatBuf} - -// ......... MBCS Byte Type Procs ......... - -{TNT-WARN ByteType} -{TNT-WARN StrByteType} -{TNT-WARN ByteToCharIndex} -{TNT-WARN ByteToCharLen} -{TNT-WARN CharToByteIndex} -{TNT-WARN CharToByteLen} - -// ........ null-terminated string functions ......... - -{TNT-WARN StrEnd} -{TNT-WARN StrLen} -{TNT-WARN StrLCopy} -{TNT-WARN StrCopy} -{TNT-WARN StrECopy} -{TNT-WARN StrPLCopy} -{TNT-WARN StrPCopy} -{TNT-WARN StrLComp} -{TNT-WARN AnsiStrLComp} -{TNT-WARN StrComp} -{TNT-WARN AnsiStrComp} -{TNT-WARN StrLIComp} -{TNT-WARN AnsiStrLIComp} -{TNT-WARN StrIComp} -{TNT-WARN AnsiStrIComp} -{TNT-WARN StrLower} -{TNT-WARN AnsiStrLower} -{TNT-WARN StrUpper} -{TNT-WARN AnsiStrUpper} -{TNT-WARN StrPos} -{TNT-WARN AnsiStrPos} -{TNT-WARN StrScan} -{TNT-WARN AnsiStrScan} -{TNT-WARN StrRScan} -{TNT-WARN AnsiStrRScan} -{TNT-WARN StrLCat} -{TNT-WARN StrCat} -{TNT-WARN StrMove} -{TNT-WARN StrPas} -{TNT-WARN StrAlloc} -{TNT-WARN StrBufSize} -{TNT-WARN StrNew} -{TNT-WARN StrDispose} - -{TNT-WARN AnsiExtractQuotedStr} -{TNT-WARN AnsiLastChar} -{TNT-WARN AnsiStrLastChar} -{TNT-WARN QuotedStr} -{TNT-WARN AnsiQuotedStr} -{TNT-WARN AnsiDequotedStr} - -// ........ string functions ......... - -{$IFNDEF COMPILER_9_UP} - // - // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat - // - - {$IFDEF COMPILER_7_UP} - type - PFormatSettings = ^TFormatSettings; - {$ENDIF} - - // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers. - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; - const FormatSettings: TFormatSettings): Cardinal; overload; - {$ENDIF} - - // SysUtils.WideFmtStr doesn't handle string lengths > 4096. - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); overload; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; overload; - {$ENDIF} - -{$ENDIF} - -{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9. -function Tnt_WideUpperCase(const S: WideString): WideString; -{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9. -function Tnt_WideLowerCase(const S: WideString): WideString; - -function TntWideLastChar(const S: WideString): WideChar; - -{TNT-WARN StringReplace} -{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x. -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - -{TNT-WARN AdjustLineBreaks} -type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR); -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; - -{TNT-WARN WrapText} -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; overload; -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload; - -// ........ filename manipulation ......... - -{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText -{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText -{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase -{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase - -{TNT-WARN IncludeTrailingBackslash} -function WideIncludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN IncludeTrailingPathDelimiter} -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingBackslash} -function WideExcludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingPathDelimiter} -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN IsDelimiter} -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -{TNT-WARN IsPathDelimiter} -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -{TNT-WARN LastDelimiter} -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -{TNT-WARN ChangeFileExt} -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -{TNT-WARN ExtractFilePath} -function WideExtractFilePath(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDir} -function WideExtractFileDir(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDrive} -function WideExtractFileDrive(const FileName: WideString): WideString; -{TNT-WARN ExtractFileName} -function WideExtractFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractFileExt} -function WideExtractFileExt(const FileName: WideString): WideString; -{TNT-WARN ExtractRelativePath} -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; - -// ........ file management routines ......... - -{TNT-WARN ExpandFileName} -function WideExpandFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractShortPathName} -function WideExtractShortPathName(const FileName: WideString): WideString; -{TNT-WARN FileCreate} -function WideFileCreate(const FileName: WideString): Integer; -{TNT-WARN FileOpen} -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -{TNT-WARN FileAge} -function WideFileAge(const FileName: WideString): Integer; overload; -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload; -{TNT-WARN DirectoryExists} -function WideDirectoryExists(const Name: WideString): Boolean; -{TNT-WARN FileExists} -function WideFileExists(const Name: WideString): Boolean; -{TNT-WARN FileGetAttr} -function WideFileGetAttr(const FileName: WideString): Cardinal; -{TNT-WARN FileSetAttr} -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -{TNT-WARN FileIsReadOnly} -function WideFileIsReadOnly(const FileName: WideString): Boolean; -{TNT-WARN FileSetReadOnly} -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -{TNT-WARN ForceDirectories} -function WideForceDirectories(Dir: WideString): Boolean; -{TNT-WARN FileSearch} -function WideFileSearch(const Name, DirList: WideString): WideString; -{TNT-WARN RenameFile} -function WideRenameFile(const OldName, NewName: WideString): Boolean; -{TNT-WARN DeleteFile} -function WideDeleteFile(const FileName: WideString): Boolean; -{TNT-WARN CopyFile} -function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; - - -{TNT-WARN TFileName} -type - TWideFileName = type WideString; - -{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary -type - TSearchRecW = record - Time: Integer; - Size: Int64; - Attr: Integer; - Name: TWideFileName; - ExcludeAttr: Integer; - FindHandle: THandle; - FindData: TWin32FindDataW; - end; -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -function WideFindNext(var F: TSearchRecW): Integer; -procedure WideFindClose(var F: TSearchRecW); - -{TNT-WARN CreateDir} -function WideCreateDir(const Dir: WideString): Boolean; -{TNT-WARN RemoveDir} -function WideRemoveDir(const Dir: WideString): Boolean; -{TNT-WARN GetCurrentDir} -function WideGetCurrentDir: WideString; -{TNT-WARN SetCurrentDir} -function WideSetCurrentDir(const Dir: WideString): Boolean; - - -// ........ date/time functions ......... - -{TNT-WARN TryStrToDateTime} -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToDate} -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToTime} -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; - -{ introduced } -function ValidDateTimeStr(Str: WideString): Boolean; -function ValidDateStr(Str: WideString): Boolean; -function ValidTimeStr(Str: WideString): Boolean; - -{TNT-WARN StrToDateTime} -function TntStrToDateTime(Str: WideString): TDateTime; -{TNT-WARN StrToDate} -function TntStrToDate(Str: WideString): TDateTime; -{TNT-WARN StrToTime} -function TntStrToTime(Str: WideString): TDateTime; -{TNT-WARN StrToDateTimeDef} -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToDateDef} -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToTimeDef} -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; - -{TNT-WARN CurrToStr} -{TNT-WARN CurrToStrF} -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -{TNT-WARN StrToCurr} -function TntStrToCurr(const S: WideString): Currency; -{TNT-WARN StrToCurrDef} -function ValidCurrencyStr(const S: WideString): Boolean; -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -function GetDefaultCurrencyFmt: TCurrencyFmtW; - -// ........ misc functions ......... - -{TNT-WARN GetLocaleStr} -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -{TNT-WARN SysErrorMessage} -function WideSysErrorMessage(ErrorCode: Integer): WideString; - -// ......... introduced ......... - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; - -const - CR = WideChar(#13); - LF = WideChar(#10); - CRLF = WideString(#13#10); - WideLineSeparator = WideChar($2028); - -var - Win32PlatformIsUnicode: Boolean; - Win32PlatformIsXP: Boolean; - Win32PlatformIs2003: Boolean; - Win32PlatformIsVista: Boolean; - -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -{$ENDIF} -function WinCheckH(RetVal: Cardinal): Cardinal; -function WinCheckFileH(RetVal: Cardinal): Cardinal; -function WinCheckP(RetVal: Pointer): Pointer; - -function WideGetModuleFileName(Instance: HModule): WideString; -function WideSafeLoadLibrary(const Filename: Widestring; - ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; -function WideLoadPackage(const Name: Widestring): HMODULE; - -function IsWideCharUpper(WC: WideChar): Boolean; -function IsWideCharLower(WC: WideChar): Boolean; -function IsWideCharDigit(WC: WideChar): Boolean; -function IsWideCharSpace(WC: WideChar): Boolean; -function IsWideCharPunct(WC: WideChar): Boolean; -function IsWideCharCntrl(WC: WideChar): Boolean; -function IsWideCharBlank(WC: WideChar): Boolean; -function IsWideCharXDigit(WC: WideChar): Boolean; -function IsWideCharAlpha(WC: WideChar): Boolean; -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; - -function WideTextPos(const SubStr, S: WideString): Integer; - -function ExtractStringArrayStr(P: PWideChar): WideString; -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -function IsRTF(const Value: WideString): Boolean; - -function ENG_US_FloatToStr(Value: Extended): WideString; -function ENG_US_StrToFloat(const S: WideString): Extended; - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -// ........ Variants.pas has WideString versions of these functions ......... -{TNT-WARN VarToStr} -{TNT-WARN VarToStrDef} - -var - _SettingChangeTime: Cardinal; - -implementation - -uses - ActiveX, ComObj, SysConst, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils, - TntSystem, TntWindows, TntFormatStrUtils; - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_9_UP} - - function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const - {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal; - var - OldFormat: WideString; - NewFormat: WideString; - begin - SetString(OldFormat, PWideChar(@FormatStr), FmtLen); - { The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } - NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - {$IFDEF COMPILER_7_UP} - if FormatSettings <> nil then - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args, FormatSettings^) - else - {$ENDIF} - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args); - end; - - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings); - end; - {$ENDIF} - - procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF}); - var - Len, BufLen: Integer; - Buffer: array[0..4095] of WideChar; - begin - BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744) - if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then - Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}) - else - begin - BufLen := Length(FormatStr); - Len := BufLen; - end; - if Len >= BufLen - 1 then - begin - while Len >= BufLen - 1 do - begin - Inc(BufLen, BufLen); - Result := ''; // prevent copying of existing data, for speed - SetLength(Result, BufLen); - Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - end; - SetLength(Result, Len); - end - else - SetString(Result, Buffer, Len); - end; - - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings); - end; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings); - end; - {$ENDIF} - -{$ENDIF} - -function Tnt_WideUpperCase(const S: WideString): WideString; -begin - {$IFNDEF COMPILER_10_UP} - { SysUtils.WideUpperCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharUpperBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S); - {$ENDIF} -end; - -function Tnt_WideLowerCase(const S: WideString): WideString; -begin - {$IFNDEF COMPILER_10_UP} - { SysUtils.WideLowerCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharLowerBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S); - {$ENDIF} -end; - -function TntWideLastChar(const S: WideString): WideChar; -var - P: PWideChar; -begin - P := WideLastChar(S); - if P = nil then - Result := #0 - else - Result := P^; -end; - -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - - function IsWordSeparator(WC: WideChar): Boolean; - begin - Result := (WC = WideChar(#0)) - or IsWideCharSpace(WC) - or IsWideCharPunct(WC); - end; - -var - SearchStr, Patt, NewStr: WideString; - Offset: Integer; - PrevChar, NextChar: WideChar; -begin - if rfIgnoreCase in Flags then - begin - SearchStr := Tnt_WideUpperCase(S); - Patt := Tnt_WideUpperCase(OldPattern); - end else - begin - SearchStr := S; - Patt := OldPattern; - end; - NewStr := S; - Result := ''; - while SearchStr <> '' do - begin - Offset := Pos(Patt, SearchStr); - if Offset = 0 then - begin - Result := Result + NewStr; - Break; - end; // done - - if (WholeWord) then - begin - if (Offset = 1) then - PrevChar := TntWideLastChar(Result) - else - PrevChar := NewStr[Offset - 1]; - - if Offset + Length(OldPattern) <= Length(NewStr) then - NextChar := NewStr[Offset + Length(OldPattern)] - else - NextChar := WideChar(#0); - - if (not IsWordSeparator(PrevChar)) - or (not IsWordSeparator(NextChar)) then - begin - Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1); - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - continue; - end; - end; - - Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - if not (rfReplaceAll in Flags) then - begin - Result := Result + NewStr; - Break; - end; - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - end; -end; - -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -var - Source, SourceEnd: PWideChar; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - Result := Length(S); - while Source < SourceEnd do - begin - case Source^ of - #10, WideLineSeparator: - if Style = tlbsCRLF then - Inc(Result); - #13: - if Style = tlbsCRLF then - if Source[1] = #10 then - Inc(Source) - else - Inc(Result) - else - if Source[1] = #10 then - Dec(Result); - end; - Inc(Source); - end; -end; - -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; -var - Source, SourceEnd, Dest: PWideChar; - DestLen: Integer; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - DestLen := TntAdjustLineBreaksLength(S, Style); - SetString(Result, nil, DestLen); - Dest := Pointer(Result); - while Source < SourceEnd do begin - case Source^ of - #10, WideLineSeparator: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - end; - #13: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - if Source^ = #10 then Inc(Source); - end; - else - Dest^ := Source^; - Inc(Dest); - Inc(Source); - end; - end; -end; - -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; - - function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean; - begin - Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet); - end; - -const - QuoteChars = ['''', '"']; -var - Col, Pos: Integer; - LinePos, LineLen: Integer; - BreakLen, BreakPos: Integer; - QuoteChar, CurChar: WideChar; - ExistingBreak: Boolean; -begin - Col := 1; - Pos := 1; - LinePos := 1; - BreakPos := 0; - QuoteChar := ' '; - ExistingBreak := False; - LineLen := Length(Line); - BreakLen := Length(BreakStr); - Result := ''; - while Pos <= LineLen do - begin - CurChar := Line[Pos]; - if CurChar = BreakStr[1] then - begin - if QuoteChar = ' ' then - begin - ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen)); - if ExistingBreak then - begin - Inc(Pos, BreakLen-1); - BreakPos := Pos; - end; - end - end - else if WideCharIn(CurChar, BreakChars) then - begin - if QuoteChar = ' ' then BreakPos := Pos - end - else if WideCharIn(CurChar, QuoteChars) then - begin - if CurChar = QuoteChar then - QuoteChar := ' ' - else if QuoteChar = ' ' then - QuoteChar := CurChar; - end; - Inc(Pos); - Inc(Col); - if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or - ((Col > MaxCol) and (BreakPos > LinePos))) then - begin - Col := Pos - BreakPos; - Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); - if not (WideCharIn(CurChar, QuoteChars)) then - while Pos <= LineLen do - begin - if WideCharIn(Line[Pos], BreakChars) then - Inc(Pos) - else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then - Inc(Pos, Length(sLineBreak)) - else - break; - end; - if not ExistingBreak and (Pos < LineLen) then - Result := Result + BreakStr; - Inc(BreakPos); - LinePos := BreakPos; - ExistingBreak := False; - end; - end; - Result := Result + Copy(Line, LinePos, MaxInt); -end; - -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; -begin - Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } -end; - -function WideIncludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideIncludeTrailingPathDelimiter(S); -end; - -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim; -end; - -function WideExcludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideExcludeTrailingPathDelimiter(S); -end; - -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if WideIsPathDelimiter(Result, Length(Result)) then - SetLength(Result, Length(Result)-1); -end; - -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -begin - Result := False; - if (Index <= 0) or (Index > Length(S)) then exit; - Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil; -end; - -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -begin - Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim); -end; - -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -var - P: PWideChar; -begin - Result := Length(S); - P := PWideChar(Delimiters); - while Result > 0 do - begin - if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then - Exit; - Dec(Result); - end; -end; - -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:',Filename); - if (I = 0) or (FileName[I] <> '.') then I := MaxInt; - Result := Copy(FileName, 1, I - 1) + Extension; -end; - -function WideExtractFilePath(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDir(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter(DriveDelim + PathDelim,Filename); - if (I > 1) and (FileName[I] = PathDelim) and - (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDrive(const FileName: WideString): WideString; -var - I, J: Integer; -begin - if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then - Result := Copy(FileName, 1, 2) - else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and - (FileName[2] = PathDelim) then - begin - J := 0; - I := 3; - While (I < Length(FileName)) and (J < 2) do - begin - if FileName[I] = PathDelim then Inc(J); - if J < 2 then Inc(I); - end; - if FileName[I] = PathDelim then Dec(I); - Result := Copy(FileName, 1, I); - end else Result := ''; -end; - -function WideExtractFileName(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, I + 1, MaxInt); -end; - -function WideExtractFileExt(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:', FileName); - if (I > 0) and (FileName[I] = '.') then - Result := Copy(FileName, I, MaxInt) else - Result := ''; -end; - -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; -var - BasePath, DestPath: WideString; - BaseLead, DestLead: PWideChar; - BasePtr, DestPtr: PWideChar; - - function WideExtractFilePathNoDrive(const FileName: WideString): WideString; - begin - Result := WideExtractFilePath(FileName); - Delete(Result, 1, Length(WideExtractFileDrive(FileName))); - end; - - function Next(var Lead: PWideChar): PWideChar; - begin - Result := Lead; - if Result = nil then Exit; - Lead := WStrScan(Lead, PathDelim); - if Lead <> nil then - begin - Lead^ := #0; - Inc(Lead); - end; - end; - -begin - if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then - begin - BasePath := WideExtractFilePathNoDrive(BaseName); - DestPath := WideExtractFilePathNoDrive(DestName); - BaseLead := Pointer(BasePath); - BasePtr := Next(BaseLead); - DestLead := Pointer(DestPath); - DestPtr := Next(DestLead); - while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do - begin - BasePtr := Next(BaseLead); - DestPtr := Next(DestLead); - end; - Result := ''; - while BaseLead <> nil do - begin - Result := Result + '..' + PathDelim; { Do not localize } - Next(BaseLead); - end; - if (DestPtr <> nil) and (DestPtr^ <> #0) then - Result := Result + DestPtr + PathDelim; - if DestLead <> nil then - Result := Result + DestLead; // destlead already has a trailing backslash - Result := Result + WideExtractFileName(DestName); - end - else - Result := DestName; -end; - -function WideExpandFileName(const FileName: WideString): WideString; -var - FName: PWideChar; - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName)); -end; - -function WideExtractShortPathName(const FileName: WideString): WideString; -var - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH)); -end; - -function WideFileCreate(const FileName: WideString): Integer; -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE, - 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)) -end; - -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -const - AccessMode: array[0..2] of LongWord = ( - GENERIC_READ, - GENERIC_WRITE, - GENERIC_READ or GENERIC_WRITE); - ShareMode: array[0..4] of LongWord = ( - 0, - 0, - FILE_SHARE_READ, - FILE_SHARE_WRITE, - FILE_SHARE_READ or FILE_SHARE_WRITE); -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3], - ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, 0)); -end; - -function WideFileAge(const FileName: WideString): Integer; -var - Handle: THandle; - FindData: TWin32FindDataW; - LocalFileTime: TFileTime; -begin - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then - Exit - end; - end; - Result := -1; -end; - -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; -var - Handle: THandle; - FindData: TWin32FindDataW; - LSystemTime: TSystemTime; - LocalFileTime: TFileTime; -begin - Result := False; - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - Result := True; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToSystemTime(LocalFileTime, LSystemTime); - with LSystemTime do - FileDateTime := EncodeDate(wYear, wMonth, wDay) + - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); - end; - end; -end; - -function WideDirectoryExists(const Name: WideString): Boolean; -var - Code: Cardinal; -begin - Code := WideFileGetAttr(Name); - Result := (Code <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); -end; - -function WideFileExists(const Name: WideString): Boolean; -var - Handle: THandle; - FindData: TWin32FindDataW; -begin - Result := False; - Handle := Tnt_FindFirstFileW(PWideChar(Name), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - Result := True; - end; -end; - -function WideFileGetAttr(const FileName: WideString): Cardinal; -begin - Result := Tnt_GetFileAttributesW(PWideChar(FileName)); -end; - -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -begin - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr) -end; - -function WideFileIsReadOnly(const FileName: WideString): Boolean; -begin - Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0; -end; - -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -var - Flags: Integer; -begin - Result := False; - Flags := Tnt_GetFileAttributesW(PWideChar(FileName)); - if Flags = -1 then Exit; - if ReadOnly then - Flags := Flags or faReadOnly - else - Flags := Flags and not faReadOnly; - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags); -end; - -function WideForceDirectories(Dir: WideString): Boolean; -begin - Result := True; - if Length(Dir) = 0 then - raise ETntGeneralError.Create(SCannotCreateDir); - Dir := WideExcludeTrailingBackslash(Dir); - if (Length(Dir) < 3) or WideDirectoryExists(Dir) - or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. - Result := WideForceDirectories(WideExtractFilePath(Dir)); - if Result then - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil) -end; - -function WideFileSearch(const Name, DirList: WideString): WideString; -var - I, P, L: Integer; - C: WideChar; -begin - Result := Name; - P := 1; - L := Length(DirList); - while True do - begin - if WideFileExists(Result) then Exit; - while (P <= L) and (DirList[P] = PathSep) do Inc(P); - if P > L then Break; - I := P; - while (P <= L) and (DirList[P] <> PathSep) do - Inc(P); - Result := Copy(DirList, I, P - I); - C := TntWideLastChar(Result); - if (C <> DriveDelim) and (C <> PathDelim) then - Result := Result + PathDelim; - Result := Result + Name; - end; - Result := ''; -end; - -function WideRenameFile(const OldName, NewName: WideString): Boolean; -begin - Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName)) -end; - -function WideDeleteFile(const FileName: WideString): Boolean; -begin - Result := Tnt_DeleteFileW(PWideChar(FileName)) -end; - -function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; -begin - Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists) -end; - -function _WideFindMatchingFile(var F: TSearchRecW): Integer; -var - LocalFileTime: TFileTime; -begin - with F do - begin - while FindData.dwFileAttributes and ExcludeAttr <> 0 do - if not Tnt_FindNextFileW(FindHandle, FindData) then - begin - Result := GetLastError; - Exit; - end; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); - Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow; - Attr := FindData.dwFileAttributes; - Name := FindData.cFileName; - end; - Result := 0; -end; - -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -const - faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory; -begin - F.ExcludeAttr := not Attr and faSpecial; - F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData); - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Result := _WideFindMatchingFile(F); - if Result <> 0 then WideFindClose(F); - end else - Result := GetLastError; -end; - -function WideFindNext(var F: TSearchRecW): Integer; -begin - if Tnt_FindNextFileW(F.FindHandle, F.FindData) then - Result := _WideFindMatchingFile(F) else - Result := GetLastError; -end; - -procedure WideFindClose(var F: TSearchRecW); -begin - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(F.FindHandle); - F.FindHandle := INVALID_HANDLE_VALUE; - end; -end; - -function WideCreateDir(const Dir: WideString): Boolean; -begin - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil); -end; - -function WideRemoveDir(const Dir: WideString): Boolean; -begin - Result := Tnt_RemoveDirectoryW(PWideChar(Dir)); -end; - -function WideGetCurrentDir: WideString; -begin - SetLength(Result, MAX_PATH); - Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result)); - Result := PWideChar(Result); -end; - -function WideSetCurrentDir(const Dir: WideString): Boolean; -begin - Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir)); -end; - -//============================================================================================= -//== DATE/TIME STRING PARSING ================================================================ -//============================================================================================= - -function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult; -begin - Result := VarDateFromStr(Str, GetThreadLocale, Flags, Double(DateTime)); - if (not Succeeded(Result)) then begin - if (Flags = VAR_TIMEVALUEONLY) - and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss") - else if (Flags = VAR_DATEVALUEONLY) - and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - else if (Flags = 0) - and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - end; -end; - -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime)); -end; - -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime)); -end; - -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime)); -end; - -function ValidDateTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp)); -end; - -function ValidDateStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp)); -end; - -function ValidTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp)); -end; - -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDateTime(Str, Result) then - Result := Default; -end; - -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDate(Str, Result) then - Result := Default; -end; - -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToTime(Str, Result) then - Result := Default; -end; - -function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime; -begin - try - OleCheck(_IntTryStrToDateTime(Str, Flags, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function TntStrToDateTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, 0, SInvalidDateTime); -end; - -function TntStrToDate(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, SInvalidDate); -end; - -function TntStrToTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, SInvalidTime); -end; - -//============================================================================================= -//== CURRENCY STRING PARSING ================================================================= -//============================================================================================= - -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -const - MAX_BUFF_SIZE = 64; // can a currency string actually be larger? -var - ValueStr: WideString; -begin - // format lpValue using ENG-US settings - ValueStr := ENG_US_FloatToStr(Value); - // get currency format - SetLength(Result, MAX_BUFF_SIZE); - if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr), - lpFormat, PWideChar(Result), Length(Result)) - then begin - RaiseLastOSError; - end; - Result := PWideChar(Result); -end; - -function TntStrToCurr(const S: WideString): Currency; -begin - try - OleCheck(VarCyFromStr(S, GetThreadLocale, 0, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function ValidCurrencyStr(const S: WideString): Boolean; -var - Dummy: Currency; -begin - Result := Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Dummy)); -end; - -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -begin - if not Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Result)) then - Result := Default; -end; - -threadvar - Currency_DecimalSep: WideString; - Currency_ThousandSep: WideString; - Currency_CurrencySymbol: WideString; - -function GetDefaultCurrencyFmt: TCurrencyFmtW; -begin - ZeroMemory(@Result, SizeOf(Result)); - Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2); - Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1); - Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3); - Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.'); - Result.lpDecimalSep := PWideChar(Currency_DecimalSep); - Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ','); - Result.lpThousandSep := PWideChar(Currency_ThousandSep); - Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0); - Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0); - Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, ''); - Result.lpCurrencySymbol := PWideChar(Currency_CurrencySymbol); -end; - -//============================================================================================= - -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -var - L: Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default) - else begin - SetLength(Result, 255); - L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result)); - if L > 0 then - SetLength(Result, L - 1) - else - Result := Default; - end; -end; - -function WideSysErrorMessage(ErrorCode: Integer): WideString; -begin - Result := WideLibraryErrorMessage('system', 0, ErrorCode); -end; - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; -var - Len: Integer; - AnsiResult: AnsiString; - Flags: Cardinal; -begin - Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; - if Dll <> 0 then - Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE; - if Win32PlatformIsUnicode then begin - SetLength(Result, 256); - Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil); - SetLength(Result, Len); - end else begin - SetLength(AnsiResult, 256); - Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil); - SetLength(AnsiResult, Len); - Result := AnsiResult; - end; - if Trim(Result) = '' then - Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]); -end; - -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -begin - Result := (Win32MajorVersion > AMajor) or - ((Win32MajorVersion = AMajor) and - (Win32MinorVersion >= AMinor)); -end; -{$ENDIF} - -function WinCheckH(RetVal: Cardinal): Cardinal; -begin - if RetVal = 0 then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckFileH(RetVal: Cardinal): Cardinal; -begin - if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckP(RetVal: Pointer): Pointer; -begin - if RetVal = nil then RaiseLastOSError; - Result := RetVal; -end; - -function WideGetModuleFileName(Instance: HModule): WideString; -begin - SetLength(Result, MAX_PATH); - WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result))); - Result := PWideChar(Result) -end; - -function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE; -var - OldMode: UINT; - FPUControlWord: Word; -begin - OldMode := SetErrorMode(ErrorMode); - try - asm - FNSTCW FPUControlWord - end; - try - Result := Tnt_LoadLibraryW(PWideChar(Filename)); - finally - asm - FNCLEX - FLDCW FPUControlWord - end; - end; - finally - SetErrorMode(OldMode); - end; -end; - -function WideLoadPackage(const Name: Widestring): HMODULE; -begin - Result := WideSafeLoadLibrary(Name); - if Result = 0 then - begin - raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]); - end; - try - InitializePackage(Result); - except - FreeLibrary(Result); - raise; - end; -end; - -function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word; -begin - Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result)) -end; - -function IsWideCharUpper(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0; -end; - -function IsWideCharLower(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0; -end; - -function IsWideCharDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0; -end; - -function IsWideCharSpace(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0; -end; - -function IsWideCharPunct(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0; -end; - -function IsWideCharCntrl(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0; -end; - -function IsWideCharBlank(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0; -end; - -function IsWideCharXDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0; -end; - -function IsWideCharAlpha(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0; -end; - -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0; -end; - -function WideTextPos(const SubStr, S: WideString): Integer; -begin - Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S)); -end; - -function FindDoubleTerminator(P: PWideChar): PWideChar; -begin - Result := P; - while True do begin - Result := WStrScan(Result, #0); - Inc(Result); - if Result^ = #0 then begin - Dec(Result); - break; - end; - end; -end; - -function ExtractStringArrayStr(P: PWideChar): WideString; -var - PEnd: PWideChar; -begin - PEnd := FindDoubleTerminator(P); - Inc(PEnd, 2); // move past #0#0 - SetString(Result, P, PEnd - P); -end; - -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -var - Start: PWideChar; -begin - Start := P; - P := WStrScan(Start, Separator); - if P = nil then begin - Result := Start; - P := WStrEnd(Start); - end else begin - SetString(Result, Start, P - Start); - Inc(P); - end; -end; - -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; -const - GROW_COUNT = 256; -var - Count: Integer; - Item: WideString; -begin - Count := 0; - SetLength(Result, GROW_COUNT); - Item := ExtractStringFromStringArray(P, Separator); - While Item <> '' do begin - if Count > High(Result) then - SetLength(Result, Length(Result) + GROW_COUNT); - Result[Count] := Item; - Inc(Count); - Item := ExtractStringFromStringArray(P, Separator); - end; - SetLength(Result, Count); -end; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsRTF(const Value: WideString): Boolean; -const - RTF_BEGIN_1 = WideString('{\RTF'); - RTF_BEGIN_2 = WideString('{URTF'); -begin - Result := (WideTextPos(RTF_BEGIN_1, Value) = 1) - or (WideTextPos(RTF_BEGIN_2, Value) = 1); -end; - -{$IFDEF COMPILER_7_UP} -var - Cached_ENG_US_FormatSettings: TFormatSettings; - Cached_ENG_US_FormatSettings_Time: Cardinal; - -function ENG_US_FormatSettings: TFormatSettings; -begin - if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then - Result := Cached_ENG_US_FormatSettings - else begin - GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result); - Result.DecimalSeparator := '.'; // ignore overrides - Cached_ENG_US_FormatSettings := Result; - Cached_ENG_US_FormatSettings_Time := _SettingChangeTime; - end; - end; - -function ENG_US_FloatToStr(Value: Extended): WideString; -begin - Result := FloatToStr(Value, ENG_US_FormatSettings); -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -begin - if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then - Result := StrToFloat(S); // try using native format -end; - -{$ELSE} - -function ENG_US_FloatToStr(Value: Extended): WideString; -var - SaveDecimalSep: AnsiChar; -begin - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := FloatToStr(Value); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -var - SaveDecimalSep: AnsiChar; -begin - try - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := StrToFloat(S); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; - except - if SysUtils.DecimalSeparator <> '.' then - Result := StrToFloat(S) // try using native format - else - raise; - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -initialization - Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); - Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) - or (Win32MajorVersion > 5); - Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2)) - or (Win32MajorVersion > 5); - Win32PlatformIsVista := (Win32MajorVersion >= 6); - -finalization - Currency_DecimalSep := ''; {make memory sleuth happy} - Currency_ThousandSep := ''; {make memory sleuth happy} - Currency_CurrencySymbol := ''; {make memory sleuth happy} - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas deleted file mode 100644 index cc99aa48f7..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas +++ /dev/null @@ -1,1384 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntSystem; - -{$INCLUDE TntCompilers.inc} - -{*****************************************************************************} -{ Special thanks go to Francisco Leong for originating the design for } -{ WideString-enabled resourcestrings. } -{*****************************************************************************} - -interface - -uses - Windows; - -// These functions should not be used by Delphi code since conversions are implicit. -{TNT-WARN WideCharToString} -{TNT-WARN WideCharLenToString} -{TNT-WARN WideCharToStrVar} -{TNT-WARN WideCharLenToStrVar} -{TNT-WARN StringToWideChar} - -// ................ ANSI TYPES ................ -{TNT-WARN Char} -{TNT-WARN PChar} -{TNT-WARN String} - -{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage -function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString. - -var - WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean; - -{TNT-WARN LoadResString} -function WideLoadResString(ResStringRec: PResStringRec): WideString; -{TNT-WARN ParamCount} -function WideParamCount: Integer; -{TNT-WARN ParamStr} -function WideParamStr(Index: Integer): WideString; - -// ......... introduced ......... - -const - { Each Unicode stream should begin with the code U+FEFF, } - { which the standard defines as the *byte order mark*. } - UNICODE_BOM = WideChar($FEFF); - UNICODE_BOM_SWAPPED = WideChar($FFFE); - UTF8_BOM = AnsiString(#$EF#$BB#$BF); - -function WideStringToUTF8(const S: WideString): AnsiString; -function UTF8ToWideString(const S: AnsiString): WideString; - -function WideStringToUTF7(const W: WideString): AnsiString; -function UTF7ToWideString(const S: AnsiString): WideString; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; - -function UCS2ToWideString(const Value: AnsiString): WideString; -function WideStringToUCS2(const Value: WideString): AnsiString; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -function LCIDToCodePage(ALcid: LCID): Cardinal; -function KeyboardCodePage: Cardinal; -function KeyUnicode(CharCode: Word): WideChar; - -procedure StrSwapByteOrder(Str: PWideChar); - -type - TTntSystemUpdate = - (tsWideResourceStrings - {$IFNDEF COMPILER_9_UP}, tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat {$ENDIF} - ); - TTntSystemUpdateSet = set of TTntSystemUpdate; - -const - AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); - -implementation - -uses - SysUtils, Variants, TntWindows, TntSysUtils; - -var - GDefaultSystemCodePage: Cardinal; - -function DefaultSystemCodePage: Cardinal; -begin - Result := GDefaultSystemCodePage; -end; - -var - IsDebugging: Boolean; - -function WideLoadResString(ResStringRec: PResStringRec): WideString; -const - MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. } -var - Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. } - PCustom: PAnsiChar; -begin - if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then - exit; { a custom resourcestring has been loaded. } - - if ResStringRec = nil then - Result := '' - else if ResStringRec.Identifier < 64*1024 then - SetString(Result, Buffer, - Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^), - ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE)) - else begin - // custom string pointer - PCustom := PAnsiChar(ResStringRec.Identifier); { I would like to use PWideChar, but this would break legacy code. } - if (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM))) - and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then - // detected UTF8 - Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM))) - else - // normal - Result := PCustom; - end; -end; - -function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar; -var - i, Len: Integer; - Start, S, Q: PWideChar; -begin - while True do - begin - while (P[0] <> #0) and (P[0] <= ' ') do - Inc(P); - if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; - end; - Len := 0; - Start := P; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - if P[0] <> #0 then - Inc(P); - end - else - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - end; - - SetLength(Param, Len); - - P := Start; - S := PWideChar(Param); - i := 0; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - if P[0] <> #0 then Inc(P); - end - else - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - end; - - Result := P; -end; - -function WideParamCount: Integer; -var - P: PWideChar; - S: WideString; -begin - P := WideGetParamStr(GetCommandLineW, S); - Result := 0; - while True do - begin - P := WideGetParamStr(P, S); - if S = '' then Break; - Inc(Result); - end; -end; - -function WideParamStr(Index: Integer): WideString; -var - P: PWideChar; -begin - if Index = 0 then - Result := WideGetModuleFileName(0) - else - begin - P := GetCommandLineW; - while True do - begin - P := WideGetParamStr(P, Result); - if (Index = 0) or (Result = '') then Break; - Dec(Index); - end; - end; -end; - -function WideStringToUTF8(const S: WideString): AnsiString; -begin - Result := UTF8Encode(S); -end; - -function UTF8ToWideString(const S: AnsiString): WideString; -begin - Result := UTF8Decode(S); -end; - - { ======================================================================= } - { Original File: ConvertUTF7.c } - { Author: David B. Goldsmith } - { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved. } - { } - { This code is copyrighted. Under the copyright laws, this code may not } - { be copied, in whole or part, without prior written consent of Taligent. } - { } - { Taligent grants the right to use this code as long as this ENTIRE } - { copyright notice is reproduced in the code. The code is provided } - { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR } - { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF } - { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT } - { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING, } - { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS } - { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY } - { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN } - { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. } - { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF } - { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE } - { LIMITATION MAY NOT APPLY TO YOU. } - { } - { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the } - { government is subject to restrictions as set forth in subparagraph } - { (c)(l)(ii) of the Rights in Technical Data and Computer Software } - { clause at DFARS 252.227-7013 and FAR 52.227-19. } - { } - { This code may be protected by one or more U.S. and International } - { Patents. } - { } - { TRADEMARKS: Taligent and the Taligent Design Mark are registered } - { trademarks of Taligent, Inc. } - { ======================================================================= } - -type UCS2 = Word; - -const - _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?'; - _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}'; - _spaces: AnsiString = #9#13#10#32; - -var - base64: PAnsiChar; - invbase64: array[0..127] of SmallInt; - direct: PAnsiChar; - optional: PAnsiChar; - spaces: PAnsiChar; - mustshiftsafe: array[0..127] of AnsiChar; - mustshiftopt: array[0..127] of AnsiChar; - -var - needtables: Boolean = True; - -procedure Initialize_UTF7_Data; -begin - base64 := PAnsiChar(_base64); - direct := PAnsiChar(_direct); - optional := PAnsiChar(_optional); - spaces := PAnsiChar(_spaces); -end; - -procedure tabinit; -var - i: Integer; - limit: Integer; -begin - i := 0; - while (i < 128) do - begin - mustshiftopt[i] := #1; - mustshiftsafe[i] := #1; - invbase64[i] := -1; - Inc(i); - end { For }; - limit := Length(_Direct); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(direct[i])] := #0; - mustshiftsafe[Integer(direct[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Spaces); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(spaces[i])] := #0; - mustshiftsafe[Integer(spaces[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Optional); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(optional[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Base64); - i := 0; - while (i < limit) do - begin - invbase64[Integer(base64[i])] := i; - Inc(i); - end { For }; - needtables := False; -end; { tabinit } - -function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer; -begin - BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits); - bufferbits := bufferbits + n; - Result := bufferbits; -end; { WRITE_N_BITS } - -function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2; -var - buffertemp: Cardinal; -begin - buffertemp := BITbuffer shr (32 - n); - BITbuffer := BITbuffer shl n; - bufferbits := bufferbits - n; - Result := UCS2(buffertemp); -end; { READ_N_BITS } - -function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar; - var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean; - verbose: Boolean): Integer; -var - r: UCS2; - target: PAnsiChar; - source: PWideChar; - BITbuffer: Cardinal; - bufferbits: Integer; - shifted: Boolean; - needshift: Boolean; - done: Boolean; - mustshift: PAnsiChar; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - source := sourceStart; - target := targetStart; - r := 0; - if needtables then - tabinit; - if optional then - mustshift := @mustshiftopt[0] - else - mustshift := @mustshiftsafe[0]; - repeat - done := source >= sourceEnd; - if not Done then - begin - r := Word(source^); - Inc(Source); - end { If }; - needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0)); - if needshift and (not shifted) then - begin - if (Target >= TargetEnd) then - begin - Result := 2; - break; - end { If }; - target^ := '+'; - Inc(target); - { Special case handling of the SHIFT_IN character } - if (r = UCS2('+')) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end; - target^ := '-'; - Inc(target); - end - else - shifted := True; - end { If }; - if shifted then - begin - { Either write the character to the bit buffer, or pad } - { the bit buffer out to a full base64 character. } - { } - if needshift then - WRITE_N_BITS(r, 16, BITbuffer, bufferbits) - else - WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer, - bufferbits); - { Flush out as many full base64 characters as possible } - { from the bit buffer. } - { } - while (target < targetEnd) and (bufferbits >= 6) do - begin - Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)]; - Inc(Target); - end { While }; - if (bufferbits >= 6) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - end { If }; - if (not needshift) then - begin - { Write the explicit shift out character if } - { 1) The caller has requested we always do it, or } - { 2) The directly encoded character is in the } - { base64 set, or } - { 3) The directly encoded character is SHIFT_OUT. } - { } - if verbose or ((not done) and ((invbase64[r] >= 0) or (r = - Integer('-')))) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end { If }; - Target^ := '-'; - Inc(Target); - end { If }; - shifted := False; - end { If }; - { The character can be directly encoded as ASCII. } - end { If }; - if (not needshift) and (not done) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := AnsiChar(r); - Inc(Target); - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUCS2toUTF7 } - -function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar; - var targetStart: PWideChar; targetEnd: PWideChar): Integer; -var - target: PWideChar { Register }; - source: PAnsiChar { Register }; - BITbuffer: Cardinal { & "Address Of" Used }; - bufferbits: Integer { & "Address Of" Used }; - shifted: Boolean { Used In Boolean Context }; - first: Boolean { Used In Boolean Context }; - wroteone: Boolean; - base64EOF: Boolean; - base64value: Integer; - done: Boolean; - c: UCS2; - prevc: UCS2; - junk: UCS2 { Used In Boolean Context }; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - first := False; - wroteone := False; - source := sourceStart; - target := targetStart; - c := 0; - if needtables then - tabinit; - repeat - { read an ASCII character c } - done := Source >= SourceEnd; - if (not done) then - begin - c := Word(Source^); - Inc(Source); - end { If }; - if shifted then - begin - { We're done with a base64 string if we hit EOF, it's not a valid } - { ASCII character, or it's not in the base64 set. } - { } - base64value := invbase64[c]; - base64EOF := (done or (c > $7F)) or (base64value < 0); - if base64EOF then - begin - shifted := False; - { If the character causing us to drop out was SHIFT_IN or } - { SHIFT_OUT, it may be a special escape for SHIFT_IN. The } - { test for SHIFT_IN is not necessary, but allows an alternate } - { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This } - { only works for some values of SHIFT_IN. } - { } - if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then - begin - { get another character c } - prevc := c; - Done := Source >= SourceEnd; - if (not Done) then - begin - c := Word(Source^); - Inc(Source); - { If no base64 characters were encountered, and the } - { character terminating the shift sequence was } - { SHIFT_OUT, then it's a special escape for SHIFT_IN. } - { } - end; - if first and (prevc = Integer('-')) then - begin - { write SHIFT_IN unicode } - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar('+'); - Inc(Target); - end - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - ; - end { If } - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - end { If } - else - begin - { Add another 6 bits of base64 to the bit buffer. } - WRITE_N_BITS(base64value, 6, BITbuffer, - bufferbits); - first := False; - end { Else }; - { Extract as many full 16 bit characters as possible from the } - { bit buffer. } - { } - while (bufferbits >= 16) and (target < targetEnd) do - begin - { write a unicode } - Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits)); - Inc(Target); - wroteone := True; - end { While }; - if (bufferbits >= 16) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end; - end { If }; - if (base64EOF) then - begin - junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits); - if (junk <> 0) then - begin - Result := 1; - end { If }; - end { If }; - end { If }; - if (not shifted) and (not done) then - begin - if (c = Integer('+')) then - begin - shifted := True; - first := True; - wroteone := False; - end { If } - else - begin - { It must be a directly encoded character. } - if (c > $7F) then - begin - Result := 1; - end { If }; - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar(c); - Inc(Target); - end { Else }; - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUTF7toUCS2 } - - {*****************************************************************************} - { Thanks to Francisco Leong for providing the Pascal conversion of } - { ConvertUTF7.c (by David B. Goldsmith) } - {*****************************************************************************} - -resourcestring - SBufferOverflow = 'Buffer overflow'; - SInvalidUTF7 = 'Invalid UTF7'; - -function WideStringToUTF7(const W: WideString): AnsiString; -var - SourceStart, SourceEnd: PWideChar; - TargetStart, TargetEnd: PAnsiChar; -begin - if W = '' then - Result := '' - else - begin - SetLength(Result, Length(W) * 7); // Assume worst case - SourceStart := PWideChar(@W[1]); - SourceEnd := PWideChar(@W[Length(W)]) + 1; - TargetStart := PAnsiChar(@Result[1]); - TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1; - if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart, - TargetEnd, True, False) <> 0 - then - raise ETntInternalError.Create(SBufferOverflow); - SetLength(Result, TargetStart - PAnsiChar(@Result[1])); - end; -end; - -function UTF7ToWideString(const S: AnsiString): WideString; -var - SourceStart, SourceEnd: PAnsiChar; - TargetStart, TargetEnd: PWideChar; -begin - if (S = '') then - Result := '' - else - begin - SetLength(Result, Length(S)); // Assume Worst case - SourceStart := PAnsiChar(@S[1]); - SourceEnd := PAnsiChar(@S[Length(S)]) + 1; - TargetStart := PWideChar(@Result[1]); - TargetEnd := PWideChar(@Result[Length(Result)]) + 1; - case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart, - TargetEnd) of - 1: raise ETntGeneralError.Create(SInvalidUTF7); - 2: raise ETntInternalError.Create(SBufferOverflow); - end; - SetLength(Result, TargetStart - PWideChar(@Result[1])); - end; -end; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(S); - OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); - SetLength(Result, OutputLength); - MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); - end; -end; - -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(WS); - OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); - SetLength(Result, OutputLength); - WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); - end; -end; - -function UCS2ToWideString(const Value: AnsiString): WideString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar)) -end; - -function WideStringToUCS2(const Value: WideString): AnsiString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar)) -end; - -{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. } -function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -var - C: TCharsetInfo; -begin - Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET)); - Result := C.ciACP -end; - -function LCIDToCodePage(ALcid: LCID): Cardinal; -var - Buf: array[0..6] of AnsiChar; -begin - GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6); - Result := StrToIntDef(Buf, GetACP); -end; - -function KeyboardCodePage: Cardinal; -begin - Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF); -end; - -function KeyUnicode(CharCode: Word): WideChar; -var - AChar: AnsiChar; -begin - // converts the given character (as it comes with a WM_CHAR message) into its - // corresponding Unicode character depending on the active keyboard layout - if CharCode <= Word(High(AnsiChar)) then begin - AChar := AnsiChar(CharCode); - MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1); - end else - Result := WideChar(CharCode); -end; - -procedure StrSwapByteOrder(Str: PWideChar); -var - P: PWord; -begin - P := PWord(Str); - While (P^ <> 0) do begin - P^ := MakeWord(HiByte(P^), LoByte(P^)); - Inc(P); - end; -end; - -//-------------------------------------------------------------------- -// LoadResString() -// -// This system function is used to retrieve a resourcestring and -// return the result as an AnsiString. If we believe that the result -// is only a temporary value, and that it will be immediately -// assigned to a WideString or a Variant, then we will save the -// Unicode result as well as a reference to the original Ansi string. -// WStrFromPCharLen() or VarFromLStr() will return this saved -// Unicode string if it appears to receive the most recent result -// of LoadResString. -//-------------------------------------------------------------------- - - - //=========================================================================================== - // - // function CodeMatchesPatternForUnicode(...); - // - // GIVEN: SomeWideString := SSomeResString; { WideString := resourcestring } - // - // Delphi will compile this statement into the following: - // ------------------------------------------------- - // TempAnsiString := LoadResString(@SSomeResString); - // LINE 1: lea edx,[SomeTempAnsiString] - // LINE 2: mov eax,[@SomeResString] - // LINE 3: call LoadResString - // - // WStrFromLStr(SomeWideString, TempAnsiString); { SomeWideString := TempAnsiString } - // LINE 4: mov edx,[SomeTempAnsiString] - // LINE 5: mov/lea eax [@SomeWideString] - // LINE 6: call @WStrFromLStr - // ------------------------------------------------- - // - // The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is - // reversed when assigning a non-temporary AnsiString to a WideString. - // - // This code, for example, results in LINE 4 and LINE 5 being swapped. - // - // SomeAnsiString := SSomeResString; - // SomeWideString := SomeAnsiString; - // - // Since we know the "signature" used by the compiler, we can detect this pattern. - // If we believe it is only temporary, we can save the Unicode results for later - // retrieval from WStrFromLStr. - // - // One final note: When assigning a resourcestring to a Variant, the same patterns exist. - //=========================================================================================== - -function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean; -const - SIZEOF_OPCODE = 1 {byte}; - MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits } - MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits } - LEA_OPCODE = AnsiChar($8D); { operand size can be 16 or 40 bits } - CALL_OPCODE = AnsiChar($E8); { assumed operand size is 32 bits } - BREAK_OPCODE = AnsiChar($CC); {in a breakpoint} -var - PLine1: PAnsiChar; - PLine2: PAnsiChar; - PLine3: PAnsiChar; - DataSize: Integer; // bytes in first LEA operand -begin - Result := False; - - PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4; - PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4; - - // figure PLine1 and operand size - DataSize := 2; { try 16 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then - begin - DataSize := 5; { try 40 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - end; - if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then - begin - if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then - begin - // After this check, it seems to match the WideString <- (temp) AnsiString pattern - Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.) - end; - end; -end; - -threadvar - PLastResString: PAnsiChar; - LastResStringValue: AnsiString; - LastWideResString: WideString; - -procedure FreeTntSystemThreadVars; -begin - LastResStringValue := ''; - LastWideResString := ''; -end; - -procedure Custom_System_EndThread(ExitCode: Integer); -begin - FreeTntSystemThreadVars; - {$IFDEF COMPILER_10_UP} - if Assigned(SystemThreadEndProc) then - SystemThreadEndProc(ExitCode); - {$ENDIF} - ExitThread(ExitCode); -end; - -function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString; -var - ReturnAddr: Pointer; -begin - // get return address - asm - PUSH ECX - MOV ECX, [EBP + 4] - MOV ReturnAddr, ECX - POP ECX - end; - // check calling code pattern - if CodeMatchesPatternForUnicode(ReturnAddr) then begin - // result will probably be assigned to an intermediate AnsiString - // on its way to either a WideString or Variant. - LastWideResString := WideLoadResString(ResStringRec); - Result := LastWideResString; - LastResStringValue := Result; - if Result = '' then - PLastResString := nil - else - PLastResString := PAnsiChar(Result); - end else begin - // result will probably be assigned to an actual AnsiString variable. - PLastResString := nil; - Result := WideLoadResString(ResStringRec); - end; -end; - -//-------------------------------------------------------------------- -// WStrFromPCharLen() -// -// This system function is used to assign an AnsiString to a WideString. -// It has been modified to assign Unicode results from LoadResString. -// Another purpose of this function is to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..2047] of WideChar; - Local_PLastResString: Pointer; -begin - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = Source) - and (System.Length(LastResStringValue) = Length) - and (LastResStringValue = Source) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - Dest := LastWideResString; - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < High(Buffer) then - begin - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer, - High(Buffer)); - if DestLen > 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar)); - Exit; - end; - end; - DestLen := (Length + 1); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), - DestLen); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// LStrFromPWCharLen() -// -// This system function is used to assign an WideString to an AnsiString. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..4095] of AnsiChar; -begin - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < (High(Buffer) div sizeof(WideChar)) then - begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, - Length, Buffer, High(Buffer), - nil, nil); - if DestLen >= 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen); - Exit; - end; - end; - - DestLen := (Length + 1) * sizeof(WideChar); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen, - nil, nil); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); -end; - -//-------------------------------------------------------------------- -// WStrToString() -// -// This system function is used to assign an WideString to an short string. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); -var - SourceLen, DestLen: Integer; - Buffer: array[0..511] of AnsiChar; -begin - if MaxLen > 255 then MaxLen := 255; - SourceLen := Length(Source); - if SourceLen >= MaxLen then SourceLen := MaxLen; - if SourceLen = 0 then - DestLen := 0 - else begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen, - Buffer, SizeOf(Buffer), nil, nil); - if DestLen > MaxLen then DestLen := MaxLen; - end; - Dest^[0] := Chr(DestLen); - if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// VarFromLStr() -// -// This system function is used to assign an AnsiString to a Variant. -// It has been modified to assign Unicode results from LoadResString. -//-------------------------------------------------------------------- - -procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString); -const - varDeepData = $BFE8; -var - Local_PLastResString: Pointer; -begin - if (V.VType and varDeepData) <> 0 then - VarClear(PVariant(@V)^); - - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = PAnsiChar(Value)) - and (LastResStringValue = Value) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - V.VOleStr := nil; - V.VType := varOleStr; - WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt); - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - V.VString := nil; - V.VType := varString; - AnsiString(V.VString) := Value; - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// WStrCat3() A := B + C; -// -// This system function is used to concatenate two strings into one result. -// This function is added because A := '' + '' doesn't necessarily result in A = ''; -//-------------------------------------------------------------------- - -procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString); - - function NewWideString(CharLength: Longint): Pointer; - var - _NewWideString: function(CharLength: Longint): Pointer; - begin - asm - PUSH ECX - MOV ECX, offset System.@NewWideString; - MOV _NewWideString, ECX - POP ECX - end; - Result := _NewWideString(CharLength); - end; - - procedure WStrSet(var S: WideString; P: PWideChar); - var - Temp: Pointer; - begin - Temp := Pointer(InterlockedExchange(Integer(S), Integer(P))); - if Temp <> nil then - WideString(Temp) := ''; - end; - -var - Source1Len, Source2Len: Integer; - NewStr: PWideChar; -begin - Source1Len := Length(Source1); - Source2Len := Length(Source2); - if (Source1Len <> 0) or (Source2Len <> 0) then - begin - NewStr := NewWideString(Source1Len + Source2Len); - Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); - Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); - WStrSet(Dest, NewStr); - end else - Dest := ''; -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// System proc replacements -//-------------------------------------------------------------------- - -type - POverwrittenData = ^TOverwrittenData; - TOverwrittenData = record - Location: Pointer; - OldCode: array[0..6] of Byte; - end; - -procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil); -{ OverwriteProcedure originally from Igor Siticov } -{ Modified by Jacques Garcia Vazquez } -var - x: PAnsiChar; - y: integer; - ov2, ov: cardinal; - p: pointer; -begin - if Assigned(Data) and (Data.Location <> nil) then - exit; { procedure already overwritten } - - // need six bytes in place of 5 - x := PAnsiChar(OldProcedure); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - - // if a jump is present then a redirect is found - // $FF25 = jmp dword ptr [xxx] - // This redirect is normally present in bpl files, but not in exe files - p := OldProcedure; - - if Word(p^) = $25FF then - begin - Inc(Integer(p), 2); // skip the jump - // get the jump address p^ and dereference it p^^ - p := Pointer(Pointer(p^)^); - - // release the memory - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; - - // re protect the correct one - x := PAnsiChar(p); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - end; - - if Assigned(Data) then - begin - Move(x^, Data.OldCode, 6); - { Assign Location last so that Location <> nil only if OldCode is properly initialized. } - Data.Location := x; - end; - - x[0] := AnsiChar($E9); - y := integer(NewProcedure) - integer(p) - 5; - x[1] := AnsiChar(y and 255); - x[2] := AnsiChar((y shr 8) and 255); - x[3] := AnsiChar((y shr 16) and 255); - x[4] := AnsiChar((y shr 24) and 255); - - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; -end; - -procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData); -var - ov, ov2: Cardinal; -begin - if Data.Location <> nil then begin - if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - Move(Data.OldCode, Data.Location^, 6); - if not VirtualProtect(Data.Location, 6, ov, @ov2) then - RaiseLastOSError; - end; -end; - -function Addr_System_EndThread: Pointer; -begin - Result := @System.EndThread; -end; - -function Addr_System_LoadResString: Pointer; -begin - Result := @System.LoadResString{TNT-ALLOW LoadResString}; -end; - -function Addr_System_WStrFromPCharLen: Pointer; -asm - mov eax, offset System.@WStrFromPCharLen; -end; - -{$IFNDEF COMPILER_9_UP} -function Addr_System_LStrFromPWCharLen: Pointer; -asm - mov eax, offset System.@LStrFromPWCharLen; -end; - -function Addr_System_WStrToString: Pointer; -asm - mov eax, offset System.@WStrToString; -end; -{$ENDIF} - -function Addr_System_VarFromLStr: Pointer; -asm - mov eax, offset System.@VarFromLStr; -end; - -function Addr_System_WStrCat3: Pointer; -asm - mov eax, offset System.@WStrCat3; -end; - -var - System_EndThread_Code, - System_LoadResString_Code, - System_WStrFromPCharLen_Code, - {$IFNDEF COMPILER_9_UP} - System_LStrFromPWCharLen_Code, - System_WStrToString_Code, - {$ENDIF} - System_VarFromLStr_Code - {$IFNDEF COMPILER_9_UP} - , - System_WStrCat3_Code, - SysUtils_WideFmtStr_Code - {$ENDIF} - : TOverwrittenData; - -procedure InstallEndThreadOverride; -begin - OverwriteProcedure(Addr_System_EndThread, @Custom_System_EndThread, @System_EndThread_Code); -end; - -procedure InstallStringConversionOverrides; -begin - OverwriteProcedure(Addr_System_WStrFromPCharLen, @Custom_System_WStrFromPCharLen, @System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code); - OverwriteProcedure(Addr_System_WStrToString, @Custom_System_WStrToString, @System_WStrToString_Code); - {$ENDIF} -end; - -procedure InstallWideResourceStrings; -begin - OverwriteProcedure(Addr_System_LoadResString, @Custom_System_LoadResString, @System_LoadResString_Code); - OverwriteProcedure(Addr_System_VarFromLStr, @Custom_System_VarFromLStr, @System_VarFromLStr_Code); -end; - -{$IFNDEF COMPILER_9_UP} -procedure InstallWideStringConcatenationFix; -begin - OverwriteProcedure(Addr_System_WStrCat3, @Custom_System_WStrCat3, @System_WStrCat3_Code); -end; - -procedure InstallWideFormatFixes; -begin - OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code); -end; -{$ENDIF} - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); -begin - InstallEndThreadOverride; - if tsWideResourceStrings in Updates then begin - InstallStringConversionOverrides; - InstallWideResourceStrings; - end; - {$IFNDEF COMPILER_9_UP} - if tsFixImplicitCodePage in Updates then begin - InstallStringConversionOverrides; - { CP_ACP is the code page used by the non-Unicode Windows API. } - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - end; - if tsFixWideStrConcat in Updates then begin - InstallWideStringConcatenationFix; - end; - if tsFixWideFormat in Updates then begin - InstallWideFormatFixes; - end; - {$ENDIF} -end; - -{$IFNDEF COMPILER_9_UP} -var - StartupDefaultUserCodePage: Cardinal; -{$ENDIF} - -procedure UninstallSystemOverrides; -begin - RestoreProcedure(Addr_System_EndThread, System_EndThread_Code); - // String Conversion - RestoreProcedure(Addr_System_WStrFromPCharLen, System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code); - RestoreProcedure(Addr_System_WStrToString, System_WStrToString_Code); - GDefaultSystemCodePage := StartupDefaultUserCodePage; - {$ENDIF} - // Wide resourcestring - RestoreProcedure(Addr_System_LoadResString, System_LoadResString_Code); - RestoreProcedure(Addr_System_VarFromLStr, System_VarFromLStr_Code); - {$IFNDEF COMPILER_9_UP} - // WideString concat fix - RestoreProcedure(Addr_System_WStrCat3, System_WStrCat3_Code); - // WideFormat fixes - RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code); - {$ENDIF} -end; - -initialization - {$IFDEF COMPILER_9_UP} - GDefaultSystemCodePage := GetACP; - {$ELSE} - {$IFDEF COMPILER_7_UP} - if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then - GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/... - else - GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME - {$ELSE} - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - {$ENDIF} - {$ENDIF} - {$IFNDEF COMPILER_9_UP} - StartupDefaultUserCodePage := DefaultSystemCodePage; - {$ENDIF} - IsDebugging := DebugHook > 0; - -finalization - UninstallSystemOverrides; - FreeTntSystemThreadVars; { Make MemorySleuth happy. } - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas deleted file mode 100644 index 02a64bbc3e..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas +++ /dev/null @@ -1,451 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWideStrUtils; - -{$INCLUDE TntCompilers.inc} - -interface - -{ Wide string manipulation functions } - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -function WStrBufSize(const Str: PWideChar): Cardinal; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -procedure WStrDispose(Str: PWideChar); -{$ENDIF} -//--------------------------------------------------------------------------------------------- -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -function WStrEnd(Str: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 -function WStrComp(Str1, Str2: PWideChar): Integer; -function WStrPos(Str, SubStr: PWideChar): PWideChar; -{$ENDIF} -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; - -{ ------------ introduced --------------- } -function WStrECopy(Dest, Source: PWideChar): PWideChar; -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrIComp(Str1, Str2: PWideChar): Integer; -function WStrLower(Str: PWideChar): PWideChar; -function WStrUpper(Str: PWideChar): PWideChar; -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPas(const Str: PWideChar): WideString; - -{ SysUtils.pas } //------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -{$ENDIF} - -implementation - -uses - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -begin - Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); - GetMem(Result, Size); - PCardinal(Result)^ := Size; - Inc(PAnsiChar(Result), SizeOf(Cardinal)); -end; - -function WStrBufSize(const Str: PWideChar): Cardinal; -var - P: PWideChar; -begin - P := Str; - Dec(PAnsiChar(P), SizeOf(Cardinal)); - Result := PCardinal(P)^ - SizeOf(Cardinal); - Result := Result div SizeOf(WideChar); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -var - Length: Integer; -begin - Result := Dest; - Length := Count * SizeOf(WideChar); - Move(Source^, Dest^, Length); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -var - Size: Cardinal; -begin - if Str = nil then Result := nil else - begin - Size := WStrLen(Str) + 1; - Result := WStrMove(WStrAlloc(Size), Str, Size); - end; -end; - -procedure WStrDispose(Str: PWideChar); -begin - if Str <> nil then - begin - Dec(PAnsiChar(Str), SizeOf(Cardinal)); - FreeMem(Str, Cardinal(Pointer(Str)^)); - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -begin - Result := WStrEnd(Str) - Str; -end; - -function WStrEnd(Str: PWideChar): PWideChar; -begin - // returns a pointer to the end of a null terminated string - Result := Str; - While Result^ <> #0 do - Inc(Result); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -begin - Result := Dest; - WStrCopy(WStrEnd(Dest), Source); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrLCopy(Dest, Source, MaxInt); -end; - -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -var - Count: Cardinal; -begin - // copies a specified maximum number of characters from Source to Dest - Result := Dest; - Count := 0; - While (Count < MaxLen) and (Source^ <> #0) do begin - Dest^ := Source^; - Inc(Source); - Inc(Dest); - Inc(Count); - end; - Dest^ := #0; -end; - -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); -end; - -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -begin - Result := Str; - while Result^ <> Chr do - begin - if Result^ = #0 then - begin - Result := nil; - Exit; - end; - Inc(Result); - end; -end; - -function WStrComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLComp(Str1, Str2, MaxInt); -end; - -function WStrPos(Str, SubStr: PWideChar): PWideChar; -var - PSave: PWideChar; - P: PWideChar; - PSub: PWideChar; -begin - // returns a pointer to the first occurance of SubStr in Str - Result := nil; - if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin - P := Str; - While P^ <> #0 do begin - if P^ = SubStr^ then begin - // investigate possibility here - PSave := P; - PSub := SubStr; - While (P^ = PSub^) do begin - Inc(P); - Inc(PSub); - if (PSub^ = #0) then begin - Result := PSave; - exit; // found a match - end; - if (P^ = #0) then - exit; // no match, hit end of string - end; - P := PSave; - end; - Inc(P); - end; - end; -end; -{$ENDIF} - -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -begin - Result := WStrComp(Str1, Str2); -end; - -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; -begin - Result := WStrPos(Str, SubStr); -end; - -//------------------------------------------------------------------------------ - -function WStrECopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrEnd(WStrCopy(Dest, Source)); -end; - -function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; -var - Len1, Len2: Integer; -begin - if MaxLen = Cardinal(MaxInt) then begin - Len1 := -1; - Len2 := -1; - end else begin - Len1 := Min(WStrLen(Str1), MaxLen); - Len2 := Min(WStrLen(Str2), MaxLen); - end; - Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; -end; - -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, 0); -end; - -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); -end; - -function WStrIComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLIComp(Str1, Str2, MaxInt); -end; - -function WStrLower(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharLowerBuffW(Str, WStrLen(Str)) -end; - -function WStrUpper(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharUpperBuffW(Str, WStrLen(Str)) -end; - -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -var - MostRecentFound: PWideChar; -begin - if Chr = #0 then - Result := WStrEnd(Str) - else - begin - Result := nil; - MostRecentFound := Str; - while True do - begin - while MostRecentFound^ <> Chr do - begin - if MostRecentFound^ = #0 then - Exit; - Inc(MostRecentFound); - end; - Result := MostRecentFound; - Inc(MostRecentFound); - end; - end; -end; - -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -begin - Result := Dest; - WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); -end; - -function WStrPas(const Str: PWideChar): WideString; -begin - Result := Str; -end; - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil - else - Result := @S[Length(S)]; -end; - -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -var - P, Src, - Dest: PWideChar; - AddCount: Integer; -begin - AddCount := 0; - P := WStrScan(PWideChar(S), Quote); - while (P <> nil) do - begin - Inc(P); - Inc(AddCount); - P := WStrScan(P, Quote); - end; - - if AddCount = 0 then - Result := Quote + S + Quote - else - begin - SetLength(Result, Length(S) + AddCount + 2); - Dest := PWideChar(Result); - Dest^ := Quote; - Inc(Dest); - Src := PWideChar(S); - P := WStrScan(Src, Quote); - repeat - Inc(P); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - Inc(Dest); - Src := P; - P := WStrScan(Src, Quote); - until P = nil; - P := WStrEnd(Src); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -var - P, Dest: PWideChar; - DropCount: Integer; -begin - Result := ''; - if (Src = nil) or (Src^ <> Quote) then Exit; - Inc(Src); - DropCount := 1; - P := Src; - Src := WStrScan(Src, Quote); - while Src <> nil do // count adjacent pairs of quote chars - begin - Inc(Src); - if Src^ <> Quote then Break; - Inc(Src); - Inc(DropCount); - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - if ((Src - P) <= 1) then Exit; - if DropCount = 1 then - SetString(Result, P, Src - P - 1) - else - begin - SetLength(Result, Src - P - DropCount); - Dest := PWideChar(Result); - Src := WStrScan(P, Quote); - while Src <> nil do - begin - Inc(Src); - if Src^ <> Quote then Break; - Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); - Inc(Dest, Src - P); - Inc(Src); - P := Src; - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -var - LText : PWideChar; -begin - LText := PWideChar(S); - Result := WideExtractQuotedStr(LText, AQuote); - if Result = '' then - Result := S; -end; -{$ENDIF} - - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas deleted file mode 100644 index dfe3755403..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas +++ /dev/null @@ -1,831 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWideStrings; - -{$INCLUDE TntCompilers.inc} - -interface - -{$IFDEF COMPILER_10_UP} - {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} -{$ENDIF} - -uses - Classes; - -{******************************************************************************} -{ } -{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } -{ Unfortunately, it was not ready for prime time. } -{ Setting CommaText is not consistent, and it relies on CharNextW } -{ Which is only available on Windows NT+. } -{ } -{******************************************************************************} - -type - TWideStrings = class; - -{ IWideStringsAdapter interface } -{ Maintains link between TWideStrings and IWideStrings implementations } - - IWideStringsAdapter = interface - ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] - procedure ReferenceStrings(S: TWideStrings); - procedure ReleaseStrings; - end; - - TWideStringsEnumerator = class - private - FIndex: Integer; - FStrings: TWideStrings; - public - constructor Create(AStrings: TWideStrings); - function GetCurrent: WideString; - function MoveNext: Boolean; - property Current: WideString read GetCurrent; - end; - -{ TWideStrings class } - - TWideStrings = class(TPersistent) - private - FDefined: TStringsDefined; - FDelimiter: WideChar; - FQuoteChar: WideChar; - {$IFDEF COMPILER_7_UP} - FNameValueSeparator: WideChar; - {$ENDIF} - FUpdateCount: Integer; - FAdapter: IWideStringsAdapter; - function GetCommaText: WideString; - function GetDelimitedText: WideString; - function GetName(Index: Integer): WideString; - function GetValue(const Name: WideString): WideString; - procedure ReadData(Reader: TReader); - procedure SetCommaText(const Value: WideString); - procedure SetDelimitedText(const Value: WideString); - procedure SetStringsAdapter(const Value: IWideStringsAdapter); - procedure SetValue(const Name, Value: WideString); - procedure WriteData(Writer: TWriter); - function GetDelimiter: WideChar; - procedure SetDelimiter(const Value: WideChar); - function GetQuoteChar: WideChar; - procedure SetQuoteChar(const Value: WideChar); - function GetNameValueSeparator: WideChar; - {$IFDEF COMPILER_7_UP} - procedure SetNameValueSeparator(const Value: WideChar); - {$ENDIF} - function GetValueFromIndex(Index: Integer): WideString; - procedure SetValueFromIndex(Index: Integer; const Value: WideString); - protected - procedure AssignTo(Dest: TPersistent); override; - procedure DefineProperties(Filer: TFiler); override; - procedure Error(const Msg: WideString; Data: Integer); overload; - procedure Error(Msg: PResStringRec; Data: Integer); overload; - function ExtractName(const S: WideString): WideString; - function Get(Index: Integer): WideString; virtual; abstract; - function GetCapacity: Integer; virtual; - function GetCount: Integer; virtual; abstract; - function GetObject(Index: Integer): TObject; virtual; - function GetTextStr: WideString; virtual; - procedure Put(Index: Integer; const S: WideString); virtual; - procedure PutObject(Index: Integer; AObject: TObject); virtual; - procedure SetCapacity(NewCapacity: Integer); virtual; - procedure SetTextStr(const Value: WideString); virtual; - procedure SetUpdateState(Updating: Boolean); virtual; - property UpdateCount: Integer read FUpdateCount; - function CompareStrings(const S1, S2: WideString): Integer; virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; virtual; - function AddObject(const S: WideString; AObject: TObject): Integer; virtual; - procedure Append(const S: WideString); - procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; - procedure AddStrings(Strings: TWideStrings); overload; virtual; - procedure Assign(Source: TPersistent); override; - procedure BeginUpdate; - procedure Clear; virtual; abstract; - procedure Delete(Index: Integer); virtual; abstract; - procedure EndUpdate; - function Equals(Strings: TWideStrings): Boolean; - procedure Exchange(Index1, Index2: Integer); virtual; - function GetEnumerator: TWideStringsEnumerator; - function GetTextW: PWideChar; virtual; - function IndexOf(const S: WideString): Integer; virtual; - function IndexOfName(const Name: WideString): Integer; virtual; - function IndexOfObject(AObject: TObject): Integer; virtual; - procedure Insert(Index: Integer; const S: WideString); virtual; abstract; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); virtual; - procedure LoadFromFile(const FileName: WideString); virtual; - procedure LoadFromStream(Stream: TStream); virtual; - procedure Move(CurIndex, NewIndex: Integer); virtual; - procedure SaveToFile(const FileName: WideString); virtual; - procedure SaveToStream(Stream: TStream); virtual; - procedure SetTextW(const Text: PWideChar); virtual; - property Capacity: Integer read GetCapacity write SetCapacity; - property CommaText: WideString read GetCommaText write SetCommaText; - property Count: Integer read GetCount; - property Delimiter: WideChar read GetDelimiter write SetDelimiter; - property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; - property Names[Index: Integer]: WideString read GetName; - property Objects[Index: Integer]: TObject read GetObject write PutObject; - property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; - property Values[const Name: WideString]: WideString read GetValue write SetValue; - property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF COMPILER_7_UP} write SetNameValueSeparator {$ENDIF}; - property Strings[Index: Integer]: WideString read Get write Put; default; - property Text: WideString read GetTextStr write SetTextStr; - property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; - end; - - PWideStringItem = ^TWideStringItem; - TWideStringItem = record - FString: WideString; - FObject: TObject; - end; - - PWideStringItemList = ^TWideStringItemList; - TWideStringItemList = array[0..MaxListSize] of TWideStringItem; - -implementation - -uses - Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} - TntSysUtils, TntClasses; - -{ TWideStringsEnumerator } - -constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); -begin - inherited Create; - FIndex := -1; - FStrings := AStrings; -end; - -function TWideStringsEnumerator.GetCurrent: WideString; -begin - Result := FStrings[FIndex]; -end; - -function TWideStringsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FStrings.Count - 1; - if Result then - Inc(FIndex); -end; - -{ TWideStrings } - -destructor TWideStrings.Destroy; -begin - StringsAdapter := nil; - inherited; -end; - -function TWideStrings.Add(const S: WideString): Integer; -begin - Result := GetCount; - Insert(Result, S); -end; - -function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; -begin - Result := Add(S); - PutObject(Result, AObject); -end; - -procedure TWideStrings.Append(const S: WideString); -begin - Add(S); -end; - -procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.AddStrings(Strings: TWideStrings); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Assign(Source: TPersistent); -begin - if Source is TWideStrings then - begin - BeginUpdate; - try - Clear; - FDefined := TWideStrings(Source).FDefined; - {$IFDEF COMPILER_7_UP} - FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; - {$ENDIF} - FQuoteChar := TWideStrings(Source).FQuoteChar; - FDelimiter := TWideStrings(Source).FDelimiter; - AddStrings(TWideStrings(Source)); - finally - EndUpdate; - end; - end - else if Source is TStrings{TNT-ALLOW TStrings} then - begin - BeginUpdate; - try - Clear; - {$IFDEF COMPILER_7_UP} - FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); - {$ENDIF} - FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); - FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); - AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); - finally - EndUpdate; - end; - end - else - inherited Assign(Source); -end; - -procedure TWideStrings.AssignTo(Dest: TPersistent); -var - I: Integer; -begin - if Dest is TWideStrings then Dest.Assign(Self) - else if Dest is TStrings{TNT-ALLOW TStrings} then - begin - TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; - try - TStrings{TNT-ALLOW TStrings}(Dest).Clear; - {$IFDEF COMPILER_7_UP} - TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); - {$ENDIF} - TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); - TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); - for I := 0 to Count - 1 do - TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); - finally - TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; - end; - end - else - inherited AssignTo(Dest); -end; - -procedure TWideStrings.BeginUpdate; -begin - if FUpdateCount = 0 then SetUpdateState(True); - Inc(FUpdateCount); -end; - -procedure TWideStrings.DefineProperties(Filer: TFiler); - - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - begin - Result := True; - if Filer.Ancestor is TWideStrings then - Result := not Equals(TWideStrings(Filer.Ancestor)) - end - else Result := Count > 0; - end; - -begin - Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); -end; - -procedure TWideStrings.EndUpdate; -begin - Dec(FUpdateCount); - if FUpdateCount = 0 then SetUpdateState(False); -end; - -function TWideStrings.Equals(Strings: TWideStrings): Boolean; -var - I, Count: Integer; -begin - Result := False; - Count := GetCount; - if Count <> Strings.GetCount then Exit; - for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; - Result := True; -end; - -procedure TWideStrings.Error(const Msg: WideString; Data: Integer); - - function ReturnAddr: Pointer; - asm - MOV EAX,[EBP+4] - end; - -begin - raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; -end; - -procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); -begin - Error(WideLoadResString(Msg), Data); -end; - -procedure TWideStrings.Exchange(Index1, Index2: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - BeginUpdate; - try - TempString := Strings[Index1]; - TempObject := Objects[Index1]; - Strings[Index1] := Strings[Index2]; - Objects[Index1] := Objects[Index2]; - Strings[Index2] := TempString; - Objects[Index2] := TempObject; - finally - EndUpdate; - end; -end; - -function TWideStrings.ExtractName(const S: WideString): WideString; -var - P: Integer; -begin - Result := S; - P := Pos(NameValueSeparator, Result); - if P <> 0 then - SetLength(Result, P-1) else - SetLength(Result, 0); -end; - -function TWideStrings.GetCapacity: Integer; -begin // descendents may optionally override/replace this default implementation - Result := Count; -end; - -function TWideStrings.GetCommaText: WideString; -var - LOldDefined: TStringsDefined; - LOldDelimiter: WideChar; - LOldQuoteChar: WideChar; -begin - LOldDefined := FDefined; - LOldDelimiter := FDelimiter; - LOldQuoteChar := FQuoteChar; - Delimiter := ','; - QuoteChar := '"'; - try - Result := GetDelimitedText; - finally - FDelimiter := LOldDelimiter; - FQuoteChar := LOldQuoteChar; - FDefined := LOldDefined; - end; -end; - -function TWideStrings.GetDelimitedText: WideString; -var - S: WideString; - P: PWideChar; - I, Count: Integer; -begin - Count := GetCount; - if (Count = 1) and (Get(0) = '') then - Result := WideString(QuoteChar) + QuoteChar - else - begin - Result := ''; - for I := 0 to Count - 1 do - begin - S := Get(I); - P := PWideChar(S); - while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do - Inc(P); - if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); - Result := Result + S + Delimiter; - end; - System.Delete(Result, Length(Result), 1); - end; -end; - -function TWideStrings.GetName(Index: Integer): WideString; -begin - Result := ExtractName(Get(Index)); -end; - -function TWideStrings.GetObject(Index: Integer): TObject; -begin - Result := nil; -end; - -function TWideStrings.GetEnumerator: TWideStringsEnumerator; -begin - Result := TWideStringsEnumerator.Create(Self); -end; - -function TWideStrings.GetTextW: PWideChar; -begin - Result := WStrNew(PWideChar(GetTextStr)); -end; - -function TWideStrings.GetTextStr: WideString; -var - I, L, Size, Count: Integer; - P: PWideChar; - S, LB: WideString; -begin - Count := GetCount; - Size := 0; - LB := sLineBreak; - for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); - SetString(Result, nil, Size); - P := Pointer(Result); - for I := 0 to Count - 1 do - begin - S := Get(I); - L := Length(S); - if L <> 0 then - begin - System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - L := Length(LB); - if L <> 0 then - begin - System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - end; -end; - -function TWideStrings.GetValue(const Name: WideString): WideString; -var - I: Integer; -begin - I := IndexOfName(Name); - if I >= 0 then - Result := Copy(Get(I), Length(Name) + 2, MaxInt) else - Result := ''; -end; - -function TWideStrings.IndexOf(const S: WideString): Integer; -begin - for Result := 0 to GetCount - 1 do - if CompareStrings(Get(Result), S) = 0 then Exit; - Result := -1; -end; - -function TWideStrings.IndexOfName(const Name: WideString): Integer; -var - P: Integer; - S: WideString; -begin - for Result := 0 to GetCount - 1 do - begin - S := Get(Result); - P := Pos(NameValueSeparator, S); - if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; - end; - Result := -1; -end; - -function TWideStrings.IndexOfObject(AObject: TObject): Integer; -begin - for Result := 0 to GetCount - 1 do - if GetObject(Result) = AObject then Exit; - Result := -1; -end; - -procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - Insert(Index, S); - PutObject(Index, AObject); -end; - -procedure TWideStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.LoadFromStream(Stream: TStream); -var - Size: Integer; - S: WideString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size div SizeOf(WideChar)); - Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); - SetTextStr(S); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Move(CurIndex, NewIndex: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - if CurIndex <> NewIndex then - begin - BeginUpdate; - try - TempString := Get(CurIndex); - TempObject := GetObject(CurIndex); - Delete(CurIndex); - InsertObject(NewIndex, TempString, TempObject); - finally - EndUpdate; - end; - end; -end; - -procedure TWideStrings.Put(Index: Integer; const S: WideString); -var - TempObject: TObject; -begin - TempObject := GetObject(Index); - Delete(Index); - InsertObject(Index, S, TempObject); -end; - -procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); -begin -end; - -procedure TWideStrings.ReadData(Reader: TReader); -begin - if Reader.NextValue in [vaString, vaLString] then - SetTextStr(Reader.ReadString) {JCL compatiblity} - else if Reader.NextValue = vaWString then - SetTextStr(Reader.ReadWideString) {JCL compatiblity} - else begin - BeginUpdate; - try - Clear; - Reader.ReadListBegin; - while not Reader.EndOfList do - if Reader.NextValue in [vaString, vaLString] then - Add(Reader.ReadString) {TStrings compatiblity} - else - Add(Reader.ReadWideString); - Reader.ReadListEnd; - finally - EndUpdate; - end; - end; -end; - -procedure TWideStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.SaveToStream(Stream: TStream); -var - SW: WideString; -begin - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TWideStrings.SetCapacity(NewCapacity: Integer); -begin - // do nothing - descendents may optionally implement this method -end; - -procedure TWideStrings.SetCommaText(const Value: WideString); -begin - Delimiter := ','; - QuoteChar := '"'; - SetDelimitedText(Value); -end; - -procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); -begin - if FAdapter <> nil then FAdapter.ReleaseStrings; - FAdapter := Value; - if FAdapter <> nil then FAdapter.ReferenceStrings(Self); -end; - -procedure TWideStrings.SetTextW(const Text: PWideChar); -begin - SetTextStr(Text); -end; - -procedure TWideStrings.SetTextStr(const Value: WideString); -var - P, Start: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := Pointer(Value); - if P <> nil then - while P^ <> #0 do - begin - Start := P; - while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do - Inc(P); - SetString(S, Start, P - Start); - Add(S); - if P^ = #13 then Inc(P); - if P^ = #10 then Inc(P); - if P^ = WideLineSeparator then Inc(P); - end; - finally - EndUpdate; - end; -end; - -procedure TWideStrings.SetUpdateState(Updating: Boolean); -begin -end; - -procedure TWideStrings.SetValue(const Name, Value: WideString); -var - I: Integer; -begin - I := IndexOfName(Name); - if Value <> '' then - begin - if I < 0 then I := Add(''); - Put(I, Name + NameValueSeparator + Value); - end else - begin - if I >= 0 then Delete(I); - end; -end; - -procedure TWideStrings.WriteData(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do begin - Writer.WriteWideString(Get(I)); - end; - Writer.WriteListEnd; -end; - -procedure TWideStrings.SetDelimitedText(const Value: WideString); -var - P, P1: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := PWideChar(Value); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - while P^ <> #0 do - begin - if P^ = QuoteChar then - S := WideExtractQuotedStr(P, QuoteChar) - else - begin - P1 := P; - while (P^ > ' ') and (P^ <> Delimiter) do - Inc(P); - SetString(S, P1, P - P1); - end; - Add(S); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - if P^ = Delimiter then - begin - P1 := P; - Inc(P1); - if P1^ = #0 then - Add(''); - repeat - Inc(P); - until not (P^ in [WideChar(#1)..WideChar(' ')]); - end; - end; - finally - EndUpdate; - end; -end; - -function TWideStrings.GetDelimiter: WideChar; -begin - if not (sdDelimiter in FDefined) then - Delimiter := ','; - Result := FDelimiter; -end; - -function TWideStrings.GetQuoteChar: WideChar; -begin - if not (sdQuoteChar in FDefined) then - QuoteChar := '"'; - Result := FQuoteChar; -end; - -procedure TWideStrings.SetDelimiter(const Value: WideChar); -begin - if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then - begin - Include(FDefined, sdDelimiter); - FDelimiter := Value; - end -end; - -procedure TWideStrings.SetQuoteChar(const Value: WideChar); -begin - if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then - begin - Include(FDefined, sdQuoteChar); - FQuoteChar := Value; - end -end; - -function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; -begin - Result := WideCompareText(S1, S2); -end; - -function TWideStrings.GetNameValueSeparator: WideChar; -begin - {$IFDEF COMPILER_7_UP} - if not (sdNameValueSeparator in FDefined) then - NameValueSeparator := '='; - Result := FNameValueSeparator; - {$ELSE} - Result := '='; - {$ENDIF} -end; - -{$IFDEF COMPILER_7_UP} -procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); -begin - if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then - begin - Include(FDefined, sdNameValueSeparator); - FNameValueSeparator := Value; - end -end; -{$ENDIF} - -function TWideStrings.GetValueFromIndex(Index: Integer): WideString; -begin - if Index >= 0 then - Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else - Result := ''; -end; - -procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); -begin - if Value <> '' then - begin - if Index < 0 then Index := Add(''); - Put(Index, Names[Index] + NameValueSeparator + Value); - end - else - if Index >= 0 then Delete(Index); -end; - -end. diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas deleted file mode 100644 index 12d74d8344..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas +++ /dev/null @@ -1,1452 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWindows; - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, ShellApi, ShlObj; - -// ......... compatibility - -const - DT_NOFULLWIDTHCHARBREAK = $00080000; - -const - INVALID_FILE_ATTRIBUTES = DWORD(-1); - -// ................ ANSI TYPES ................ -{TNT-WARN LPSTR} -{TNT-WARN PLPSTR} -{TNT-WARN LPCSTR} -{TNT-WARN LPCTSTR} -{TNT-WARN LPTSTR} - -// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... -// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... -// .. TNT--WARN EnumResourceTypes .. -// .. TNT--WARN EnumResourceTypesA .. -// .. TNT--WARN EnumResourceNames .. -// .. TNT--WARN EnumResourceNamesA .. -// .. TNT--WARN EnumResourceLanguages .. -// .. TNT--WARN EnumResourceLanguagesA .. - -//------------------------------------------------------------------------------------------ - -// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... -{TNT-WARN ExtTextOut} -{TNT-WARN ExtTextOutA} -{TNT-WARN Tnt_ExtTextOutW} - -{TNT-WARN FindResource} -{TNT-WARN FindResourceA} -{TNT-WARN Tnt_FindResourceW} - -{TNT-WARN FindResourceEx} -{TNT-WARN FindResourceExA} -{TNT-WARN Tnt_FindResourceExW} - -{TNT-WARN GetCharWidth} -{TNT-WARN GetCharWidthA} -{TNT-WARN Tnt_GetCharWidthW} - -{TNT-WARN GetCommandLine} -{TNT-WARN GetCommandLineA} -{TNT-WARN Tnt_GetCommandLineW} - -{TNT-WARN GetTextExtentPoint} -{TNT-WARN GetTextExtentPointA} -{TNT-WARN Tnt_GetTextExtentPointW} - -{TNT-WARN GetTextExtentPoint32} -{TNT-WARN GetTextExtentPoint32A} -{TNT-WARN Tnt_GetTextExtentPoint32W} - -{TNT-WARN lstrcat} -{TNT-WARN lstrcatA} -{TNT-WARN Tnt_lstrcatW} - -{TNT-WARN lstrcpy} -{TNT-WARN lstrcpyA} -{TNT-WARN Tnt_lstrcpyW} - -{TNT-WARN lstrlen} -{TNT-WARN lstrlenA} -{TNT-WARN Tnt_lstrlenW} - -{TNT-WARN MessageBox} -{TNT-WARN MessageBoxA} -{TNT-WARN Tnt_MessageBoxW} - -{TNT-WARN MessageBoxEx} -{TNT-WARN MessageBoxExA} -{TNT-WARN Tnt_MessageBoxExA} - -{TNT-WARN TextOut} -{TNT-WARN TextOutA} -{TNT-WARN Tnt_TextOutW} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale -{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale - -//------------------------------------------------------------------------------------------ -// compatiblity -//------------------------------------------------------------------------------------------ -{$IFNDEF COMPILER_9_UP} -type - TStartupInfoA = _STARTUPINFOA; - TStartupInfoW = record - cb: DWORD; - lpReserved: PWideChar; - lpDesktop: PWideChar; - lpTitle: PWideChar; - dwX: DWORD; - dwY: DWORD; - dwXSize: DWORD; - dwYSize: DWORD; - dwXCountChars: DWORD; - dwYCountChars: DWORD; - dwFillAttribute: DWORD; - dwFlags: DWORD; - wShowWindow: Word; - cbReserved2: Word; - lpReserved2: PByte; - hStdInput: THandle; - hStdOutput: THandle; - hStdError: THandle; - end; - -function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; - -{$ENDIF} -//------------------------------------------------------------------------------------------ - -{TNT-WARN SetWindowText} -{TNT-WARN SetWindowTextA} -{TNT-WARN SetWindowTextW} -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; - -{TNT-WARN RemoveDirectory} -{TNT-WARN RemoveDirectoryA} -{TNT-WARN RemoveDirectoryW} -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetShortPathName} -{TNT-WARN GetShortPathNameA} -{TNT-WARN GetShortPathNameW} -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; - -{TNT-WARN GetFullPathName} -{TNT-WARN GetFullPathNameA} -{TNT-WARN GetFullPathNameW} -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; - -{TNT-WARN CreateFile} -{TNT-WARN CreateFileA} -{TNT-WARN CreateFileW} -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; - -{TNT-WARN FindFirstFile} -{TNT-WARN FindFirstFileA} -{TNT-WARN FindFirstFileW} -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; - -{TNT-WARN FindNextFile} -{TNT-WARN FindNextFileA} -{TNT-WARN FindNextFileW} -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; - -{TNT-WARN GetFileAttributes} -{TNT-WARN GetFileAttributesA} -{TNT-WARN GetFileAttributesW} -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; - -{TNT-WARN SetFileAttributes} -{TNT-WARN SetFileAttributesA} -{TNT-WARN SetFileAttributesW} -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; - -{TNT-WARN CreateDirectory} -{TNT-WARN CreateDirectoryA} -{TNT-WARN CreateDirectoryW} -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; - -{TNT-WARN MoveFile} -{TNT-WARN MoveFileA} -{TNT-WARN MoveFileW} -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; - -{TNT-WARN CopyFile} -{TNT-WARN CopyFileA} -{TNT-WARN CopyFileW} -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; - -{TNT-WARN DeleteFile} -{TNT-WARN DeleteFileA} -{TNT-WARN DeleteFileW} -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; - -{TNT-WARN DrawText} -{TNT-WARN DrawTextA} -{TNT-WARN DrawTextW} -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; - -{TNT-WARN GetDiskFreeSpace} -{TNT-WARN GetDiskFreeSpaceA} -{TNT-WARN GetDiskFreeSpaceW} -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; - -{TNT-WARN GetVolumeInformation} -{TNT-WARN GetVolumeInformationA} -{TNT-WARN GetVolumeInformationW} -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; - -{TNT-WARN GetModuleFileName} -{TNT-WARN GetModuleFileNameA} -{TNT-WARN GetModuleFileNameW} -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; - -{TNT-WARN GetTempPath} -{TNT-WARN GetTempPathA} -{TNT-WARN GetTempPathW} -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN GetTempFileName} -{TNT-WARN GetTempFileNameA} -{TNT-WARN GetTempFileNameW} -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; - -{TNT-WARN GetWindowsDirectory} -{TNT-WARN GetWindowsDirectoryA} -{TNT-WARN GetWindowsDirectoryW} -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetSystemDirectory} -{TNT-WARN GetSystemDirectoryA} -{TNT-WARN GetSystemDirectoryW} -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetCurrentDirectory} -{TNT-WARN GetCurrentDirectoryA} -{TNT-WARN GetCurrentDirectoryW} -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN SetCurrentDirectory} -{TNT-WARN SetCurrentDirectoryA} -{TNT-WARN SetCurrentDirectoryW} -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetComputerName} -{TNT-WARN GetComputerNameA} -{TNT-WARN GetComputerNameW} -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN GetUserName} -{TNT-WARN GetUserNameA} -{TNT-WARN GetUserNameW} -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN ShellExecute} -{TNT-WARN ShellExecuteA} -{TNT-WARN ShellExecuteW} -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; - -{TNT-WARN LoadLibrary} -{TNT-WARN LoadLibraryA} -{TNT-WARN LoadLibraryW} -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; - -{TNT-WARN LoadLibraryEx} -{TNT-WARN LoadLibraryExA} -{TNT-WARN LoadLibraryExW} -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; - -{TNT-WARN CreateProcess} -{TNT-WARN CreateProcessA} -{TNT-WARN CreateProcessW} -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; - -{TNT-WARN GetCurrencyFormat} -{TNT-WARN GetCurrencyFormatA} -{TNT-WARN GetCurrencyFormatW} -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; - -{TNT-WARN CompareString} -{TNT-WARN CompareStringA} -{TNT-WARN CompareStringW} -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; - -{TNT-WARN CharUpper} -{TNT-WARN CharUpperA} -{TNT-WARN CharUpperW} -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharUpperBuff} -{TNT-WARN CharUpperBuffA} -{TNT-WARN CharUpperBuffW} -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN CharLower} -{TNT-WARN CharLowerA} -{TNT-WARN CharLowerW} -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharLowerBuff} -{TNT-WARN CharLowerBuffA} -{TNT-WARN CharLowerBuffW} -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN GetStringTypeEx} -{TNT-WARN GetStringTypeExA} -{TNT-WARN GetStringTypeExW} -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; - -{TNT-WARN LoadString} -{TNT-WARN LoadStringA} -{TNT-WARN LoadStringW} -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; - -{TNT-WARN InsertMenuItem} -{TNT-WARN InsertMenuItemA} -{TNT-WARN InsertMenuItemW} -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; - -{TNT-WARN ExtractIconEx} -{TNT-WARN ExtractIconExA} -{TNT-WARN ExtractIconExW} -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; - -{TNT-WARN ExtractAssociatedIcon} -{TNT-WARN ExtractAssociatedIconA} -{TNT-WARN ExtractAssociatedIconW} -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; - -{TNT-WARN GetFileVersionInfoSize} -{TNT-WARN GetFileVersionInfoSizeA} -{TNT-WARN GetFileVersionInfoSizeW} -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; - -{TNT-WARN GetFileVersionInfo} -{TNT-WARN GetFileVersionInfoA} -{TNT-WARN GetFileVersionInfoW} -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; - -const - VQV_FIXEDFILEINFO = '\'; - VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; - VQV_STRINGFILEINFO = '\StringFileInfo'; - - VER_COMMENTS = 'Comments'; - VER_INTERNALNAME = 'InternalName'; - VER_PRODUCTNAME = 'ProductName'; - VER_COMPANYNAME = 'CompanyName'; - VER_LEGALCOPYRIGHT = 'LegalCopyright'; - VER_PRODUCTVERSION = 'ProductVersion'; - VER_FILEDESCRIPTION = 'FileDescription'; - VER_LEGALTRADEMARKS = 'LegalTrademarks'; - VER_PRIVATEBUILD = 'PrivateBuild'; - VER_FILEVERSION = 'FileVersion'; - VER_ORIGINALFILENAME = 'OriginalFilename'; - VER_SPECIALBUILD = 'SpecialBuild'; - -{TNT-WARN VerQueryValue} -{TNT-WARN VerQueryValueA} -{TNT-WARN VerQueryValueW} -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; - -type - TSHNameMappingHeaderA = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGA; - end; - PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; - - TSHNameMappingHeaderW = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGW; - end; - PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; - -{TNT-WARN SHFileOperation} -{TNT-WARN SHFileOperationA} -{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; - -{TNT-WARN SHFreeNameMappings} -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); - -{TNT-WARN SHBrowseForFolder} -{TNT-WARN SHBrowseForFolderA} -{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; - -{TNT-WARN SHGetPathFromIDList} -{TNT-WARN SHGetPathFromIDListA} -{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; - -{TNT-WARN SHGetFileInfo} -{TNT-WARN SHGetFileInfoA} -{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; - -// ......... introduced ......... -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; - -function LANGIDFROMLCID(lcid: LCID): WORD; -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -function PRIMARYLANGID(lgid: WORD): WORD; -function SORTIDFROMLCID(lcid: LCID): WORD; -function SUBLANGID(lgid: WORD): WORD; - -implementation - -uses - SysUtils, Math, TntSysUtils, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PAnsiChar(S); -end; - -function _PWideCharWithNil(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PWideChar(S); -end; - -function _WStr(lpString: PWideChar; cchCount: Integer): WideString; -begin - if cchCount = -1 then - Result := lpString - else - Result := Copy(WideString(lpString), 1, cchCount); -end; - -procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); -begin - CopyMemory(@WideFindData, @AnsiFindData, - Integer(@WideFindData.cFileName) - Integer(@WideFindData)); - WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); - WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); -end; - -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) - else - Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); -end; - -//----------------------------- - -type - TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); - TPathLengthResultOptions = set of TPathLengthResultOption; - -procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; -begin - for i := 1 to Count do begin - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; -end; - -procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; - OriginalSource: PWideChar; - PNextSlash: PWideChar; -begin - if Count >= 4 then begin - OriginalSource := pSource; - PNextSlash := WStrScan(pSource, '\'); - for i := 1 to Count - 1 do begin - // determine next path delimiter - if pSource > pNextSlash then begin - PNextSlash := WStrScan(pSource, '\'); - end; - // leave if no more sub paths - if (PNextSlash = nil) - or ((pNextSlash - OriginalSource) >= Count) then begin - exit; - end; - // copy char - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; - end; -end; - -function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength > Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if (poExactCopy in Options) then begin - // exact - Result := nBufferLength; - _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else begin - // other - if (poAllowDirectoryMode in Options) - and (nBufferLength = Cardinal(Length(WideBuff))) then begin - Result := Length(WideBuff) + 1; - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); - end else begin - Result := Length(WideBuff) + 1; - if (nBufferLength > 0) then begin - if (poZeroSmallBuff in Options) then - lpBuffer^ := #0 - else if (poExactCopySubPaths in Options) then - _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); - end; - end; - end; -end; - -function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength >= Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if nBufferLength = 0 then - Result := Length(WideBuff) - else - Result := 0; -end; - -//------------------------------------------- - -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) - else - Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), - PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); - end; -end; - -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; -var - AnsiBuff: AnsiString; - AnsiFilePart: PAnsiChar; - AnsiLeadingChars: Integer; - WideLeadingChars: Integer; -begin - if Win32PlatformIsUnicode then - Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), - Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); - // deal w/ lpFilePart - if (AnsiFilePart = nil) or (nBufferLength < Result) then - lpFilePart := nil - else begin - AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); - WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); - lpFilePart := lpBuffer + WideLeadingChars; - end; - end; -end; - -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; -begin - if Win32PlatformIsUnicode then - Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) - else - Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) -end; - -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) - else begin - Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), - Ansi_lpFindFileData); - if Result <> INVALID_HANDLE_VALUE then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) - else begin - Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); - if Result then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) - else - Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) - else - Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); -end; - -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) - else - Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); -end; - -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) - else - Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); -end; - -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) - else - Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), - PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); -end; - -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) - else - Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; -begin - if Win32PlatformIsUnicode then - Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) - else - Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, - PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); -end; - -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) - else - Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) -end; - -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; -var - AnsiFileSystemNameBuffer: AnsiString; - AnsiVolumeNameBuffer: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) - else begin - SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiFileSystemNameBuffer); - Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); - if Result then begin - SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); - if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then - Result := False - else begin - WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); - WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); - end; - end; - end; -end; - -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); - end; -end; - -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) - else begin - SetLength(AnsiBuff, MAX_PATH); - Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); - AnsiBuff := PAnsiChar(AnsiBuff); - _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); - end; -end; - -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) - else - Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiBuff); - Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, 255); - AnsiBuffLen := Length(AnsiBuff); - Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; -begin - if Win32PlatformIsUnicode then - Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), - FileName, Parameters, - Directory, ShowCmd) - else begin - Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), - _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), - _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) - end; -end; - -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) - else - Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); -end; - -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) - else - Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); -end; - -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; -var - AnsiStartupInfo: TStartupInfoA; -begin - if Win32PlatformIsUnicode then begin - Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - lpCurrentDirectory, lpStartupInfo, lpProcessInformation) - end else begin - CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); - AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); - AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); - AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); - Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), - _PAnsiCharWithNil(AnsiString(lpCommandLine)), - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); - end; -end; - -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; -const - MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? -var - AnsiFormat: TCurrencyFmtA; - PAnsiFormat: PCurrencyFmtA; - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, lpFormat, lpCurrencyStr, cchCurrency) - else begin - if lpFormat = nil then - PAnsiFormat := nil - else begin - ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); - AnsiFormat.NumDigits := lpFormat.NumDigits; - AnsiFormat.LeadingZero := lpFormat.LeadingZero; - AnsiFormat.Grouping := lpFormat.Grouping; - AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); - AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); - AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; - AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; - AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); - PAnsiFormat := @AnsiFormat; - end; - SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); - SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, - PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); - Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); - end; -end; - -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; -var - WideStr1, WideStr2: WideString; - AnsiStr1, AnsiStr2: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) - else begin - WideStr1 := _WStr(lpString1, cchCount1); - WideStr2 := _WStr(lpString2, cchCount2); - if (dwCmpFlags = 0) then begin - // binary comparison - if WideStr1 < WideStr2 then - Result := 1 - else if WideStr1 = WideStr2 then - Result := 2 - else - Result := 3; - end else begin - AnsiStr1 := WideStr1; - AnsiStr2 := WideStr2; - Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, - PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); - end; - end; -end; - -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; -var - AStr: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) - else begin - AStr := _WStr(lpSrcStr, cchSrc); - Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, - PAnsiChar(AStr), -1, lpCharType); - end; -end; - -function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -// This function originated by the WINE Project. -// It was translated to Pascal by Francisco Leong. -// It was further modified by Troy Wolbrink. -var - hmem: HGLOBAL; - hrsrc: THandle; - p: PWideChar; - string_num, i: Integer; - block: Integer; -begin - Result := 0; - // Netscape v3 fix... - if (HIWORD(uID) = $FFFF) then begin - uID := UINT(-(Integer(uID))); - end; - // figure block, string_num - block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 - string_num := uID and $000F; - // get handle & pointer to string block - hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); - if (hrsrc <> 0) then - begin - hmem := LoadResource(hInstance, hrsrc); - if (hmem <> 0) then - begin - p := LockResource(hmem); - // walk the block to the requested string - for i := 0 to string_num - 1 do begin - p := p + Integer(p^) + 1; - end; - Result := Integer(p^); { p points to the length of string } - Inc(p); { p now points to the actual string } - if (lpBuffer <> nil) and (nBufferMax > 0) then - begin - Result := min(nBufferMax - 1, Result); { max length to copy } - if (Result > 0) then begin - CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); - end; - lpBuffer[Result] := WideChar(0); { null terminate } - end; - end; - end; -end; - -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -begin - if Win32PlatformIsUnicode then - Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) - else - Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); -end; - -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; -begin - if Win32PlatformIsUnicode then - Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, lpmii) - else begin - TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); - Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, TMenuItemInfoA(lpmii)); - end; -end; - -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; -begin - if Win32PlatformIsUnicode then - Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, - nIconIndex, phiconLarge, phiconSmall, nIcons) - else - Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), - nIconIndex, phiconLarge, phiconSmall, nIcons); -end; - -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; -begin - if Win32PlatformIsUnicode then - Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, lpIconPath, lpiIcon) - else - Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, - PAnsiChar(AnsiString(lpIconPath)), lpiIcon) -end; - -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) - else - Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); -end; - -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) - else - Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); -end; - -var - Last_VerQueryValue_String: WideString; - -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) - else begin - Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); - if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then - else begin - { /StringFileInfo, convert ansi result to unicode } - SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); - Last_VerQueryValue_String := AnsiBuff; - lplpBuffer := PWideChar(Last_VerQueryValue_String); - puLen := Length(Last_VerQueryValue_String); - end; - end; -end; - -//--------------------------------------------------------------------------------------- -// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) -//--------------------------------------------------------------------------------------- - -type - TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; - TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; - TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; - TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; - -var - Safe_SHFileOperationW: TSHFileOperationW = nil; - Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; - Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; - Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; - -var Shell32DLL: HModule = 0; - -procedure LoadWideShell32Procs; -begin - if Shell32DLL = 0 then begin - Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); - Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); - Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); - Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); - Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); - end; -end; - -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; -var - AnsiFileOp: TSHFileOpStructA; - MapCount: Integer; - PAnsiMap: PSHNameMappingA; - PWideMap: PSHNameMappingW; - OldPath: WideString; - NewPath: WideString; - i: integer; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHFileOperationW(lpFileOp); - end else begin - AnsiFileOp := TSHFileOpStructA(lpFileOp); - // convert PChar -> PWideChar - if lpFileOp.pFrom = nil then - AnsiFileOp.pFrom := nil - else - AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); - if lpFileOp.pTo = nil then - AnsiFileOp.pTo := nil - else - AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); - AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); - Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}(AnsiFileOp); - // return struct results - lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; - lpFileOp.hNameMappings := nil; - if (AnsiFileOp.hNameMappings <> nil) - and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin - // alloc mem - MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; - lpFileOp.hNameMappings := - AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); - PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; - // init pointers - PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; - PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; - for i := 1 to MapCount do begin - // old path - OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); - PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); - PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); - // new path - NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); - PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); - PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); - // next record - Inc(PAnsiMap); - Inc(PWideMap); - end; - end; - end; -end; - -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); -var - i: integer; - MapCount: Integer; - PWideMap: PSHNameMappingW; -begin - if Win32PlatformIsUnicode then - SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) - else begin - // free strings - MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; - PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; - for i := 1 to MapCount do begin - WStrDispose(PWideMap.pszOldPath); - WStrDispose(PWideMap.pszNewPath); - Inc(PWideMap); - end; - // free struct - FreeMem(Pointer(hNameMappings)); - end; -end; - -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; -var - AnsiInfo: TBrowseInfoA; - AnsiBuffer: array[0..MAX_PATH] of AnsiChar; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHBrowseForFolderW(lpbi); - end else begin - AnsiInfo := TBrowseInfoA(lpbi); - AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); - if lpbi.pszDisplayName <> nil then - AnsiInfo.pszDisplayName := AnsiBuffer; - Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}(AnsiInfo); - if lpbi.pszDisplayName <> nil then - WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); - lpbi.iImage := AnsiInfo.iImage; - end; -end; - -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; -var - AnsiPath: AnsiString; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetPathFromIDListW(pidl, pszPath); - end else begin - SetLength(AnsiPath, MAX_PATH); - Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); - if Result then - WStrPCopy(pszPath, PAnsiChar(AnsiPath)) - end; -end; - -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; -var - SHFileInfoA: TSHFileInfoA; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) - end else begin - Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), - dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); - // update pfsi... - ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); - psfi.hIcon := SHFileInfoA.hIcon; - psfi.iIcon := SHFileInfoA.iIcon; - psfi.dwAttributes := SHFileInfoA.dwAttributes; - WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); - WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); - end; -end; - - -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; -begin - Result := HiWord(Cardinal(ResStr)) = 0; -end; - -function LANGIDFROMLCID(lcid: LCID): WORD; -begin - Result := LoWord(lcid); -end; - -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -begin - Result := (usSubLanguage shl 10) or usPrimaryLanguage; -end; - -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -begin - Result := MakeLong(wLanguageID, wSortID); -end; - -function PRIMARYLANGID(lgid: WORD): WORD; -begin - Result := lgid and $03FF; -end; - -function SORTIDFROMLCID(lcid: LCID): WORD; -begin - Result := HiWord(lcid); -end; - -function SUBLANGID(lgid: WORD): WORD; -begin - Result := lgid shr 10; -end; - -initialization - -finalization - if Shell32DLL <> 0 then - FreeLibrary(Shell32DLL); - -end. diff --git a/plugins/Chess4Net/lib/XIE/XIE.pas b/plugins/Chess4Net/lib/XIE/XIE.pas deleted file mode 100644 index bd2498e738..0000000000 --- a/plugins/Chess4Net/lib/XIE/XIE.pas +++ /dev/null @@ -1,333 +0,0 @@ -{ ============================================================================= - - UnitName : XIe - Ver : 1.1 - Create Date : 09.07.2007 - Last Edit : 19.01.2011 by Pavel Perminov - Author : Dmitry Mirovodin - http://www.hcsoft.spb.ru - mirovodin@mail.ru - support@hcsoft.spb.ru - - ========================================================================== } - -unit XIE; - -interface - -uses - Windows, ActiveX, URLMon; - -type - - TIEWrapperOnProcess = Procedure (const ProgressProcent: Byte; const StatusID : Cardinal; Const StatusText : String ) of object; - - - TBindStatusCallBack = Class(TObject, IUnknown, IBindStatusCallback) - private - fOnProcess : TIEWrapperOnProcess; - function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall; - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - protected - function OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; stdcall; - function GetPriority(out nPriority): HResult; stdcall; - function OnLowResource(reserved: DWORD): HResult; stdcall; - function OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall; - function OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; stdcall; - function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; virtual; stdcall; - function OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc; stgmed: PStgMedium): HResult; stdcall; - function OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; stdcall; - public - constructor Create(); - Property OnProcess : TIEWrapperOnProcess Read fOnProcess Write fOnProcess; - Class function ProcessStatusIdToString(Const StatusId: Cardinal):String; - end; - - TIEWrapper = Class (TObject) - protected - fBindStatusCallback : TBindStatusCallback; - function GetOnProcess : TIEWrapperOnProcess; - procedure SetOnProcess( Value : TIEWrapperOnProcess); - function CheckRequest(const Request : String): boolean; Virtual; - public - constructor Create(); virtual; - destructor Destroy(); override; - function OpenRequest(const Request : String):String; - function LoadFile(const Request : String; const FileName: String): boolean; - property OnProcess : TIEWrapperOnProcess Read GetOnProcess Write SetOnProcess; - end; - - -implementation - -uses - SysUtils; - -{ -const - BINDF_ASYNCHRONOUS = $00000001; - BINDF_ASYNCSTORAGE = $00000002; - BINDF_NOPROGRESSIVERENDERING = $00000004; - BINDF_OFFLINEOPERATION = $00000008; - BINDF_GETNEWESTVERSION = $00000010; - BINDF_NOWRITECACHE = $00000020; - BINDF_NEEDFILE = $00000040; - BINDF_PULLDATA = $00000080; - BINDF_IGNORESECURITYPROBLEM = $00000100; - BINDF_RESYNCHRONIZE = $00000200; - BINDF_HYPERLINK = $00000400; - BINDF_NO_UI = $00000800; - BINDF_SILENTOPERATION = $00001000; - BINDF_PRAGMA_NO_CACHE = $00002000; - BINDF_GETCLASSOBJECT = $00004000; - BINDF_RESERVED_1 = $00008000; - BINDF_FREE_THREADED = $00010000; - BINDF_DIRECT_READ = $00020000; - BINDF_FORMS_SUBMIT = $00040000; - BINDF_GETFROMCACHE_IF_NET_FAIL= $00080000; - BINDF_FROMURLMON = $00100000; - BINDF_FWD_BACK = $00200000; - BINDF_PREFERDEFAULTHANDLER = $00400000; - BINDF_RESERVED_3 = $00800000; -} - -// ========================================================================== // - -constructor TBindStatusCallback.Create(); -begin - inherited Create; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.QueryInterface(const IID: TGUID; out Obj): HResult; -begin - if GetInterface(IID, Obj) then Result := S_OK - else Result := E_NOINTERFACE; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback._AddRef: Integer; -begin - Result := -1; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback._Release: Integer; -begin - Result := -1; -end; - -// ----------------------------------------------------------------------------- - -Class function TBindStatusCallback.ProcessStatusIdToString(Const StatusId: Cardinal):String; -begin - case StatusId of - BINDSTATUS_FINDINGRESOURCE : result := 'BINDSTATUS_FINDINGRESOURCE'; - BINDSTATUS_CONNECTING : Result := 'BINDSTATUS_CONNECTING'; - BINDSTATUS_REDIRECTING : Result := 'BINDSTATUS_REDIRECTING'; - BINDSTATUS_BEGINDOWNLOADDATA : Result := 'BINDSTATUS_BEGINDOWNLOADDATA'; - BINDSTATUS_DOWNLOADINGDATA : Result := 'BINDSTATUS_DOWNLOADINGDATA'; - BINDSTATUS_ENDDOWNLOADDATA : Result := 'BINDSTATUS_ENDDOWNLOADDATA'; - BINDSTATUS_BEGINDOWNLOADCOMPONENTS : Result := 'BINDSTATUS_BEGINDOWNLOADCOMPONENTS'; - BINDSTATUS_INSTALLINGCOMPONENTS : Result := 'BINDSTATUS_INSTALLINGCOMPONENTS'; - BINDSTATUS_ENDDOWNLOADCOMPONENTS : Result := 'BINDSTATUS_ENDDOWNLOADCOMPONENTS'; - BINDSTATUS_USINGCACHEDCOPY : Result := 'BINDSTATUS_USINGCACHEDCOPY'; - BINDSTATUS_SENDINGREQUEST : Result := 'BINDSTATUS_SENDINGREQUEST'; - BINDSTATUS_CLASSIDAVAILABLE : Result := 'BINDSTATUS_CLASSIDAVAILABLE'; - BINDSTATUS_MIMETYPEAVAILABLE : Result := 'BINDSTATUS_MIMETYPEAVAILABLE'; - BINDSTATUS_CACHEFILENAMEAVAILABLE : Result := 'BINDSTATUS_CACHEFILENAMEAVAILABLE'; - BINDSTATUS_BEGINSYNCOPERATION : Result := 'BINDSTATUS_BEGINSYNCOPERATION'; - BINDSTATUS_ENDSYNCOPERATION : Result := 'BINDSTATUS_ENDSYNCOPERATION'; - BINDSTATUS_BEGINUPLOADDATA : Result := 'BINDSTATUS_BEGINUPLOADDATA'; - BINDSTATUS_UPLOADINGDATA : Result:= 'BINDSTATUS_UPLOADINGDATA'; - BINDSTATUS_ENDUPLOADDATA : Result:= 'BINDSTATUS_ENDUPLOADDATA'; - BINDSTATUS_PROTOCOLCLASSID : Result := 'BINDSTATUS_PROTOCOLCLASSID'; - BINDSTATUS_ENCODING : Result:= 'BINDSTATUS_ENCODING'; - BINDSTATUS_VERIFIEDMIMETYPEAVAILABLE : Result := 'BINDSTATUS_VERIFIEDMIMETYPEAVAILABLE'; - BINDSTATUS_CLASSINSTALLLOCATION : Result := 'BINDSTATUS_CLASSINSTALLLOCATION'; - BINDSTATUS_DECODING : Result := 'BINDSTATUS_DECODING'; - BINDSTATUS_LOADINGMIMEHANDLER : Result := 'BINDSTATUS_LOADINGMIMEHANDLER'; - BINDSTATUS_CONTENTDISPOSITIONATTACH : Result := 'BINDSTATUS_CONTENTDISPOSITIONATTACH'; - BINDSTATUS_FILTERREPORTMIMETYPE : Result := 'BINDSTATUS_FILTERREPORTMIMETYPE'; - BINDSTATUS_CLSIDCANINSTANTIATE : Result := 'BINDSTATUS_CLSIDCANINSTANTIATE'; - BINDSTATUS_IUNKNOWNAVAILABLE : Result := 'BINDSTATUS_IUNKNOWNAVAILABLE'; - BINDSTATUS_DIRECTBIND : Result := 'BINDSTATUS_DIRECTBIND'; - BINDSTATUS_RAWMIMETYPE : Result := 'BINDSTATUS_RAWMIMETYPE'; - BINDSTATUS_PROXYDETECTING : Result := 'BINDSTATUS_PROXYDETECTING'; - BINDSTATUS_ACCEPTRANGES : Result := 'BINDSTATUS_ACCEPTRANGES'; - BINDSTATUS_COOKIE_SENT : Result := 'BINDSTATUS_COOKIE_SENT'; - BINDSTATUS_COMPACT_POLICY_RECEIVED : Result := 'BINDSTATUS_COMPACT_POLICY_RECEIVED'; - BINDSTATUS_COOKIE_SUPPRESSED : Result := 'BINDSTATUS_COOKIE_SUPPRESSED'; - BINDSTATUS_COOKIE_STATE_UNKNOWN : Result := 'BINDSTATUS_COOKIE_STATE_UNKNOWN'; - BINDSTATUS_COOKIE_STATE_ACCEPT : Result := 'BINDSTATUS_COOKIE_STATE_ACCEPT'; - BINDSTATUS_COOKIE_STATE_REJECT : Result := 'BINDSTATUS_COOKIE_STATE_REJECT'; - BINDSTATUS_COOKIE_STATE_PROMPT : Result := 'BINDSTATUS_COOKIE_STATE_PROMPT'; - BINDSTATUS_COOKIE_STATE_LEASH : Result := 'BINDSTATUS_COOKIE_STATE_LEASH'; - BINDSTATUS_COOKIE_STATE_DOWNGRADE : Result := 'BINDSTATUS_COOKIE_STATE_DOWNGRADE'; - BINDSTATUS_POLICY_HREF : Result := 'BINDSTATUS_POLICY_HREF'; - BINDSTATUS_P3P_HEADER : Result := 'BINDSTATUS_P3P_HEADER'; - BINDSTATUS_SESSION_COOKIE_RECEIVED : Result := 'BINDSTATUS_SESSION_COOKIE_RECEIVED'; - BINDSTATUS_PERSISTENT_COOKIE_RECEIVED : Result := 'BINDSTATUS_PERSISTENT_COOKIE_RECEIVED'; - BINDSTATUS_SESSION_COOKIES_ALLOWED : Result := 'BINDSTATUS_SESSION_COOKIES_ALLOWED'; - else - Result := 'N/A Code : ' + IntToStr(StatusId); - end; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnStartBinding(dwReserved: DWORD; pib: IBinding): HResult; -begin - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.GetPriority(out nPriority): HResult; -begin - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnLowResource(reserved: DWORD): HResult; -begin - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnProgress(ulProgress, ulProgressMax, ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; -var - Proc : Byte; -begin - if Assigned(fOnProcess) then - begin - if ulStatusCode = BINDSTATUS_ENDDOWNLOADDATA then Proc := 100 else - if ulProgressMax = 0 then Proc := 0 else - Proc := Trunc( ulProgress * 100 / ulProgressMax); - - fOnProcess(Proc, ulStatusCode, szStatusText); - end; - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnStopBinding(hresult: HResult; szError: LPCWSTR): HResult; -begin - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; -begin - Result := E_NOTIMPL; -// grfBINDF := BINDF_GETNEWESTVERSION; -// Result :=BINDF_GETNEWESTVERSION; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnDataAvailable(grfBSCF: DWORD; dwSize: DWORD; formatetc: PFormatEtc; stgmed: PStgMedium): HResult; -begin - Result := E_NOTIMPL; -end; - -// ----------------------------------------------------------------------------- - -function TBindStatusCallback.OnObjectAvailable(const iid: TGUID; punk: IUnknown): HResult; -begin - Result := E_NOTIMPL; -end; - -// ========================================================================== // - -Constructor TIEWrapper.Create; -begin - fBindStatusCallback := TBindStatusCallback.Create; -end; - -// ----------------------------------------------------------------------------- - -function TIEWrapper.GetOnProcess : TIEWrapperOnProcess; -begin - Result:=fBindStatusCallback.OnProcess; -end; - -// ----------------------------------------------------------------------------- - -procedure TIEWrapper.SetOnProcess( Value : TIEWrapperOnProcess); -begin - fBindStatusCallback.OnProcess := Value; -end; - -// ----------------------------------------------------------------------------- - -function TIEWrapper.CheckRequest(const Request : String): boolean; -begin - result := False; - if Length(Request)>0 then Result := True; -end; - -// ----------------------------------------------------------------------------- - -function TIEWrapper.OpenRequest(const Request : string):String; -Var - Stream : IStream; - StreamInfo : STATSTG; - BuffSize : Integer; - P : Pointer; -begin - Result := ''; - if not CheckRequest(Request) then Exit; - Stream := nil; - if URLOpenBlockingStream(nil, PChar(Request), Stream, 0, fBindStatusCallback) = S_OK then - Begin - ZeroMemory(@StreamInfo, SizeOf(StreamInfo)); - If Stream.Stat(StreamInfo, 0) = S_OK Then - Begin - If StreamInfo.cbSize > 0 Then - Begin - BuffSize := StreamInfo.cbSize; - GetMem(P, BuffSize); - try - ZeroMemory(P, SizeOf(BuffSize)); - Stream.Read(P, buffsize, Nil); - Result := PCHAR(P); - finally - FreeMem(P); - end; - End; - End; - Stream := nil; - End; -end; - -// ----------------------------------------------------------------------------- - -function TIEWrapper.LoadFile(const Request : String; const FileName: String): boolean; -begin - Result := false; - if not CheckRequest(Request) then Exit; - if URLDownloadToFile(nil, PChar(Request), PCHAR(FileName), 0, fBindStatusCallback) = S_OK then - Result := True; -end; - -// ----------------------------------------------------------------------------- - -destructor TIEWrapper.Destroy(); -begin - fBindStatusCallback.Free; - fBindStatusCallback := nil; - inherited Destroy; -end; - -// ========================================================================== // - -end. -- cgit v1.2.3