diff options
Diffstat (limited to 'plugins/!NotAdopted')
181 files changed, 70688 insertions, 0 deletions
diff --git a/plugins/!NotAdopted/Chess4Net/BitmapResUnit.pas b/plugins/!NotAdopted/Chess4Net/BitmapResUnit.pas new file mode 100644 index 0000000000..28551b3887 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/BitmapResUnit.pas @@ -0,0 +1,282 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit BitmapResUnit;
+
+interface
+
+uses
+ Graphics, Types,
+ // Chess4Net
+ ChessBoardHeaderUnit, ChessRulesEngine;
+
+type
+ // Bitmap resources - introduced for 2009.1 (sizable board feature)
+ TBitmapRes = class // parametrizable class factory
+ private
+ m_ResSet: TBitmap;
+ m_iSetNumber: integer;
+ m_iSquareSize: integer;
+ procedure FCalculateClientBoardSizes(InitialSize: TSize);
+ function FGetOptimalBoardSize(const ClientSize: TSize; out iSetNumber: integer): TSize;
+ procedure FCalculateSetNumberFromSquareSize;
+ procedure FLoadPieceSet(iSetNumber: integer);
+ function FGetBoardResName(iSetNumber: integer): string;
+ function FGetSetResName(iSetNumber: integer): string;
+ public
+ constructor Create(const ClientBoardSize: TSize); overload;
+ constructor Create(iSquareSize: integer); overload;
+ destructor Destroy; override;
+ procedure CreateBoardBitmap(ClientBoardSize: TSize; const BackgroundColor: TColor;
+ out Bitmap: TBitmap);
+ procedure CreateFigureBitmap(const Figure: TFigure; out Bitmap: TBitmap);
+ function GetOptimalBoardSize(ClientSize: TSize): TSize;
+ property SquareSize: integer read m_iSquareSize;
+ end;
+
+implementation
+
+{$R ChessSet_PNG.RES}
+
+uses
+ SysUtils, Classes, Math, pngimage;
+
+{$J+}
+
+const
+ CHB_RES_X = 4; CHB_RES_Y = 4; // starting coordinates of A8 field in resources
+
+var
+ arrClientBoardSizes: array[1..7] of TSize;
+ g_bClientBoardSizesCalculated: boolean = FALSE;
+
+////////////////////////////////////////////////////////////////////////////////
+// TBitmapRes
+
+constructor TBitmapRes.Create(const ClientBoardSize: TSize);
+begin
+ inherited Create;
+ FCalculateClientBoardSizes(ClientBoardSize);
+end;
+
+
+constructor TBitmapRes.Create(iSquareSize: integer);
+begin
+ inherited Create;
+ m_iSquareSize := iSquareSize;
+end;
+
+
+destructor TBitmapRes.Destroy;
+begin
+ m_ResSet.Free;
+ inherited;
+end;
+
+
+procedure TBitmapRes.CreateBoardBitmap(ClientBoardSize: TSize; const BackgroundColor: TColor;
+ out Bitmap: TBitmap);
+var
+ Png: TPngObject;
+ ResBoard: TBitmap;
+ iSetNumber: integer;
+begin
+ Png := nil;
+ ResBoard := nil;
+
+ FGetOptimalBoardSize(ClientBoardSize, iSetNumber);
+
+ if (iSetNumber = 0) then
+ exit;
+
+ Bitmap := TBitMap.Create;
+ with Bitmap do
+ try
+ Png := TPngObject.Create;
+ Png.LoadFromResourceName(HInstance, FGetBoardResName(iSetNumber));
+ ResBoard := TBitmap.Create;
+ ResBoard.Assign(Png);
+
+ Width := arrClientBoardSizes[iSetNumber].cx;
+ Height := arrClientBoardSizes[iSetNumber].cy;
+ Canvas.Brush.Color := BackgroundColor;
+ Canvas.FillRect(Bounds(0, 0, Width, Height));
+ Canvas.Draw(CHB_X - CHB_RES_X, CHB_Y - CHB_RES_Y, ResBoard);
+
+ // Load appropriate set
+ FLoadPieceSet(iSetNumber);
+
+ finally;
+ m_iSetNumber := iSetNumber;
+ ResBoard.Free;
+ Png.Free;
+ end;
+end;
+
+
+procedure TBitmapRes.FLoadPieceSet(iSetNumber: integer);
+var
+ Png: TPngObject;
+begin
+ if (Assigned(m_ResSet) and (iSetNumber = m_iSetNumber)) then
+ exit;
+
+ FreeAndNil(m_ResSet);
+
+ Png := TPngObject.Create;
+ try
+ Png.LoadFromResourceName(HInstance, FGetSetResName(iSetNumber));
+ m_ResSet := TBitmap.Create;
+ m_ResSet.Assign(Png);
+
+ m_iSquareSize := m_ResSet.Height;
+ finally
+ Png.Free;
+ end;
+end;
+
+
+procedure TBitmapRes.CreateFigureBitmap(const Figure: TFigure; out Bitmap: TBitmap);
+const
+ PNG_SET_POS: array[TFigure] of integer = (2, 4, 6, 8, 10, 12, 0, 3, 5, 7, 9, 11, 13);
+var
+ iWidth: integer;
+begin
+ if (m_iSetNumber = 0) then
+ begin
+ FCalculateSetNumberFromSquareSize;
+ if (m_iSetNumber = 0) then
+ exit;
+ end;
+
+ FLoadPieceSet(m_iSetNumber);
+
+ iWidth := IfThen((Figure = ES), m_iSquareSize + m_iSquareSize, m_iSquareSize);
+
+ Bitmap := TBitMap.Create;
+ Bitmap.Width := iWidth;
+ Bitmap.Height := m_iSquareSize;
+
+ Bitmap.Canvas.CopyRect(Bounds(0, 0, iWidth, m_iSquareSize), m_ResSet.Canvas,
+ Bounds(m_iSquareSize * PNG_SET_POS[Figure], 0, iWidth, m_iSquareSize));
+ Bitmap.Transparent:= TRUE;
+end;
+
+
+procedure TBitmapRes.FCalculateSetNumberFromSquareSize;
+var
+ i: integer;
+begin
+ m_iSetNumber := 0;
+
+ with TPngObject.Create do
+ try
+ for i := High(arrClientBoardSizes) downto Low(arrClientBoardSizes) do
+ begin
+ LoadFromResourceName(HInstance, FGetSetResName(i));
+
+ if (Height <= m_iSquareSize) then
+ begin
+ m_iSetNumber := i;
+ exit;
+ end;
+ end;
+
+ finally
+ Free;
+ end;
+
+end;
+
+
+function TBitmapRes.GetOptimalBoardSize(ClientSize: TSize): TSize;
+var
+ iDummy: integer;
+begin
+ Result := FGetOptimalBoardSize(ClientSize, iDummy);
+end;
+
+
+function TBitmapRes.FGetOptimalBoardSize(const ClientSize: TSize; out iSetNumber: integer): TSize;
+var
+ i: integer;
+begin
+ iSetNumber := 0;
+
+ for i := High(arrClientBoardSizes) downto Low(arrClientBoardSizes) do
+ begin
+ if ((ClientSize.cx >= arrClientBoardSizes[i].cx) and
+ (ClientSize.cy >= arrClientBoardSizes[i].cy)) then
+ begin
+ Result := arrClientBoardSizes[i];
+ iSetNumber := i;
+ exit;
+ end;
+ end; { for i }
+
+ Result := Size(0, 0);
+end;
+
+
+procedure TBitmapRes.FCalculateClientBoardSizes(InitialSize: TSize);
+var
+ i: integer;
+ iOptimal: integer;
+ iAddX, iAddY: integer;
+begin
+ if (g_bClientBoardSizesCalculated) then
+ exit;
+
+ // Load board sizes from resources
+ with TPngObject.Create do
+ try
+ for i := Low(arrClientBoardSizes) to High(arrClientBoardSizes) do
+ begin
+ LoadFromResourceName(HInstance, FGetBoardResName(i));
+ arrClientBoardSizes[i] := Size(Width, Height);
+ end;
+ finally
+ Free;
+ end;
+
+ // Find optimal board size from resources
+ iOptimal := 0;
+ for i := High(arrClientBoardSizes) downto Low(arrClientBoardSizes) do
+ begin
+ if ((InitialSize.cx > (arrClientBoardSizes[i].cx + CHB_X - CHB_RES_X)) and
+ (InitialSize.cy > (arrClientBoardSizes[i].cy + CHB_Y - CHB_RES_Y))) then
+ begin
+ iOptimal := i;
+ break;
+ end;
+ end;
+ Assert(iOptimal > 0);
+
+ // Calculate board sizes for client
+ iAddX := InitialSize.cx - arrClientBoardSizes[iOptimal].cx;
+ iAddY := InitialSize.cy - arrClientBoardSizes[iOptimal].cy;
+ for i := Low(arrClientBoardSizes) to High(arrClientBoardSizes) do
+ begin
+ inc(arrClientBoardSizes[i].cx, iAddX);
+ inc(arrClientBoardSizes[i].cy, iAddY);
+ end;
+
+ g_bClientBoardSizesCalculated := TRUE;
+end;
+
+
+function TBitmapRes.FGetBoardResName(iSetNumber: integer): string;
+begin
+ Result := 'BOARD' + IntToStr(iSetNumber);
+end;
+
+
+function TBitmapRes.FGetSetResName(iSetNumber: integer): string;
+begin
+ Result := 'SET' + IntToStr(iSetNumber);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/Build/Chigorin.mov b/plugins/!NotAdopted/Chess4Net/Build/Chigorin.mov Binary files differnew file mode 100644 index 0000000000..d52fb6b2c4 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Chigorin.mov diff --git a/plugins/!NotAdopted/Chess4Net/Build/Chigorin.pos b/plugins/!NotAdopted/Chess4Net/Build/Chigorin.pos Binary files differnew file mode 100644 index 0000000000..ed7f8eb36d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Chigorin.pos diff --git a/plugins/!NotAdopted/Chess4Net/Build/Fischer.mov b/plugins/!NotAdopted/Chess4Net/Build/Fischer.mov Binary files differnew file mode 100644 index 0000000000..8000a1934e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Fischer.mov diff --git a/plugins/!NotAdopted/Chess4Net/Build/Fischer.pos b/plugins/!NotAdopted/Chess4Net/Build/Fischer.pos Binary files differnew file mode 100644 index 0000000000..9f64528cdc --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Fischer.pos diff --git a/plugins/!NotAdopted/Chess4Net/Build/Tal.mov b/plugins/!NotAdopted/Chess4Net/Build/Tal.mov Binary files differnew file mode 100644 index 0000000000..db9fcd6798 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Tal.mov diff --git a/plugins/!NotAdopted/Chess4Net/Build/Tal.pos b/plugins/!NotAdopted/Chess4Net/Build/Tal.pos Binary files differnew file mode 100644 index 0000000000..6a5199294b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/Tal.pos diff --git a/plugins/!NotAdopted/Chess4Net/Build/eco.mov b/plugins/!NotAdopted/Chess4Net/Build/eco.mov Binary files differnew file mode 100644 index 0000000000..c041d1a6d0 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/eco.mov diff --git a/plugins/!NotAdopted/Chess4Net/Build/eco.pos b/plugins/!NotAdopted/Chess4Net/Build/eco.pos Binary files differnew file mode 100644 index 0000000000..361375d6f3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Build/eco.pos diff --git a/plugins/!NotAdopted/Chess4Net/Chess4Net.bpg b/plugins/!NotAdopted/Chess4Net/Chess4Net.bpg new file mode 100644 index 0000000000..a347fd3148 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Chess4Net.bpg @@ -0,0 +1,36 @@ +#------------------------------------------------------------------------------
+VERSION = BWS.01
+#------------------------------------------------------------------------------
+!ifndef ROOT
+ROOT = $(MAKEDIR)\..
+!endif
+#------------------------------------------------------------------------------
+MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$**
+DCC = $(ROOT)\bin\dcc32.exe $**
+BRCC = $(ROOT)\bin\brcc32.exe $**
+#------------------------------------------------------------------------------
+PROJECTS = Chess4Net.exe Chess4Net_MI.dll Chess4Net_Trillian.dll \
+ Chess4Net_AndRQ.dll Chess4Net_QIP.dll Chess4Net_Skype.exe
+#------------------------------------------------------------------------------
+default: $(PROJECTS)
+#------------------------------------------------------------------------------
+
+Chess4Net.exe: Socket\Chess4Net.dpr
+ $(DCC)
+
+Chess4Net_MI.dll: MI\Chess4Net_MI.dpr
+ $(DCC)
+
+Chess4Net_Trillian.dll: Trillian\Chess4Net_Trillian.dpr
+ $(DCC)
+
+Chess4Net_AndRQ.dll: AndRQ\Chess4Net_AndRQ.dpr
+ $(DCC)
+
+Chess4Net_QIP.dll: QIP\Chess4Net_QIP.dpr
+ $(DCC)
+
+Chess4Net_Skype.exe: Skype\Chess4Net_Skype.dpr
+ $(DCC)
+
+
diff --git a/plugins/!NotAdopted/Chess4Net/Chess4Net.ico b/plugins/!NotAdopted/Chess4Net/Chess4Net.ico Binary files differnew file mode 100644 index 0000000000..7994197a01 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Chess4Net.ico diff --git a/plugins/!NotAdopted/Chess4Net/Chess4Net.res b/plugins/!NotAdopted/Chess4Net/Chess4Net.res Binary files differnew file mode 100644 index 0000000000..a42efffac4 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Chess4Net.res diff --git a/plugins/!NotAdopted/Chess4Net/Chess4Net_16.ico b/plugins/!NotAdopted/Chess4Net/Chess4Net_16.ico Binary files differnew file mode 100644 index 0000000000..d76475585f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Chess4Net_16.ico diff --git a/plugins/!NotAdopted/Chess4Net/ChessBoardHeaderUnit.pas b/plugins/!NotAdopted/Chess4Net/ChessBoardHeaderUnit.pas new file mode 100644 index 0000000000..b0226e3321 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessBoardHeaderUnit.pas @@ -0,0 +1,27 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ChessBoardHeaderUnit;
+
+interface
+
+uses
+ Types;
+
+const
+ CHB_X = 20; CHB_Y = 6; // starting coordinates of A8 field
+
+function Size(const iX, iY: integer): TSize;
+
+implementation
+
+function Size(const iX, iY: integer): TSize;
+begin
+ Result.cx := iX;
+ Result.cy := iY;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.dfm b/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.dfm new file mode 100644 index 0000000000..3976a60187 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.dfm @@ -0,0 +1,51 @@ +object ChessBoard: TChessBoard
+ Left = 715
+ Top = 238
+ Width = 364
+ Height = 381
+ Caption = 'ChessBoard'
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCanResize = FormCanResize
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ OnResize = FormResize
+ PixelsPerInch = 96
+ TextHeight = 13
+ object PBoxBoard: TPaintBox
+ Left = 0
+ Top = 0
+ Width = 356
+ Height = 354
+ Align = alClient
+ Color = clSilver
+ DragCursor = crHandPoint
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -13
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ OnDragDrop = PBoxBoardDragDrop
+ OnDragOver = PBoxBoardDragOver
+ OnEndDrag = PBoxBoardEndDrag
+ OnMouseDown = PBoxBoardMouseDown
+ OnMouseMove = PBoxBoardMouseMove
+ OnMouseUp = PBoxBoardMouseUp
+ OnPaint = PBoxBoardPaint
+ OnStartDrag = PBoxBoardStartDrag
+ end
+ object AnimateTimer: TTimer
+ Enabled = False
+ Interval = 1
+ OnTimer = AnimateTimerTimer
+ Left = 8
+ Top = 8
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.pas b/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.pas new file mode 100644 index 0000000000..8a7042f292 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessBoardUnit.pas @@ -0,0 +1,1381 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ChessBoardUnit;
+
+interface
+
+uses
+ Forms, ExtCtrls, Classes, Controls, Graphics, Types, Messages,
+ //
+ ChessRulesEngine, BitmapResUnit, PromotionUnit;
+
+type
+ TMode = (mView, mGame, mAnalyse, mEdit); // Board mode
+
+ TAnimation = (aNo, aSlow, aQuick);
+
+ TChessBoardEvent = (cbeMate, cbeStaleMate, cbeMoved, cbePosSet, cbeMenu);
+ TChessBoardHandler = procedure(e: TChessBoardEvent;
+ d1: pointer = nil; d2: pointer = nil) of object;
+
+ TChessBoardLayerBase = class;
+
+ TChessBoard = class(TForm, IChessRulesEngineable)
+ PBoxBoard: TPaintBox;
+ AnimateTimer: TTimer;
+
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormCanResize(Sender: TObject; var NewWidth,
+ NewHeight: Integer; var Resize: Boolean);
+ procedure FormResize(Sender: TObject);
+ procedure AnimateTimerTimer(Sender: TObject);
+ procedure PBoxBoardPaint(Sender: TObject);
+ procedure PBoxBoardDragDrop(Sender, Source: TObject; X, Y: Integer);
+ procedure PBoxBoardDragOver(Sender, Source: TObject; X, Y: Integer;
+ State: TDragState; var Accept: Boolean);
+ procedure PBoxBoardEndDrag(Sender, Target: TObject; X, Y: Integer);
+ procedure PBoxBoardMouseDown(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+ procedure PBoxBoardMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
+ procedure PBoxBoardMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure PBoxBoardStartDrag(Sender: TObject; var DragObject: TDragObject);
+
+ private
+ m_ChessRulesEngine: TChessRulesEngine;
+ m_BitmapRes: TBitmapRes; // Manager for bitmaps
+
+ FHandler: TChessBoardHandler;
+
+ dx, dy: integer; // Ðàññòîÿíèå îò êóðñîðà äî âåðõíåãî ëåâîãî óãëà
+ x0, y0: integer; // Ïðåäûäóùèå êîîðäèíàòû êóðñîðà
+ _flipped: boolean; // Äîñêà ïåðåâ¸ðíóòà èëè íåò
+ m_bHilighted: boolean; // Hilight the move that is being done
+
+ m_i0, m_j0: integer;
+ m_fig: TFigure;
+
+ m_Mode: TMode;
+ m_bViewGaming: boolean;
+
+ m_bmHiddenBoard: TBitmap;
+ m_bmChessBoard: TBitmap;
+ m_bmFigure: array[TFigure] of TBitmap;
+ m_bmBuf: TBitmap;
+
+ m_iSquareSize: integer; // Size of one chess board field
+
+ m_animation: TAnimation; // Animation speed
+ m_iAnimStep, m_iPrevAnimStep, m_iAnimStepsCount: integer;
+ anim_dx, anim_dy: real; // Variables for animation of a dragged piece
+
+ m_PlayerColor: TFigureColor; // Color of player client
+ m_bDraggedMoved: boolean; // Flag for switching of dragging
+ last_hilight: boolean; // Flag for hilighting of the last move done
+ coord_show: boolean; // Flag for showing coordinates
+
+ // Resizing
+ m_ResizingType: (rtNo, rtHoriz, rtVert);
+ m_iDeltaWidthHeight: integer;
+ m_bDeltaWidthHeightFlag: boolean;
+
+ m_PromotionForm: TPromotionForm;
+
+ m_EditPiece: TFigure;
+
+ m_iUpdateCounter: integer;
+
+ m_lstLayers: TList;
+
+ procedure HilightLastMove;
+ procedure Evaluate;
+
+ function FGetLastMove: PMoveAbs;
+ property lastMove: PMoveAbs read FGetLastMove;
+
+ function FGetPosition: PChessPosition;
+ property Position: PChessPosition read FGetPosition;
+
+ function AskPromotionFigure(FigureColor: TFigureColor): TFigureName;
+
+ procedure FSetMode(const Value: TMode);
+
+ function FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean;
+ procedure FOnAfterMoveDone;
+ procedure FOnAfterSetPosition;
+
+ procedure FAnimate(const i, j: integer); // Animates a disposition of a piece from (i0,j0) to (i,j)
+ procedure FDoAnimationStep;
+ procedure FEndAnimation;
+
+ procedure FWhatSquare(const P: TPoint; var i: Integer; var j: Integer);
+
+ procedure FSetPlayerColor(const Value: TFigureColor);
+ procedure FCancelAnimationDragging; // Caneling of animation and dragging for trace removal after draw
+ procedure FSetFlipped(Value: boolean); // Flips chess position
+ procedure FSetCoordinatesShown(Value: boolean);
+ procedure FSetLastMoveHilighted(Value: boolean);
+ function FGetPositionsList: TList;
+ function FGetPositionColor: TFigureColor;
+ function FGetMoveNotationFormat: TMoveNotationFormat;
+ procedure FSetMoveNotationFormat(Value: TMoveNotationFormat);
+ function FGetFENFormat: boolean;
+ procedure FSetFENFormat(bValue: boolean);
+
+ procedure FDrawHiddenBoard;
+ function FGetHiddenBoardCanvas: TCanvas;
+
+ procedure FDrawBoard;
+ procedure FOnDrawLayerUpdate(const ADrawLayer: TChessBoardLayerBase);
+
+ function FGetMovesOffset: integer;
+ function FGetColorStarts: TFigureColor;
+
+ procedure WMSizing(var Msg: TMessage); message WM_SIZING;
+
+ procedure FDoHandler(e: TChessBoardEvent; d1: pointer = nil; d2: pointer = nil);
+
+ property SquareSize: integer read m_iSquareSize;
+ property PositionsList: TList read FGetPositionsList;
+
+ public
+ constructor Create(Owner: TComponent; AHandler: TChessBoardHandler = nil); reintroduce;
+
+ function DoMove(const strMove: string): boolean;
+ procedure ResetMoveList;
+ function SetPosition(const strPosition: string): boolean;
+ function GetPosition: string;
+ procedure InitPosition;
+ procedure PPRandom;
+ procedure TakeBack;
+ function NMoveDone: integer;
+ function NPlysDone: integer;
+
+ function IsMoveAnimating: boolean;
+
+ procedure BeginUpdate;
+ procedure EndUpdate;
+
+ procedure AddLayer(const ALayer: TChessBoardLayerBase);
+ procedure RemoveLayer(const ALayer: TChessBoardLayerBase);
+
+ property PlayerColor: TFigureColor read m_PlayerColor write FSetPlayerColor;
+ property Mode: TMode read m_Mode write FSetMode;
+ property CoordinatesShown: boolean read coord_show write FSetCoordinatesShown;
+ property Flipped: boolean read _flipped write FSetFlipped;
+ property LastMoveHilighted: boolean read last_hilight write FSetLastMoveHilighted;
+ property Animation: TAnimation read m_animation write m_animation;
+ property ViewGaming: boolean read m_bViewGaming write m_bViewGaming;
+ property PositionColor: TFigureColor read FGetPositionColor; // Whos move it is in the current position
+ property MoveNotationFormat: TMoveNotationFormat
+ read FGetMoveNotationFormat write FSetMoveNotationFormat;
+ property MovesOffset: integer read FGetMovesOffset;
+ property FENFormat: boolean read FGetFENFormat write FSetFENFormat;
+ property EditPiece: TFigure read m_EditPiece write m_EditPiece;
+ end;
+
+
+ TChessBoardLayerBase = class
+ private
+ m_ChessBoard: TChessBoard;
+ function FGetSquareSize: integer;
+ function FGetCanvas: TCanvas;
+ function FGetPosition: PChessPosition;
+ function FGetPositionsList: TList;
+ protected
+ procedure RDraw; virtual; abstract;
+ function RGetColorStarts: TFigureColor;
+
+ procedure RDoUpdate;
+
+ procedure ROnAfterMoveDone; virtual;
+ procedure ROnAfterSetPosition; virtual;
+ procedure ROnAfterModeSet(const OldValue, NewValue: TMode); virtual;
+ procedure ROnResetMoveList; virtual;
+
+ property ChessBoard: TChessBoard read m_ChessBoard write m_ChessBoard;
+ property SquareSize: integer read FGetSquareSize;
+ property Canvas: TCanvas read FGetCanvas;
+ property Position: PChessPosition read FGetPosition;
+ property PositionsList: TList read FGetPositionsList;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ Math, SysUtils, Windows,
+ //
+ ChessBoardHeaderUnit;
+
+const
+ HILIGHT_WIDTH = 1;
+ HILIGHT_COLOR: TColor = clRed;
+ HILIGHT_LAST_MOVE_WIDTH = 1;
+ HILIGHT_LAST_MOVE_COLOR: TColor = clBlue;
+ ANIMATION_SLOW = 30; // Time of animation in frames >= 1
+ ANIMATION_QUICK = 9;
+ CHB_WIDTH = 4;
+
+////////////////////////////////////////////////////////////////////////////////
+// TChessBoard
+
+constructor TChessBoard.Create(Owner: TComponent; AHandler: TChessBoardHandler = nil);
+begin
+ FHandler := AHandler;
+ inherited Create(Owner);
+end;
+
+
+procedure TChessBoard.AnimateTimerTimer(Sender: TObject);
+begin
+ FDoAnimationStep;
+ if (m_iAnimStep >= m_iAnimStepsCount) then
+ FEndAnimation;
+end;
+
+
+procedure TChessBoard.FDoAnimationStep;
+var
+ iX, iY: integer;
+ rect: TRect;
+begin
+ if (m_iAnimStep < m_iAnimStepsCount) then
+ begin
+ inc(m_iAnimStep);
+
+ iX := round(x0 + anim_dx * m_iAnimStep);
+ iY := round(y0 + anim_dy * m_iAnimStep);
+ dx := iX - x0 - Round(anim_dx * m_iPrevAnimStep);
+ dy := iY - y0 - Round(anim_dy * m_iPrevAnimStep);
+
+ // Âîññòàíîâèòü ôðàãìåíò íà m_bmHiddenBoard
+ m_bmHiddenBoard.Canvas.Draw(iX - dx, iY - dy, m_bmBuf);
+ // Êîïèðîâàòü íîâûé ôðàãìåíò â áóôåð
+ m_bmBuf.Canvas.CopyRect(Bounds(0, 0, m_iSquareSize, m_iSquareSize),
+ m_bmHiddenBoard.Canvas, Bounds(iX, iY, m_iSquareSize, m_iSquareSize));
+ // Íàðèñîâàòü ïåðåòàñêèâàåìóþ ôèãóðó â íîâîé ïîçèöèè
+ m_bmHiddenBoard.Canvas.Draw(iX, iY, m_bmFigure[m_fig]);
+ // Ïåðåíåñòè íîâûé ôðàãìåíò íà ýêðàí
+ rect := Bounds(Min(iX - dx, iX), Min(iY - dy, iY),
+ abs(dx) + m_iSquareSize, abs(dy) + m_iSquareSize);
+ PBoxBoard.Canvas.CopyRect(rect, m_bmHiddenBoard.Canvas, rect);
+ end;
+
+ m_iPrevAnimStep := m_iAnimStep;
+
+end;
+
+
+procedure TChessBoard.FEndAnimation;
+begin
+ AnimateTimer.Enabled := FALSE;
+
+ m_iAnimStep := m_iAnimStepsCount;
+
+ FDrawBoard;
+ HilightLastMove;
+ Evaluate;
+end;
+
+
+procedure TChessBoard.FDrawBoard;
+var
+ i: integer;
+begin
+ if (csDestroying in ComponentState) then
+ exit;
+
+ if (m_iUpdateCounter > 0) then
+ exit;
+
+ FDrawHiddenBoard;
+
+ for i := 0 to m_lstLayers.Count - 1 do
+ TChessBoardLayerBase(m_lstLayers[i]).RDraw;
+
+ PBoxBoardPaint(nil);
+end;
+
+
+procedure TChessBoard.HilightLastMove;
+var
+ i, j, l,
+ _i0, _j0, x, y: integer;
+begin
+ if (not (m_Mode in [mGame, mAnalyse])) then
+ exit;
+
+ // Output the last move done
+ if (last_hilight and (lastMove.i0 <> 0)) then
+ begin
+ if (_flipped) then
+ begin
+ _i0 := 9 - lastMove.i0;
+ _j0 := lastMove.j0;
+ i := 9 - lastMove.i;
+ j := lastMove.j;
+ end
+ else
+ begin
+ _i0 := lastMove.i0;
+ _j0 := 9 - lastMove.j0;
+ i := lastMove.i;
+ j := 9 - lastMove.j;
+ end;
+
+ x := m_iSquareSize * (_i0 - 1) + CHB_X;
+ y := m_iSquareSize * (_j0 - 1) + CHB_Y;
+ m_bmHiddenBoard.Canvas.Pen.Color := HILIGHT_LAST_MOVE_COLOR;
+ m_bmHiddenBoard.Canvas.Pen.Width := HILIGHT_LAST_MOVE_WIDTH;
+
+ for l := 1 to 2 do
+ with m_bmHiddenBoard.Canvas do
+ begin
+ MoveTo(x, y);
+ LineTo(x + m_iSquareSize - 1, y);
+ LineTo(x + m_iSquareSize - 1, y + m_iSquareSize - 1);
+ LineTo(x, y + m_iSquareSize - 1);
+ LineTo(x, y);
+
+ x := m_iSquareSize * (i - 1) + CHB_X;
+ y := m_iSquareSize * (j - 1) + CHB_Y;
+ end;
+ PBoxBoardPaint(nil);
+ end;
+end;
+
+
+procedure TChessBoard.FDrawHiddenBoard;
+var
+ i, j: integer;
+ x, y: integer;
+begin
+ if (not Assigned(m_bmHiddenBoard)) then
+ exit;
+
+ // Copy empty board to the hidden one
+ with m_bmHiddenBoard do
+ begin
+ Canvas.CopyRect(Bounds(0,0, Width,Height), m_bmChessBoard.Canvas, Bounds(0,0, Width,Height));
+ end;
+
+ // Draw coordinates
+ if (coord_show) then
+ with m_bmHiddenBoard, m_bmHiddenBoard.Canvas do
+ begin
+ x:= CHB_X + m_iSquareSize div 2;
+ y:= (m_bmHiddenBoard.Height + CHB_Y + 8 * m_iSquareSize + CHB_WIDTH) div 2;
+ if _flipped then j := ord('h')
+ else j:= ord('a');
+ for i:= 1 to 8 do // áóêâû
+ begin
+ TextOut(x - TextWidth(chr(j)) div 2,
+ y + 1 - TextHeight(chr(j)) div 2 , chr(j));
+ x := x + m_iSquareSize;
+ if _flipped then dec(j)
+ else inc(j);
+ end;
+ x:= (CHB_X - CHB_WIDTH) div 2;
+ y:= CHB_Y + m_iSquareSize div 2;
+ if _flipped then j:= ord('1')
+ else j := ord('8');
+ for i := 1 to 8 do // öèôðû
+ begin
+ TextOut(x - TextWidth(chr(j)) div 2,
+ y - TextHeight(chr(j)) div 2, chr(j));
+ y:= y + m_iSquareSize;
+ if _flipped then inc(j)
+ else dec(j);
+ end;
+ end;
+
+ // Draw pieces
+ for i := 1 to 8 do
+ for j := 1 to 8 do
+ begin
+ if ((Position.board[i,j] = ES)) then
+ continue; // There's nothing to draw
+ if not _flipped then // Çàãðóçèòü íóæíóþ ôèãóðó èç ðåñóðñà è íàðèñîâàòü
+ m_bmHiddenBoard.Canvas.Draw(CHB_X + m_iSquareSize * (i-1),
+ CHB_Y + m_iSquareSize * (8-j),
+ m_bmFigure[Position.board[i,j]])
+ else // Black is below
+ m_bmHiddenBoard.Canvas.Draw(CHB_X + m_iSquareSize * (8-i),
+ CHB_Y + m_iSquareSize * (j-1),
+ m_bmFigure[Position.board[i,j]]);
+ end;
+end;
+
+
+function TChessBoard.FGetHiddenBoardCanvas: TCanvas;
+begin
+ if (Assigned(m_bmHiddenBoard)) then
+ Result := m_bmHiddenBoard.Canvas
+ else
+ Result := nil;
+end;
+
+
+procedure TChessBoard.Evaluate;
+begin
+ case m_ChessRulesEngine.GetEvaluation of
+ evMate:
+ FDoHandler(cbeMate, self);
+ evStaleMate:
+ FDoHandler(cbeStaleMate, self);
+ end;
+end;
+
+
+procedure TChessBoard.PBoxBoardPaint(Sender: TObject);
+begin
+ PBoxBoard.Canvas.Draw(0, 0, m_bmHiddenBoard); // Draw hidden board on the form
+// PBoxBoard.Canvas.StretchDraw(Bounds(0, 0, PBoxBoard.Width, PBoxBoard.Height), m_bmHiddenBoard);
+end;
+
+
+function TChessBoard.FGetLastMove: PMoveAbs;
+begin
+ Result := m_ChessRulesEngine.lastMove;
+end;
+
+
+function TChessBoard.FGetPosition: PChessPosition;
+begin
+ Result := m_ChessRulesEngine.Position;
+end;
+
+
+function TChessBoard.AskPromotionFigure(FigureColor: TFigureColor): TFigureName;
+var
+ frmOwner: TForm;
+begin
+ if (Owner is TForm) then
+ frmOwner := TForm(Owner)
+ else
+ frmOwner := self;
+
+ if (Showing) then
+ begin
+ m_PromotionForm := TPromotionForm.Create(frmOwner, m_BitmapRes);
+ try
+ Result := m_PromotionForm.ShowPromotion(FigureColor);
+ finally
+ FreeAndNil(m_PromotionForm);
+ end;
+ end
+ else
+ Result := Q;
+end;
+
+
+procedure TChessBoard.FSetPlayerColor(const Value: TFigureColor);
+begin
+ FCancelAnimationDragging;
+ m_PlayerColor := Value;
+ if (m_PlayerColor = fcWhite) then
+ FSetFlipped(FALSE)
+ else // fcBlack
+ FSetFlipped(TRUE);
+end;
+
+
+procedure TChessBoard.FCancelAnimationDragging;
+begin
+ // Cancel animation and dragging
+ if (AnimateTimer.Enabled) then
+ begin
+ AnimateTimer.Enabled := FALSE;
+ // iAnimStep := iAnimStepsCount;
+ // AnimateTimerTimer(nil);
+ end;
+
+ if (PBoxBoard.Dragging) then
+ begin
+ m_bDraggedMoved := FALSE;
+ PBoxBoard.EndDrag(FALSE);
+ end;
+end;
+
+
+procedure TChessBoard.FSetFlipped(Value: boolean);
+begin
+ // TODO: ???
+ _flipped := Value;
+ FDrawBoard;
+end;
+
+
+procedure TChessBoard.FSetMode(const Value: TMode);
+var
+ OldMode: TMode;
+ i: integer;
+begin
+ if (m_Mode = Value) then
+ exit;
+
+ OldMode := m_Mode;
+ m_Mode := Value;
+
+ if ((m_Mode in [mView, mEdit]) and (Assigned(m_PromotionForm))) then
+ m_PromotionForm.Close;
+
+ for i := 0 to m_lstLayers.Count - 1 do
+ TChessBoardLayerBase(m_lstLayers[i]).ROnAfterModeSet(OldMode, m_Mode);
+
+ FDrawBoard;
+ HilightLastMove;
+end;
+
+
+procedure TChessBoard.FSetCoordinatesShown(Value: boolean);
+begin
+ coord_show := Value;
+ FDrawBoard;
+ HilightLastMove;
+end;
+
+
+procedure TChessBoard.FSetLastMoveHilighted(Value: boolean);
+begin
+ last_hilight := Value;
+ FDrawBoard;
+ HilightLastMove;
+end;
+
+
+function TChessBoard.DoMove(const strMove: string): boolean;
+begin
+ Result := FALSE;
+
+ if (m_Mode = mEdit) then
+ exit;
+
+ // Animation canceling
+ if (AnimateTimer.Enabled) then
+ FEndAnimation;
+
+ Result := m_ChessRulesEngine.DoMove(strMove);
+
+ if (Result) then
+ begin
+ FOnAfterMoveDone;
+ FAnimate(lastMove.i, lastMove.j);
+ end;
+end;
+
+
+procedure TChessBoard.FOnAfterMoveDone;
+var
+ _fig: TFigure;
+ strLastMove: string;
+ i: integer;
+begin
+ m_i0 := lastMove.i0;
+ m_j0 := lastMove.j0;
+
+ _fig := Position.board[lastMove.i, lastMove.j];
+ if (lastMove.prom_fig in [Q, R, B, N]) then
+ begin
+ if (_fig < ES) then
+ m_fig := WP
+ else
+ m_fig := BP;
+ end
+ else
+ m_fig := _fig;
+
+ strLastMove := m_ChessRulesEngine.LastMoveStr;
+ FDoHandler(cbeMoved, @strLastMove, self);
+
+ if (m_Mode = mAnalyse) then
+ m_PlayerColor := PositionColor;
+
+ for i := 0 to m_lstLayers.Count - 1 do
+ TChessBoardLayerBase(m_lstLayers[i]).ROnAfterMoveDone;
+end;
+
+
+procedure TChessBoard.FAnimate(const i, j: integer);
+var
+ x, y: integer;
+begin
+ if (not Showing) then
+ exit;
+
+ if ((m_i0 = 0) or (m_j0 = 0)) then
+ exit;
+
+ if (AnimateTimer.Enabled) then
+ begin
+ m_iAnimStep := m_iAnimStepsCount;
+ exit;
+ end;
+
+ case animation of
+ aNo:
+ m_iAnimStepsCount := 1;
+ aSlow:
+ m_iAnimStepsCount := ANIMATION_SLOW;
+ aQuick:
+ m_iAnimStepsCount := ANIMATION_QUICK;
+ end;
+
+ if (_flipped) then
+ begin
+ x0 := (8 - m_i0) * m_iSquareSize + CHB_X;
+ y0 := (m_j0 - 1) * m_iSquareSize + CHB_Y;
+ x := (8 - i) * m_iSquareSize + CHB_X;
+ y := (j - 1) * m_iSquareSize + CHB_Y;
+ end
+ else
+ begin
+ x0 := (m_i0 - 1) * m_iSquareSize + CHB_X;
+ y0 := (8 - m_j0) * m_iSquareSize + CHB_Y;
+ x := (i - 1) * m_iSquareSize + CHB_X;
+ y := (8 - j) * m_iSquareSize + CHB_Y;
+ end;
+
+ anim_dx := (x - x0) / m_iAnimStepsCount;
+ anim_dy := (y - y0) / m_iAnimStepsCount;
+
+ m_iAnimStep := 0;
+ m_iPrevAnimStep := m_iAnimStep;
+
+ // Copy image of the empty square to m_bmBuf
+ m_bmBuf.Width := m_iSquareSize;
+ m_bmBuf.Height := m_iSquareSize;
+ if (((m_i0 + m_j0) and 1) <> 0) then
+ m_bmBuf.Canvas.CopyRect(Bounds(0, 0, m_iSquareSize, m_iSquareSize),
+ m_bmFigure[ES].Canvas, Bounds(0, 0, m_iSquareSize, m_iSquareSize))
+ else
+ m_bmBuf.Canvas.CopyRect(Bounds(0, 0, m_iSquareSize, m_iSquareSize),
+ m_bmFigure[ES].Canvas, Bounds(m_iSquareSize, 0, m_iSquareSize, m_iSquareSize));
+
+ AnimateTimer.Enabled := TRUE;
+end;
+
+
+procedure TChessBoard.ResetMoveList;
+var
+ i: integer;
+begin
+ m_ChessRulesEngine.ResetMoveList;
+
+ for i := 0 to m_lstLayers.Count - 1 do
+ TChessBoardLayerBase(m_lstLayers[i]).ROnResetMoveList;
+end;
+
+
+function TChessBoard.SetPosition(const strPosition: string): boolean;
+begin
+ Result := m_ChessRulesEngine.SetPosition(strPosition);
+ if (Result) then
+ begin
+ FCancelAnimationDragging;
+ FOnAfterSetPosition;
+ FDrawBoard;
+ end;
+end;
+
+
+function TChessBoard.GetPosition: string;
+begin
+ Result := m_ChessRulesEngine.GetPosition;
+end;
+
+
+procedure TChessBoard.FOnAfterSetPosition;
+var
+ strPosition: string;
+ i: integer;
+begin
+ case m_Mode of
+ mAnalyse:
+ m_PlayerColor := PositionColor;
+
+ mEdit:
+ ResetMoveList;
+ end;
+
+ m_i0 := 0;
+ m_j0 := 0;
+
+ strPosition := GetPosition;
+ FDoHandler(cbePosSet, @strPosition, self);
+
+ for i := 0 to m_lstLayers.Count - 1 do
+ TChessBoardLayerBase(m_lstLayers[i]).ROnAfterSetPosition;
+end;
+
+
+procedure TChessBoard.FormCreate(Sender: TObject);
+begin
+ // m_iDeltaWidthHeight := Width - Height;
+
+ m_BitmapRes := TBitmapRes.Create(Size(PBoxBoard.Width, PBoxBoard.Height));
+
+ coord_show:= TRUE;
+ last_hilight:= FALSE;
+ m_animation := aQuick;
+
+ m_ChessRulesEngine := TChessRulesEngine.Create(self);
+ m_lstLayers := TList.Create;
+end;
+
+
+procedure TChessBoard.FormDestroy(Sender: TObject);
+var
+ _fig: TFigure;
+ i: integer;
+begin
+ for i := m_lstLayers.Count - 1 downto 0 do
+ RemoveLayer(m_lstLayers[i]);
+ m_lstLayers.Free;
+
+ m_ChessRulesEngine.Free;
+
+ m_bmHiddenBoard.Free;
+ m_bmBuf.Free;
+
+ for _fig := Low(TFigure) to High(TFigure) do
+ m_bmFigure[_fig].Free;
+ m_bmChessBoard.Free;
+
+ m_BitmapRes.Free;
+end;
+
+
+procedure TChessBoard.PBoxBoardDragDrop(Sender, Source: TObject; X,
+ Y: Integer);
+var
+ i, j: Integer;
+begin
+ FWhatSquare(Point(X, Y), i, j);
+ case m_Mode of
+ mGame, mAnalyse:
+ begin
+ if (FDoMove(i, j)) then
+ m_bDraggedMoved := TRUE;
+ end;
+
+ mEdit:
+ m_bDraggedMoved := TRUE;
+ end;
+end;
+
+
+procedure TChessBoard.FWhatSquare(const P: TPoint;
+ var i: Integer; var j: Integer);
+begin
+ with P do
+ begin
+ i := (X - CHB_X + m_iSquareSize) div m_iSquareSize;
+ j := 8 - (Y - CHB_Y) div m_iSquareSize;
+ if (_flipped) then
+ begin
+ i := 9 - i;
+ j := 9 - j;
+ end;
+ end;
+end;
+
+
+function TChessBoard.FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean;
+begin
+ Result := m_ChessRulesEngine.DoMove(m_i0, m_j0, i, j, prom_fig);
+ if (Result) then
+ FOnAfterMoveDone;
+end;
+
+
+procedure TChessBoard.PBoxBoardDragOver(Sender, Source: TObject; X,
+ Y: Integer; State: TDragState; var Accept: Boolean);
+var
+ rect: TRect;
+ i, j: integer;
+begin
+ case State of
+ dsDragEnter:
+ m_bHilighted := FALSE;
+
+ dsDragMove:
+ begin
+ // Repaint a fragment on m_bmHiddenBoard
+ m_bmHiddenBoard.Canvas.Draw(x0 - dx, y0 - dy, m_bmBuf);
+ // Copy new fragment to the buffer
+ m_bmBuf.Canvas.CopyRect(Bounds(0, 0, m_iSquareSize, m_iSquareSize),
+ m_bmHiddenBoard.Canvas, Bounds(X - dx, Y - dy, m_iSquareSize, m_iSquareSize));
+ // Draw the dragging piece in a new position
+ m_bmHiddenBoard.Canvas.Draw(X - dx, Y - dy, m_bmFigure[m_fig]);
+ // Copy the new fragment to the screen
+ rect:= Bounds(Min(x0,X) - dx, Min(y0, Y) - dy,
+ abs(X - x0) + m_iSquareSize, abs(Y - y0) + m_iSquareSize);
+ PBoxBoard.Canvas.CopyRect(rect, m_bmHiddenBoard.Canvas, rect);
+
+ x0 := X;
+ y0 := Y;
+
+ FWhatSquare(Point(X,Y), i, j);
+
+ Accept := ((i in [1..8]) and (j in [1..8]));
+ end;
+ end;
+end;
+
+
+procedure TChessBoard.PBoxBoardEndDrag(Sender, Target: TObject; X, Y: Integer);
+var
+ i, j: integer;
+ bRes: boolean;
+begin
+ case m_Mode of
+ mGame, mAnalyse:
+ begin
+ if (m_bHilighted) then
+ begin
+ with m_bmHiddenBoard.Canvas do
+ begin
+ Pen.Color:= HILIGHT_COLOR;
+ Pen.Width := HILIGHT_WIDTH;
+ x0:= x0 - dx;
+ y0:= y0 - dy;
+ MoveTo(x0,y0);
+ LineTo(x0 + m_iSquareSize - 1, y0);
+ LineTo(x0 + m_iSquareSize - 1, y0 + m_iSquareSize - 1);
+ LineTo(x0, y0 + m_iSquareSize - 1);
+ LineTo(x0, y0);
+
+ PBoxBoardPaint(nil);
+ end;
+ end
+ else
+ begin
+ if (AnimateTimer.Enabled) then
+ AnimateTimer.Enabled := FALSE;
+ FDrawBoard;
+ if (m_bDraggedMoved) then
+ begin
+ HilightLastMove;
+ Evaluate;
+ m_bDraggedMoved := FALSE;
+ end;
+ end;
+ end;
+
+ mEdit:
+ begin
+ if (m_bDraggedMoved) then
+ begin
+ FWhatSquare(Point(X, Y), i, j);
+ bRes := (((i <> m_i0) or (j <> m_j0)) and Position.SetPiece(i, j, m_fig));
+ end
+ else
+ bRes := TRUE;
+
+ if (bRes) then
+ begin
+ Position.SetPiece(m_i0, m_j0, ES);
+ FOnAfterSetPosition;
+ end;
+
+ FDrawBoard;
+ end;
+ end; // case
+end;
+
+
+procedure TChessBoard.PBoxBoardMouseDown(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+var
+ i, j: Integer;
+ f: TFigure;
+begin
+ if (Button <> mbLeft) then
+ exit;
+
+ FWhatSquare(Point(X, Y), i, j);
+ if (not ((i in [1..8]) and (j in [1..8]))) then
+ exit;
+
+ m_bDraggedMoved := FALSE;
+
+ f := Position.board[i,j];
+
+ case m_Mode of
+ mGame, mAnalyse:
+ begin
+ if (m_bViewGaming) then
+ exit;
+ if ((Position.color <> m_PlayerColor) or
+ (((Position.color <> fcWhite) or (f >= ES)) and
+ ((Position.color <> fcBlack) or (f <= ES)))) then
+ exit;
+
+ if ((i = m_i0) and (j = m_j0)) then
+ m_bHilighted := (m_bHilighted xor TRUE)
+ else
+ m_bHilighted := TRUE;
+ end;
+
+ mEdit:
+ begin
+ if (f = ES) then
+ exit;
+ end;
+
+ else
+ exit;
+ end;
+
+ if (m_iAnimStep < m_iAnimStepsCount) then
+ FEndAnimation;
+
+ m_fig := f;
+ m_i0 := i;
+ m_j0 := j;
+
+ dx := (X - CHB_X) mod m_iSquareSize;
+ dy := (Y - CHB_Y) mod m_iSquareSize;
+ x0 := X;
+ y0 := Y;
+
+ m_bDraggedMoved := TRUE;
+ PBoxBoard.BeginDrag(FALSE);
+end;
+
+
+procedure TChessBoard.PBoxBoardMouseMove(Sender: TObject; Shift: TShiftState;
+ X, Y: Integer);
+var
+ f: TFigure;
+ i,j: Integer;
+begin
+ FWhatSquare(Point(X,Y), i,j);
+ if (not ((i in [1..8]) and (j in [1..8]))) then
+ begin
+ PBoxBoard.Cursor:= crDefault;
+ exit;
+ end;
+
+ f := Position.board[i,j];
+
+ case m_Mode of
+ mGame, mAnalyse:
+ begin
+ if (m_bViewGaming) then
+ exit;
+
+ if (m_PlayerColor = Position.color) and
+ (((Position.color = fcWhite) and (f < ES)) or
+ ((Position.color = fcBlack) and (f > ES))) then
+ PBoxBoard.Cursor:= crHandPoint
+ else
+ PBoxBoard.Cursor:= crDefault;
+ end;
+
+ mEdit:
+ begin
+ if (f <> ES) then
+ PBoxBoard.Cursor:= crHandPoint
+ else
+ PBoxBoard.Cursor:= crDefault;
+ end;
+
+ else
+ PBoxBoard.Cursor := crDefault;
+ end;
+end;
+
+
+function TChessBoard.FGetPositionsList: TList;
+begin
+ Result := m_ChessRulesEngine.PositionsList;
+end;
+
+
+function TChessBoard.FGetColorStarts: TFigureColor;
+begin
+ Result := m_ChessRulesEngine.GetColorStarts;
+end;
+
+
+procedure TChessBoard.PBoxBoardMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+var
+ i, j: integer;
+begin
+ case Button of
+ mbLeft:
+ begin
+ case m_Mode of
+ mGame, mAnalyse:
+ begin
+ if (not m_bHilighted) then
+ exit;
+ FWhatSquare(Point(X, Y), i, j);
+ if (m_bDraggedMoved) then
+ FDrawBoard
+ else
+ begin
+ m_bHilighted := FALSE;
+ if (FDoMove(i, j)) then
+ FAnimate(i, j)
+ else
+ FDrawBoard;
+ end;
+ end;
+
+ mEdit:
+ begin
+ if (m_bDraggedMoved) then
+ exit;
+ // Assert(empty field)
+ FWhatSquare(Point(X, Y), i, j);
+ if (Position.SetPiece(i, j, m_EditPiece)) then
+ begin
+ FOnAfterSetPosition;
+ FDrawBoard;
+ end;
+ end;
+
+ end; // case
+ end;
+
+ mbRight:
+ begin
+ FDoHandler(cbeMenu, self);
+ end;
+
+ end;
+end;
+
+
+procedure TChessBoard.PBoxBoardStartDrag(Sender: TObject;
+ var DragObject: TDragObject);
+begin
+ // Copy image of an empty square to m_bmBuf
+ m_bmBuf.Width := m_iSquareSize;
+ m_bmBuf.Height:= m_iSquareSize;
+ if (((m_i0 + m_j0) and 1) <> 0) then
+ m_bmBuf.Canvas.CopyRect(Bounds(0,0, m_iSquareSize, m_iSquareSize),
+ m_bmFigure[ES].Canvas, Bounds(0,0, m_iSquareSize, m_iSquareSize))
+ else
+ m_bmBuf.Canvas.CopyRect(Bounds(0,0, m_iSquareSize, m_iSquareSize),
+ m_bmFigure[ES].Canvas, Bounds(m_iSquareSize,0, m_iSquareSize, m_iSquareSize));
+
+ m_bDraggedMoved := FALSE;
+end;
+
+
+procedure TChessBoard.InitPosition;
+begin
+ m_ChessRulesEngine.InitNewGame;
+
+ FCancelAnimationDragging;
+ FOnAfterSetPosition;
+
+ FDrawBoard;
+end;
+
+
+procedure TChessBoard.PPRandom;
+begin
+ m_ChessRulesEngine.InitNewPPRandomGame;
+
+ FCancelAnimationDragging;
+ FOnAfterSetPosition;
+
+ FDrawBoard;
+end;
+
+
+procedure TChessBoard.TakeBack;
+begin
+ if (m_Mode = mEdit) then
+ exit;
+
+ if (not m_ChessRulesEngine.TakeBack) then
+ exit;
+
+ FOnAfterSetPosition;
+ // TODO: animation
+ FDrawBoard;
+end;
+
+
+function TChessBoard.NMoveDone: integer;
+begin
+ Result := m_ChessRulesEngine.NMovesDone;
+end;
+
+
+function TChessBoard.NPlysDone: integer;
+begin
+ Result := m_ChessRulesEngine.NPlysDone;
+end;
+
+
+function TChessBoard.FGetMovesOffset: integer;
+begin
+ Result := m_ChessRulesEngine.MovesOffset;
+end;
+
+
+function TChessBoard.FGetPositionColor: TFigureColor;
+begin
+ Result := Position.color;
+end;
+
+
+procedure TChessBoard.FormCanResize(Sender: TObject; var NewWidth,
+ NewHeight: Integer; var Resize: Boolean);
+var
+ NewBoardSize: TSize;
+begin
+ if (not m_bDeltaWidthHeightFlag) then
+ begin
+ m_iDeltaWidthHeight := Width - Height;
+ m_bDeltaWidthHeightFlag := TRUE;
+ end;
+
+ Resize := (m_ResizingType <> rtNo);
+ if (not Resize) then
+ exit;
+
+ if (m_ResizingType = rtVert) then
+ NewWidth := NewHeight + m_iDeltaWidthHeight
+ else // rtHoriz
+ NewHeight := NewWidth - m_iDeltaWidthHeight;
+
+ NewBoardSize := m_BitmapRes.GetOptimalBoardSize(
+ Size(PBoxBoard.Width + (NewWidth - Width), PBoxBoard.Height + (NewHeight - Height)));
+
+ Resize := (NewBoardSize.cx > 0) and (NewBoardSize.cy > 0) and
+ ((NewBoardSize.cx <> PBoxBoard.Width) or (NewBoardSize.cy <> PBoxBoard.Height));
+ if (Resize) then
+ begin
+ NewWidth := Width + (NewBoardSize.cx - PBoxBoard.Width);
+ NewHeight := Height + (NewBoardSize.cy - PBoxBoard.Height);
+ end;
+end;
+
+
+procedure TChessBoard.FormResize(Sender: TObject);
+var
+ _fig: TFigure;
+begin
+ FreeAndNil(m_bmChessBoard);
+ m_BitmapRes.CreateBoardBitmap(Size(PBoxBoard.Width, PBoxBoard.Height), self.Color,
+ m_bmChessBoard);
+ m_iSquareSize := m_BitmapRes.SquareSize;
+
+ for _fig := Low(TFigure) to High(TFigure) do
+ begin
+ FreeAndNil(m_bmFigure[_fig]);
+ m_BitmapRes.CreateFigureBitmap(_fig, m_bmFigure[_fig]);
+ end;
+
+ // Graphics initialization
+ if (not Assigned(m_bmHiddenBoard)) then
+ begin
+ m_bmHiddenBoard := Graphics.TBitmap.Create;
+ m_bmHiddenBoard.Palette := m_bmChessBoard.Palette;
+ m_bmHiddenBoard.Canvas.Font := PBoxBoard.Font; // Õàðàêòåðèñòèêè øðèôòà êîîðäèíàò çàäàþòñÿ â èíñïåêòîðå
+ m_bmHiddenBoard.Canvas.Brush.Style := bsClear;
+ end;
+ m_bmHiddenBoard.Width := m_bmChessBoard.Width;
+ m_bmHiddenBoard.Height := m_bmChessBoard.Height;
+
+ if (not Assigned(m_bmBuf)) then
+ begin
+ m_bmBuf := Graphics.TBitmap.Create;
+ m_bmBuf.Palette:= m_bmChessBoard.Palette;
+ end;
+
+ FDrawBoard;
+end;
+
+
+procedure TChessBoard.WMSizing(var Msg: TMessage);
+begin
+ case Msg.WParam of
+ WMSZ_RIGHT, WMSZ_LEFT, WMSZ_BOTTOMRIGHT, WMSZ_TOPLEFT:
+ m_ResizingType := rtHoriz;
+ WMSZ_BOTTOM, WMSZ_TOP:
+ m_ResizingType := rtVert;
+ else
+ begin
+ m_ResizingType := rtNo;
+ PRect(Msg.LParam).Left := Left;
+ PRect(Msg.LParam).Top := Top;
+ end;
+ end; // case
+end;
+
+
+procedure TChessBoard.FDoHandler(e: TChessBoardEvent; d1: pointer = nil; d2: pointer = nil);
+begin
+ if (Assigned(FHandler)) then
+ FHandler(e, d1, d2);
+end;
+
+
+function TChessBoard.FGetMoveNotationFormat: TMoveNotationFormat;
+begin
+ Result := m_ChessRulesEngine.MoveNotationFormat;
+end;
+
+
+procedure TChessBoard.FSetMoveNotationFormat(Value: TMoveNotationFormat);
+begin
+ m_ChessRulesEngine.MoveNotationFormat := Value;
+end;
+
+
+function TChessBoard.FGetFENFormat: boolean;
+begin
+ Result := m_ChessRulesEngine.FENFormat;
+end;
+
+
+procedure TChessBoard.FSetFENFormat(bValue: boolean);
+begin
+ m_ChessRulesEngine.FENFormat := bValue;
+end;
+
+
+procedure TChessBoard.BeginUpdate;
+begin
+ inc(m_iUpdateCounter);
+end;
+
+
+procedure TChessBoard.EndUpdate;
+begin
+ if (m_iUpdateCounter > 0) then
+ begin
+ dec(m_iUpdateCounter);
+ if (m_iUpdateCounter = 0) then
+ FDrawBoard;
+ end;
+end;
+
+
+procedure TChessBoard.FOnDrawLayerUpdate(const ADrawLayer: TChessBoardLayerBase);
+begin
+ if (not AnimateTimer.Enabled) then
+ FDrawBoard;
+end;
+
+
+procedure TChessBoard.AddLayer(const ALayer: TChessBoardLayerBase);
+begin
+ if (m_lstLayers.IndexOf(ALayer) >= 0) then
+ exit;
+
+ ALayer.ChessBoard := self;
+ m_lstLayers.Add(ALayer);
+
+ FOnDrawLayerUpdate(ALayer);
+end;
+
+
+procedure TChessBoard.RemoveLayer(const ALayer: TChessBoardLayerBase);
+begin
+ if (m_lstLayers.Remove(ALayer) >= 0) then
+ begin
+ ALayer.ChessBoard := nil;
+
+ FOnDrawLayerUpdate(ALayer);
+ end;
+end;
+
+
+function TChessBoard.IsMoveAnimating: boolean;
+begin
+ Result := AnimateTimer.Enabled;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TChessBoardDrawBase
+
+procedure TChessBoardLayerBase.RDoUpdate;
+begin
+ if (Assigned(m_ChessBoard)) then
+ m_ChessBoard.FOnDrawLayerUpdate(self);
+end;
+
+
+function TChessBoardLayerBase.FGetSquareSize: integer;
+begin
+ if (Assigned(m_ChessBoard)) then
+ Result := m_ChessBoard.SquareSize
+ else
+ Result := 0;
+end;
+
+
+function TChessBoardLayerBase.FGetCanvas: TCanvas;
+begin
+ if (Assigned(m_ChessBoard)) then
+ Result := m_ChessBoard.FGetHiddenBoardCanvas
+ else
+ Result := nil;
+end;
+
+
+function TChessBoardLayerBase.FGetPosition: PChessPosition;
+begin
+ if (Assigned(m_ChessBoard)) then
+ Result := m_ChessBoard.Position
+ else
+ Result := nil;
+end;
+
+
+function TChessBoardLayerBase.RGetColorStarts: TFigureColor;
+begin
+ if (Assigned(m_ChessBoard)) then
+ Result := m_ChessBoard.FGetColorStarts
+ else
+ Result := fcWhite;
+end;
+
+
+function TChessBoardLayerBase.FGetPositionsList: TList;
+begin
+ if (Assigned(m_ChessBoard)) then
+ Result := m_ChessBoard.PositionsList
+ else
+ Result := nil;
+end;
+
+
+procedure TChessBoardLayerBase.ROnAfterMoveDone;
+begin
+end;
+
+
+procedure TChessBoardLayerBase.ROnAfterSetPosition;
+begin
+end;
+
+
+procedure TChessBoardLayerBase.ROnAfterModeSet(const OldValue, NewValue: TMode);
+begin
+end;
+
+
+procedure TChessBoardLayerBase.ROnResetMoveList;
+begin
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ChessClockUnit.pas b/plugins/!NotAdopted/Chess4Net/ChessClockUnit.pas new file mode 100644 index 0000000000..9e587af9f2 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessClockUnit.pas @@ -0,0 +1,113 @@ +unit ChessClockUnit;
+
+interface
+
+type
+ TChessClock = class
+ public
+ class function IsZeitnot(const time: TDateTime): boolean;
+ class function ConvertToStr(const time: TDateTime): string;
+ class function ConvertToFullStr(const time: TDateTime;
+ bIncludeMSec: boolean = TRUE): string;
+ class function ConvertFromFullStr(const strTime: string): TDateTime;
+ end;
+
+implementation
+
+uses
+ SysUtils;
+
+const
+ FULL_TIME_FORMAT = 'h":"n":"s"."z';
+ HOUR_TIME_FORMAT = 'h":"nn":"ss';
+ MIN_TIME_FORMAT = 'n":"ss';
+ ZEITNOT_FORMAT = 's"."zzz';
+ ZEITNOT_BOARDER = 10; // sec. - zeitnot border
+
+////////////////////////////////////////////////////////////////////////////////
+// TChessClock
+
+class function TChessClock.IsZeitnot(const time: TDateTime): boolean;
+begin
+ Result := ((time > 0) and (time < EncodeTime(0, 0, ZEITNOT_BOARDER, 0)));
+end;
+
+
+class function TChessClock.ConvertToStr(const time: TDateTime): string;
+begin
+ LongTimeFormat := MIN_TIME_FORMAT;
+ if (time >= EncodeTime(1, 0, 0, 0)) then
+ LongTimeFormat := HOUR_TIME_FORMAT
+ else if (IsZeitnot(time)) then
+ LongTimeFormat := ZEITNOT_FORMAT;
+
+ Result := TimeToStr(time);
+end;
+
+
+class function TChessClock.ConvertToFullStr(const time: TDateTime;
+ bIncludeMSec: boolean = TRUE): string;
+begin
+ if (bIncludeMSec) then
+ LongTimeFormat := FULL_TIME_FORMAT
+ else
+ LongTimeFormat := HOUR_TIME_FORMAT;
+
+ Result := TimeToStr(time);
+end;
+
+
+class function TChessClock.ConvertFromFullStr(const strTime: string): TDateTime;
+
+ procedure NParse(strTime: string; out Hour, Min, Sec, MSec: Word);
+ const
+ TIME_DELIM = ':';
+ MSEC_DELIM = '.';
+ var
+ iPos: integer;
+ str: string;
+ begin
+ Hour := 0;
+ Min := 0;
+ Sec := 0;
+ MSec := 0;
+
+ iPos := LastDelimiter(MSEC_DELIM, strTime);
+ if (iPos > 0) then
+ begin
+ str := Copy(strTime, iPos + 1, MaxInt);
+ strTime := Copy(strTime, 1, iPos - 1);
+ MSec := StrToInt(str);
+ end;
+
+ strTime := TIME_DELIM + strTime;
+
+ iPos := LastDelimiter(TIME_DELIM, strTime);
+ if (iPos = 0) then
+ exit;
+ str := Copy(strTime, iPos + 1, MaxInt);
+ strTime := Copy(strTime, 1, iPos - 1);
+ Sec := StrToInt(str);
+
+ iPos := LastDelimiter(TIME_DELIM, strTime);
+ if (iPos = 0) then
+ exit;
+ str := Copy(strTime, iPos + 1, MaxInt);
+ strTime := Copy(strTime, 1, iPos - 1);
+ Min := StrToInt(str);
+
+ iPos := LastDelimiter(TIME_DELIM, strTime);
+ if (iPos = 0) then
+ exit;
+ str := Copy(strTime, iPos + 1, MaxInt);
+ Hour := StrToInt(str);
+ end;
+
+var
+ Hour, Min, Sec, MSec: Word;
+begin // .ConvertFromFullStr
+ NParse(strTime, Hour, Min, Sec, MSec);
+ Result := EncodeTime(Hour, Min, Sec, MSec);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ChessRulesEngine.pas b/plugins/!NotAdopted/Chess4Net/ChessRulesEngine.pas new file mode 100644 index 0000000000..466f7b9190 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessRulesEngine.pas @@ -0,0 +1,1481 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ChessRulesEngine;
+
+interface
+
+uses
+ Classes;
+
+type
+ TFigureName = (K, Q, R, B, N, P);
+ TFigure = (WK, WQ, WR, WB, WN, WP, ES,
+ BK, BQ, BR, BB, BN, BP); // ES - Empty Square
+ TFigureColor = (fcWhite, fcBlack);
+
+ TCastlingCapability = set of (
+ WhiteKingSide, WhiteQueenSide, BlackKingSide, BlackQueenSide);
+
+ PChessPosition = ^TChessPosition;
+ TChessPosition = object // Chess position
+ board: array[1..8, 1..8] of TFigure;
+ color: TFigureColor; // Who moves
+ castling: TCastlingCapability;
+ en_passant: 0..8; // possibility of e.p 0 - no e.p.
+ private
+ procedure FUpdateKingSideCastling(AColor: TFigureColor);
+ procedure FUpdateQueenSideCastling(AColor: TFigureColor);
+ public
+ function SetPiece(i, j: integer; APiece: TFigure): boolean;
+ end;
+
+ PMoveAbs = ^TMoveAbs;
+ TMoveAbs = record
+ i0, j0, i, j: byte;
+ prom_fig: TFigureName;
+ end;
+
+ IChessRulesEngineable = interface
+ function AskPromotionFigure(FigureColor: TFigureColor): TFigureName;
+ end;
+
+ TEvaluation = (evInGame, evMate, evStaleMate);
+
+ TMoveNotationFormat = (mnfCh4N, mnfCh4NEx); // TODO: mnfPGN
+
+ TChessRulesEngine = class
+ private
+ m_ChessRulesEngineable: IChessRulesEngineable;
+ m_Position: TChessPosition;
+ m_iMovesOffset: integer;
+ m_i0, m_j0: integer; // Previous position of piece
+ m_fig: TFigure; // Piece that moves
+ m_lastMove: TMoveAbs; // Last move done
+ m_strLastMoveStr: string; // last move in algebraic notation
+ m_MoveNotationFormat: TMoveNotationFormat;
+ m_bFENFormat: boolean;
+ m_lstPosition: TList;
+
+ function FGetPosition: PChessPosition;
+ function FAskPromotionFigure(FigureColor: TFigureColor): TFigureName;
+ procedure FAddPosMoveToList; // Add position and its move to the list
+ function FMove2Str(const pos: TChessPosition): string;
+
+ function FCheckMove(const chp: TChessPosition; var chp_res: TChessPosition;
+ i0, j0, i, j: integer; var prom_fig: TFigureName): boolean;
+
+ function FGetLastMove: PMoveAbs;
+ procedure FDeleteLastPositionFromPositionList;
+
+ function FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean;
+
+ class function FFieldUnderAttack(const pos: TChessPosition; i0,j0: integer): boolean;
+ class function FCheckCheck(const pos: TChessPosition): boolean;
+ function FCanMove(pos: TChessPosition): boolean;
+
+ procedure FSetMovesOffset(iValue: integer);
+
+ property i0: integer read m_i0 write m_i0;
+ property j0: integer read m_j0 write m_j0;
+ property fig: TFigure read m_fig write m_fig;
+
+ public
+ constructor Create(ChessRulesEngineable: IChessRulesEngineable = nil);
+ destructor Destroy; override;
+
+ function DoMove(move_str: string): boolean; overload;
+ function DoMove(i0, j0, i, j: integer; prom_fig: TFigureName = K): boolean; overload;
+ function TakeBack: boolean;
+ function SetPosition(strValue: string): boolean;
+ function GetPosition: string;
+ function GetColorStarts: TFigureColor;
+ procedure InitNewGame;
+ procedure InitNewPPRandomGame;
+ procedure ResetMoveList; // Clears positions list
+ function NMovesDone: integer; // amount of moves done
+ function NPlysDone: integer; // amount of plys done
+ function GetFENMoveNumber: integer;
+ function GetEvaluation: TEvaluation;
+
+ property Position: PChessPosition read FGetPosition;
+ property lastMove: PMoveAbs read FGetLastMove;
+ property lastMoveStr: string read m_strLastMoveStr;
+ property MovesOffset: integer read m_iMovesOffset write FSetMovesOffset;
+ property PositionsList: TList read m_lstPosition;
+ property MoveNotationFormat: TMoveNotationFormat
+ read m_MoveNotationFormat write m_MoveNotationFormat;
+ property FENFormat: boolean read m_bFENFormat write m_bFENFormat;
+ end;
+
+ PPosMove = ^TPosMove;
+ TPosMove = record
+ pos: TChessPosition;
+ move: TMoveAbs;
+ end;
+
+const
+ INITIAL_CHESS_POSITION = 'rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -';
+ EMPTY_CHESS_POSITION = '8/8/8/8/8/8/8/8 w - -';
+ INITIAL_FEN = 'rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1';
+ EMPTY_FEN = '8/8/8/8/8/8/8/8 w - - 0 1';
+
+implementation
+
+{$J+}
+
+uses
+ SysUtils, StrUtils;
+
+type
+ TDeltaMove = array [TFigureName] of
+ record
+ longRange: boolean;
+ dx,dy: array[1..8] of Integer;
+ end;
+
+const
+ DELTA_MOVE: TDeltaMove = ((longRange: FALSE; // Êîðîëü
+ dx: (1,0,-1,0, 1,-1,-1,1); dy: (0,1,0,-1, 1,1,-1,-1)),
+ (longRange: TRUE; // Ôåðçü
+ dx: (1,0,-1,0, 1,-1,-1,1); dy: (0,1,0,-1, 1,1,-1,-1)),
+ (longRange: TRUE; // Ëàäüÿ
+ dx: (1,0,-1,0, 0,0,0,0); dy: (0,1,0,-1, 0,0,0,0)),
+ (longRange: TRUE; // Ñëîí
+ dx: (1,-1,-1,1, 0,0,0,0); dy: (1,1,-1,-1, 0,0,0,0)),
+ (longRange: FALSE; // Êîíü
+ dx: (2,1,-1,-2, 2,1,-1,-2); dy: (1,2,2,1, -1,-2,-2,-1)),
+ (longRange: FALSE; // Ïåøêà
+ dx: (0,0,-1,1, 0,0,0,0); dy: (2,1,1,1, 0,0,0,0)));
+
+////////////////////////////////////////////////////////////////////////////////
+// TChessRulesEngine
+
+constructor TChessRulesEngine.Create(ChessRulesEngineable: IChessRulesEngineable = nil);
+begin
+ inherited Create;
+
+ m_ChessRulesEngineable := ChessRulesEngineable;
+ m_lstPosition := TList.Create;
+
+ InitNewGame;
+end;
+
+
+destructor TChessRulesEngine.Destroy;
+begin
+ ResetMoveList;
+ m_lstPosition.Free;
+
+ inherited;
+end;
+
+
+function TChessRulesEngine.FGetPosition: PChessPosition;
+begin
+ Result := @m_Position;
+end;
+
+
+function TChessRulesEngine.FAskPromotionFigure(FigureColor: TFigureColor): TFigureName;
+begin
+ if (Assigned(m_ChessRulesEngineable)) then
+ Result := m_ChessRulesEngineable.AskPromotionFigure(FigureColor)
+ else
+ Result := Q;
+end;
+
+
+class function TChessRulesEngine.FCheckCheck(const pos: TChessPosition): boolean;
+label
+ l;
+const
+ _i0: integer = 1; // äëÿ óâåëè÷åíèÿ ñêîðîñòè îáðàáîòêè
+ _j0: integer = 1;
+var
+ i, j: integer;
+begin
+ with pos do
+ begin
+ if ((color = fcWhite) and (board[_i0, _j0] = WK)) or
+ ((color = fcBlack) and (board[_i0, _j0] = BK)) then goto l;
+ // ïîèñê êîðîëÿ íà äîñêå
+ for i:= 1 to 8 do
+ begin
+ for j:= 1 to 8 do
+ begin
+ if ((color = fcWhite) and (board[i,j] = WK)) or
+ ((color = fcBlack) and (board[i,j] = BK)) then
+ begin
+ _i0 := i;
+ _j0 := j;
+ goto l;
+ end;
+ end; // for j
+ end; // for i
+l:
+ Result := FFieldUnderAttack(pos, _i0, _j0);
+ end;
+end;
+
+
+class function TChessRulesEngine.FFieldUnderAttack(const pos: TChessPosition; i0, j0: integer): boolean;
+var
+ f: TFigureName;
+ ef: TFigure;
+ l: byte;
+ ti,tj: Integer;
+ locLongRange: boolean;
+begin
+ for f:= R to N do
+ for l:= 1 to 8 do
+ with DELTA_MOVE[f], pos do
+ begin
+ if (dx[l] = 0) and (dy[l] = 0) then break; // Âñå õîäû ïðîñìîòðåíû
+ ti:= i0; tj:= j0;
+ locLongRange:= FALSE;
+ repeat
+ ti:= ti + dx[l]; tj:= tj + dy[l];
+ if not(ti in [1..8]) or not(tj in [1..8]) then break;
+ ef:= board[ti,tj];
+ if ((color = fcWhite) and (ef < ES)) or ((color = fcBlack) and (ef > ES))
+ then break;
+ case ef of
+ WK,BK:
+ if locLongRange or (f = N) then break;
+ WQ,BQ:
+ if f = N then break;
+ WR,BR:
+ if f <> R then break;
+ WB,BB:
+ if f <> B then break;
+ WN,BN:
+ if f <> N then break;
+ WP,BP:
+ if locLongRange or (f <> B) or
+ ((color = fcWhite) and not(tj > j0)) or
+ ((color = fcBlack) and not(tj < j0))
+ then break;
+ ES:
+ begin
+ locLongRange:= TRUE;
+ continue;
+ end;
+ end;
+ Result:= TRUE;
+ exit;
+ until (not longRange);
+ end;
+
+ Result := FALSE;
+end;
+
+
+function TChessRulesEngine.FCheckMove(const chp: TChessPosition; var chp_res: TChessPosition;
+ i0, j0, i, j: integer; var prom_fig: TFigureName): boolean;
+label
+ here;
+var
+ ti,tj: integer;
+ l: byte;
+ f: TFigureName;
+ _fig: TFigure;
+ pos: TChessPosition;
+begin
+ Result := FALSE;
+
+ if (not ((i0 in [1..8]) and (j0 in [1..8]) and
+ (i in [1..8]) and (j in [1..8]))) then
+ exit;
+
+ _fig := chp.board[i0, j0];
+ if (((chp.color = fcWhite) and (_fig > ES)) or
+ ((chp.color = fcBlack) and (_fig < ES))) then
+ exit;
+
+ f := TFigureName(ord(_fig) - ord(chp.color) * ord(BK));
+
+ for l := 1 to 8 do
+ with DELTA_MOVE[f], chp do
+ begin
+ if (dx[l] = 0) and (dy[l] = 0) then
+ break; // All moves have been viewed
+
+ ti := i0;
+ tj := j0;
+
+ case f of
+ P:
+ begin
+ if ((l = 1) and
+ (not (((color = fcWhite) and (j0 = 2) and (board[i0,3] = ES)) or
+ ((color = fcBlack) and (j0 = 7) and (board[i0,6] = ES))))) then
+ continue; // Pawn is not on 2/7 row - long move is impossible
+
+ case color of
+ fcWhite:
+ begin
+ inc(ti, dx[l]);
+ inc(tj, dy[l]);
+ end;
+
+ fcBlack:
+ begin
+ dec(ti, dx[l]);
+ dec(tj, dy[l]);
+ end;
+ end;
+
+ if (not (ti in [1..8]) or not(tj in [1..8])) then
+ continue;
+ if ((l <= 2) and (board[ti,tj] <> ES)) then
+ continue; // There's a piece before the pawn -> exit
+
+ if ((l >= 3) and (not (((color = fcWhite) and ((board[ti,tj] > ES) or
+ ((j0 = 5) and (en_passant = ti)))) or
+ ((color = fcBlack) and ((board[ti,tj] < ES) or
+ ((j0 = 4) and (en_passant = ti))))))) then
+ continue;
+
+ if ((ti = i) and (tj = j)) then
+ goto here;
+ end;
+
+ else
+ begin
+ repeat
+ inc(ti, dx[l]);
+ inc(tj, dy[l]);
+
+ if ((not (ti in [1..8])) or (not (tj in [1..8])) or
+ ((color = fcWhite) and ((board[ti,tj] < ES) or
+ ((board[ti,tj] > ES) and ((ti <> i) or (tj <> j))))) or
+ ((color = fcBlack) and ((board[ti,tj] > ES) or
+ ((board[ti,tj] < ES) and ((ti <> i) or (tj <> j)))))) then
+ break;
+
+ if ((ti = i) and (tj = j)) then
+ goto here;
+
+ until (not longRange);
+ end;
+
+ end; { case }
+ end;
+
+ if (f = K) then // Checking against castling
+ begin
+ with chp do
+ begin
+ if (i-i0 = 2) and (j = j0) and
+ (((color = fcWhite) and (WhiteKingSide in castling)) or
+ ((color = fcBlack) and (BlackKingSide in castling))) then
+ begin
+ if ((board[6,j0] <> ES) or (board[7,j0] <> ES) or // 0-0
+ FFieldUnderAttack(chp,5,j0) or
+ FFieldUnderAttack(chp,6,j0)) then exit;
+ end
+ else if ((i-i0 = -2) and (j = j0) and
+ (((color = fcWhite) and (WhiteQueenSide in castling)) or
+ ((color = fcBlack) and (BlackQueenSide in castling)))) then
+ begin
+ if ((board[4,j0] <> ES) or (board[3,j0] <> ES) or // 0-0-0
+ (board[2,j0] <> ES) or
+ FFieldUnderAttack(chp,5,j0) or
+ FFieldUnderAttack(chp,4,j0)) then
+ exit;
+ end
+ else
+ exit;
+
+ goto here;
+ end;
+ end;
+
+ exit; // The piece was moved not according to rules
+
+here:
+ // Making move on pos
+ pos := chp;
+
+ with pos do
+ begin
+ case f of
+ P:
+ begin
+ if (((color = fcWhite) and (j0 = 5)) or
+ ((color = fcBlack) and (j0 = 4))) and (i = en_passant) then
+ board[i,j0]:= ES; // remove enemy pawn with e.p.
+ end;
+
+ K:
+ begin
+ if i-i0 = 2 then
+ begin
+ board[6,j0]:= board[8,j0]; // 0-0
+ board[8,j0]:= ES;
+ end
+ else
+ if i0-i = 2 then
+ begin
+ board[4,j0]:= board[1,j0]; // 0-0-0
+ board[1,j0]:= ES;
+ end;
+ case color of
+ fcWhite:
+ castling:= castling - [WhiteKingSide, WhiteQueenSide];
+ fcBlack:
+ castling:= castling - [BlackKingSide, BlackQueenSide];
+ end;
+ end;
+
+ R:
+ begin
+ if ((i0 = 8) and (j0 = 1)) or ((i = 8) and (j = 1)) then
+ castling := castling - [WhiteKingSide]
+ else if ((i0 = 1) and (j0 = 1)) or ((i = 1) and (j = 1)) then
+ castling := castling - [WhiteQueenSide]
+ else if ((i0 = 8) and (j0 = 8)) or ((i = 8) and (j = 8)) then
+ castling := castling - [BlackKingSide]
+ else if ((i0 = 1) and (j0 = 8)) or ((i = 1) and (j = 8)) then
+ castling := castling - [BlackQueenSide];
+ end;
+ end;
+
+ if ((f = P) and (abs(j-j0) = 2) and
+ (((i > 1) and (((color = fcWhite) and (board[i-1,j] = BP)) or
+ ((color = fcBlack) and (board[i-1,j] = WP)))) or
+ ((i < 8) and (((color = fcWhite) and (board[i+1,j] = BP)) or
+ ((color = fcBlack) and (board[i+1,j] = WP)))))) then
+ en_passant := i0 // e.p. on
+ else
+ en_passant := 0; // e.p. off
+
+ // make the move
+
+ board[i0, j0]:= ES;
+ board[i, j] := _fig;
+
+ if (FCheckCheck(pos)) then
+ exit; // move is impossible because of check
+
+ if (f = P) and ((j = 1) or (j = 8)) then
+ begin
+ case prom_fig of
+ Q..N: ;
+ else
+ prom_fig := FAskPromotionFigure(pos.color);
+ end; // case
+ board[i, j] := TFigure(ord(color) * ord(BK) + ord(prom_fig));
+ end;
+
+ if (color = fcWhite) then
+ color := fcBlack
+ else
+ color := fcWhite;
+ end; // with
+
+ chp_res := pos;
+
+ Result:= TRUE;
+end;
+
+
+function TChessRulesEngine.FCanMove(pos: TChessPosition): boolean;
+var
+ i,j: integer;
+ ti,tj: integer;
+ l: byte;
+ f: TFigureName;
+ prom_fig: TFigureName;
+begin
+ with pos do
+ for i:= 1 to 8 do
+ for j:= 1 to 8 do
+ begin
+ if ((color = fcWhite) and (board[i,j] >= ES)) or
+ ((color = fcBlack) and (board[i,j] <= ES)) then continue;
+
+ f:= TFigureName(ord(board[i,j]) - ord(color) * ord(BK));
+ for l:= 1 to 8 do
+ with DELTA_MOVE[f] do
+ begin
+ if (dx[l] = 0) and (dy[l] = 0) then break; // Âñå õîäû ïðîñìîòðåíû
+ ti:= i; tj:= j;
+ repeat
+ case color of
+ fcWhite:
+ begin
+ ti:= ti + dx[l]; tj:= tj + dy[l];
+ end;
+ fcBlack:
+ begin
+ ti:= ti - dx[l]; tj:= tj - dy[l];
+ end;
+ end;
+ if not ((ti in [1..8]) and (tj in [1..8])) then break;
+ prom_fig := Q;
+ if FCheckMove(pos, pos, i, j, ti, tj, prom_fig) then
+ begin
+ Result:= TRUE;
+ exit;
+ end;
+ until not longRange;
+ end;
+ end;
+
+ Result := FALSE;
+end;
+
+
+function TChessRulesEngine.DoMove(move_str: string): boolean;
+label
+ l1;
+var
+ l: byte;
+ f, prom_f: TFigureName;
+ i, j: integer;
+ ti, tj: integer;
+ saved_i, saved_j: integer;
+begin
+ Result := FALSE;
+
+ l := length(move_str);
+ if ((l <= 1)) then // at least two characters
+ exit;
+
+ if ((move_str[l] in ['+', '#'])) then
+ move_str := LeftStr(move_str, l - 1);
+
+ // Ïðîâåðêà íà ðîêèðîâêó
+ if (move_str = '0-0') then
+ begin
+ if (Position.color = fcWhite) then
+ move_str:= 'Ke1g1'
+ else
+ move_str:= 'Ke8g8'
+ end
+ else if (move_str = '0-0-0') then
+ begin
+ if (Position.color = fcWhite) then
+ move_str:= 'Ke1c1'
+ else
+ move_str:= 'Ke8c8';
+ end;
+
+ l := length(move_str);
+
+ i0 := 0;
+ j0 := 0;
+ i := 0;
+ j := 0;
+
+ prom_f := K;
+ case move_str[l] of
+ 'Q': prom_f := Q;
+ 'R': prom_f := R;
+ 'B': prom_f := B;
+ 'N': prom_f := N;
+ else
+ inc(l);
+ end;
+
+ dec(l);
+
+ if move_str[l] in ['1'..'8'] then
+ begin
+ j := StrToInt(move_str[l]);
+ dec(l);
+ end;
+ if move_str[l] in ['a'..'h'] then
+ begin
+ i := ord(move_str[l]) - ord('a') + 1;
+ dec(l);
+ end;
+ if (l > 0) and (move_str[l] in ['1'..'8']) then
+ begin
+ j0 := StrToInt(move_str[l]);
+ dec(l);
+ end;
+ if (l > 0) and (move_str[l] in ['a'..'h']) then
+ begin
+ i0 := ord(move_str[l]) - ord('a') + 1;
+ dec(l);
+ end;
+
+ if (l = 0) then
+ f := P
+ else
+ begin
+ case move_str[l] of
+ 'K': f:= K;
+ 'Q': f:= Q;
+ 'R': f:= R;
+ 'B': f:= B;
+ 'N': f:= N;
+ end;
+ end;
+
+ with m_Position do
+ begin
+ fig := TFigure(ord(f) + ord(Position.color) * ord(BK));
+
+ case f of
+ K..N: // Õîä Êð - Ê
+ begin
+ if ((i0 > 0) and (j0 > 0)) then
+ begin
+ Result := FDoMove(i, j, prom_f);
+ exit;
+ end;
+
+ for l := 1 to 8 do
+ begin
+ with DELTA_MOVE[f] do
+ begin
+ if (dx[l] = 0) and (dy[l] = 0) then break; // Âñå õîäû ïðîñìîòðåíû
+ ti:= i;
+ tj:= j;
+ repeat
+ ti:= ti + dx[l];
+ tj:= tj + dy[l];
+ if not ((ti in [1..8]) and (tj in [1..8])) or
+ ((board[ti,tj] <> ES) and (board[ti,tj] <> fig)) then
+ break;
+
+ if ((i0 = 0) or (i0 = ti)) and ((j0 = 0) or (j0 = tj)) and
+ (board[ti, tj] = fig) then
+ begin // Õîäÿùàÿ ôèãóðà íàéäåíà
+ saved_i := i0;
+ saved_j := j0;
+
+ i0 := ti;
+ j0 := tj;
+ Result := FDoMove(i, j, prom_f);
+ if (Result) then
+ exit;
+
+ i0 := saved_i;
+ j0 := saved_j;
+ end;
+ until (f = K) or (f = N); // Åñëè Êð èëè Ê, òî âûõîä
+ end; // with
+ end; // for
+ end; // K..N
+
+ P: // Õîä ïåøêîé
+ begin
+ if (i0 <> 0) and (i0 <> i) then // âçÿòèå ïåøêîé
+ begin
+ for l := 2 to 7 do
+ begin
+ if (board[i0, l] = fig) and ((j0 = 0) or (j0 = l)) then
+ begin
+ if color = fcWhite then
+ begin
+ if ((board[i, l + 1] > ES) or
+ ((l = 5) and (en_passant = i))) and
+ ((j = 0) or (j = l+1)) and (abs(i - i0) = 1) then
+ begin
+ j0 := l;
+ j := l + 1;
+ Result := FDoMove(i, j, prom_f);
+ if (Result) then
+ exit;
+ end;
+ end
+ else // color = fcBlack
+ if ((board[i,l - 1] < ES) or
+ ((l = 4) and (en_passant = i))) and
+ ((j = 0) or (j = l-1)) and (abs(i - i0) = 1) then
+ begin
+ j0 := l;
+ j := l - 1;
+ Result := FDoMove(i, j, prom_f);
+ if (Result) then
+ exit;
+ end;
+ end; // if
+ end; // for
+ end
+ else // Õîä ïðÿìî
+ begin
+ i0 := i;
+ if color = fcWhite then
+ begin
+ if board[i, j - 1] = fig then
+ j0 := j - 1
+ else if (j = 4) and (board[i, 3] = ES) and
+ (board[i,2] = fig) then
+ j0 := 2;
+ end
+ else // color = fcBlack
+ begin
+ if (board[i, j + 1] = fig) then
+ j0 := j + 1
+ else if (j = 5) and (board[i,6] = ES) and (board[i, 7] = fig) then
+ j0 := 7;
+ end;
+
+ Result := FDoMove(i, j, prom_f);
+ end; // if
+ end; // P:
+
+ end; // case
+ end;
+end;
+
+
+function TChessRulesEngine.FDoMove(i, j: integer; prom_fig: TFigureName = K): boolean;
+var
+ newPosition: TChessPosition;
+begin
+ Result := FCheckMove(m_Position, newPosition, i0, j0, i, j, prom_fig);
+ if (Result) then
+ begin
+ // Store the move done
+ lastMove.i0 := i0;
+ lastMove.j0 := j0;
+ lastMove.i := i;
+ lastMove.j := j;
+ lastMove.prom_fig := prom_fig;
+
+ FAddPosMoveToList;
+
+ m_strLastMoveStr := FMove2Str(newPosition);
+
+ m_Position := newPosition;
+ end;
+end;
+
+
+function TChessRulesEngine.DoMove(i0, j0, i, j: integer; prom_fig: TFigureName = K): boolean;
+begin
+ self.i0 := i0;
+ self.j0 := j0;
+ Result := FDoMove(i, j, prom_fig);
+end;
+
+
+function TChessRulesEngine.FGetLastMove: PMoveAbs;
+begin
+ Result := @m_lastMove;
+end;
+
+
+procedure TChessRulesEngine.FAddPosMoveToList;
+var
+ pm: PPosMove;
+begin
+ new(pm);
+ pm.pos := m_Position;
+ pm.move := lastMove^;
+ PositionsList.Add(pm);
+end;
+
+
+function TChessRulesEngine.FMove2Str(const pos: TChessPosition): string;
+
+ procedure NExtendWithCheckOrMate(var strMove: string);
+ begin
+ if (strMove = '') then
+ exit;
+
+ if (FCheckCheck(pos)) then
+ begin
+ if (FCanMove(pos)) then
+ strMove := strMove + '+'
+ else
+ strMove := strMove + '#';
+ end;
+ end;
+
+var
+ f: TFigureName;
+ l: byte;
+ ti, tj: integer;
+ ambig, hor, ver: boolean;
+ _fig: TFigure;
+ DummyPosition: TChessPosition;
+begin // .FMove2Str
+ if (lastMove.i0 = 0) then // No move
+ begin
+ Result:= '';
+ exit;
+ end;
+
+ _fig := Position.board[lastMove.i0, lastMove.j0];
+ f := TFigureName(ord(_fig) + (ord(pos.color) - 1) * ord(BK));
+
+ // Pawn moves
+ if (f = P) then
+ begin
+ with pos do
+ begin
+ if ((lastMove.i - lastMove.i0) = 0) then // move
+ Result := chr(ord('a') + lastMove.i - 1) + IntToStr(lastMove.j)
+ else // capturing
+ begin
+ Result := chr(ord('a') + lastMove.i0 - 1) + chr(ord('a') + lastMove.i - 1);
+
+ for l := 2 to 7 do // Checking against ambiguity of capturing
+ begin
+ if (board[lastMove.i0, l] = WP) then
+ tj := l + 1
+ else if (board[lastMove.i0, l] = BP) then
+ tj := l - 1
+ else
+ continue;
+
+ if ((((tj > l) and ((Position.board[lastMove.i, tj] > ES) or
+ ((Position.en_passant = lastMove.i) and (l = 5)))) and (color = fcBlack)) or
+ (((tj < l) and ((Position.board[lastMove.i, tj] < ES) or
+ ((Position.en_passant = lastMove.i) and (l = 4)))) and (color = fcWhite))) then
+ begin
+ if ((MoveNotationFormat <> mnfCh4NEx) or
+ FCheckMove(m_Position, DummyPosition, lastMove.i0, l, lastMove.i, tj,
+ lastMove.prom_fig)) then
+ begin
+ Result := Result + IntToStr(lastMove.j);
+ end;
+ end;
+
+ end;
+ end;
+
+ if (lastMove.j = 8) or (lastMove.j = 1) then // The pawn has been promoted
+ begin
+ case board[lastMove.i,lastMove.j] of
+ WQ,BQ: Result := Result + 'Q';
+ WR,BR: Result := Result + 'R';
+ WB,BB: Result := Result + 'B';
+ WN,BN: Result := Result + 'N';
+ end;
+ end;
+
+ if (m_MoveNotationFormat = mnfCh4NEx) then
+ NExtendWithCheckOrMate(Result);
+
+ exit;
+
+ end; // with
+ end; // if
+
+ // <Piece>
+ case f of
+ K: Result:= 'K';
+ Q: Result:= 'Q';
+ R: Result:= 'R';
+ B: Result:= 'B';
+ N: Result:= 'N';
+ end;
+
+ // [<Line>][<Row>]
+ ambig:= FALSE;
+ hor:= FALSE;
+ ver:= FALSE;
+
+ for l := 1 to 8 do
+ begin
+ with pos, DELTA_MOVE[f] do
+ begin
+ if (dx[l] = 0) and (dy[l] = 0) then
+ break; // All moves have been viewed
+
+ ti := lastMove.i;
+ tj := lastMove.j;
+
+ repeat
+ inc(ti, dx[l]);
+ inc(tj, dy[l]);
+
+ if ((not (ti in [1..8])) or (not (tj in [1..8]))) then
+ break;
+
+ if (board[ti,tj] = ES) then
+ continue;
+
+ if (board[ti, tj] <> _fig) then
+ break;
+
+ if ((m_MoveNotationFormat <> mnfCh4NEx) or
+ FCheckMove(m_Position, DummyPosition, ti, tj, lastMove.i, lastMove.j,
+ lastMove.prom_fig)) then
+ begin
+ ambig := TRUE;
+ ver := (ver or (ti = lastMove.i0));
+ hor := (hor or (tj = lastMove.j0));
+
+ break;
+ end;
+
+ until (f = K) or (f = N); // If K or N -> exit
+
+ end;
+ end; // for l
+
+ if (ambig) then
+ begin
+ if ((not ver) or hor) then
+ Result := Result + chr(ord('a') + lastMove.i0 - 1);
+ if (ver) then
+ Result := Result + IntToStr(lastMove.j0);
+ end;
+
+ // <Destination field>
+ Result := Result + chr(ord('a') + lastMove.i - 1) + IntToStr(lastMove.j);
+
+ // <Short castling> | <Long castling>
+ if (f = K) then
+ begin
+ if ((lastMove.i - lastMove.i0) = 2) then
+ Result := '0-0'
+ else if (lastMove.i0 - lastMove.i = 2) then
+ Result := '0-0-0';
+ end;
+
+ if (m_MoveNotationFormat = mnfCh4NEx) then
+ NExtendWithCheckOrMate(Result);
+end;
+
+
+function TChessRulesEngine.TakeBack: boolean;
+begin
+ Result := (PositionsList.Count > 0);
+ if (Result) then
+ begin
+ FDeleteLastPositionFromPositionList;
+ lastMove.i0 := 0;
+ end;
+end;
+
+
+procedure TChessRulesEngine.FDeleteLastPositionFromPositionList;
+var
+ i: integer;
+begin
+ i := PositionsList.Count - 1;
+ if (i >= 0) then
+ begin
+ m_Position := PPosMove(PositionsList[i]).pos;
+ Dispose(PositionsList[i]);
+ PositionsList.Delete(i);
+ end;
+end;
+
+
+function TChessRulesEngine.SetPosition(strValue: string): boolean;
+
+ function NNextToken(var str: string): string;
+ var
+ iPos: integer;
+ begin
+ str := TrimLeft(str);
+ if (str = '') then
+ Result := ''
+ else
+ begin
+ iPos := Pos(' ', str);
+ if (iPos > 0) then
+ begin
+ Result := LeftStr(str, Pred(iPos));
+ str := Copy(str, iPos, MaxInt);
+ end
+ else
+ begin
+ Result := str;
+ str := '';
+ end;
+ end;
+ end;
+
+var
+ pos: TChessPosition;
+
+ function NSetPlacingOfPieces: boolean;
+ var
+ strPos: string;
+ iPos: integer;
+ j, i, k: integer;
+ begin
+ Result := FALSE;
+
+ strPos := NNextToken(strValue);
+
+ iPos := 1;
+
+ for j := 8 downto 1 do
+ begin
+ i := 1;
+ repeat
+ if (iPos > Length(strPos)) then
+ exit;
+
+ case strPos[iPos] of
+ 'K': pos.board[i,j]:= WK;
+ 'Q': pos.board[i,j]:= WQ;
+ 'R': pos.board[i,j]:= WR;
+ 'B': pos.board[i,j]:= WB;
+ 'N': pos.board[i,j]:= WN;
+ 'P': pos.board[i,j]:= WP;
+
+ 'k': pos.board[i,j]:= BK;
+ 'q': pos.board[i,j]:= BQ;
+ 'r': pos.board[i,j]:= BR;
+ 'b': pos.board[i,j]:= BB;
+ 'n': pos.board[i,j]:= BN;
+ 'p': pos.board[i,j]:= BP;
+
+ '1'..'8': // Insert empty fields
+ begin
+ k := StrToInt(strPos[iPos]);
+ repeat
+ pos.board[i,j]:= ES;
+ dec(k); inc(i);
+ until k = 0;
+ dec(i);
+ end;
+
+ ' ': break; // Position is read -> exit from loop
+
+ else
+ exit; // Error in strPos
+ end;
+
+ inc(i);
+ inc(iPos);
+
+ until ((i > 8) or (strPos[iPos] = '/')); // Repeat until '/' or if not on the row
+
+ inc(iPos);
+
+ end; // for j
+
+ Result := TRUE;
+ end;
+
+var
+ i: integer;
+ iMovesOffset: integer;
+ strToken: string;
+begin // .SetPosition
+ Result := NSetPlacingOfPieces;
+ if (not Result) then
+ exit;
+
+ // Defaults
+ pos.color := fcWhite;
+ pos.castling := [];
+ pos.en_passant := 0;
+ iMovesOffset := 0;
+
+ try
+ strToken := NNextToken(strValue);
+ if (strToken = '') then
+ exit;
+
+ case strToken[1] of
+ 'w':
+ pos.color := fcWhite;
+ 'b':
+ pos.color := fcBlack;
+ else
+ exit;
+ end;
+
+ strToken := NNextToken(strValue);
+ if (strToken = '') then
+ exit;
+
+ for i := 1 to Length(strToken) do
+ begin
+ with pos do
+ begin
+ case strToken[i] of
+ 'K':
+ Include(castling, WhiteKingSide);
+ 'Q':
+ Include(castling, WhiteQueenSide);
+ 'k':
+ Include(castling, BlackKingSide);
+ 'q':
+ Include(castling, BlackQueenSide);
+ '-':
+ castling := [];
+ else
+ exit;
+ end;
+ end;
+
+ end; // for
+
+ strToken := NNextToken(strValue);
+ if (strToken = '') then
+ exit;
+
+ with pos do
+ begin
+ case strToken[1] of
+ 'a'..'h':
+ en_passant := ord(strToken[1]) - ord('a') + 1;
+ end;
+ end;
+
+ strToken := NNextToken(strValue);
+ if (strToken = '') then
+ exit;
+
+ // Skip 50-moves counter
+
+ strToken := NNextToken(strValue);
+ if (strToken = '') then
+ exit;
+
+ iMovesOffset := StrToIntDef(strToken, 1) - 1;
+ if (iMovesOffset < 0) then
+ iMovesOffset := 0;
+
+ finally
+ ResetMoveList;
+ m_Position := pos;
+ m_iMovesOffset := iMovesOffset;
+ end;
+
+end;
+
+
+procedure TChessRulesEngine.InitNewGame;
+var
+ bRes: boolean;
+begin
+ bRes := SetPosition(INITIAL_CHESS_POSITION);
+ Assert(bRes);
+end;
+
+
+procedure TChessRulesEngine.ResetMoveList;
+var
+ i: integer;
+begin
+ for i := 0 to PositionsList.Count - 1 do
+ Dispose(PositionsList[i]);
+ PositionsList.Clear;
+
+ lastMove.i0 := 0;
+end;
+
+
+function TChessRulesEngine.GetPosition: string;
+
+ function NGetPlacingOfPieces: string;
+ var
+ i, j: Integer;
+ k: byte;
+ chFig: char;
+ begin
+ Result := '';
+
+ // Placing of pieces
+ for j := 8 downto 1 do
+ begin
+ k := 0;
+
+ for i := 1 to 8 do
+ begin
+ case Position.board[i, j] of
+ WK: chFig := 'K';
+ WQ: chFig := 'Q';
+ WR: chFig := 'R';
+ WB: chFig := 'B';
+ WN: chFig := 'N';
+ WP: chFig := 'P';
+ BK: chFig := 'k';
+ BQ: chFig := 'q';
+ BR: chFig := 'r';
+ BB: chFig := 'b';
+ BN: chFig := 'n';
+ BP: chFig := 'p';
+ ES:
+ begin
+ inc(k);
+ continue;
+ end;
+ end;
+
+ if (k > 0) then
+ begin
+ Result := Result + IntToStr(k);
+ k := 0;
+ end;
+
+ Result := Result + chFig;
+ end; // for i
+
+ if (k > 0) then
+ Result := Result + IntToStr(k);
+ if (j = 1) then
+ Result := Result + ' '
+ else
+ Result := Result + '/'; // i <= 7
+ end; // for j
+
+ end;
+
+begin // .GetPosition
+ Result := NGetPlacingOfPieces;
+
+ if (Position.color = fcWhite) then
+ Result := Result + 'w '
+ else
+ Result := Result + 'b '; // color = fcBlack
+
+ // Castling
+ if (Position.castling = []) then
+ Result := Result + '-'
+ else
+ begin
+ if (WhiteKingSide in Position.castling) then
+ Result := Result + 'K';
+ if (WhiteQueenSide in Position.castling) then
+ Result := Result + 'Q';
+ if (BlackKingSide in Position.castling) then
+ Result := Result + 'k';
+ if (BlackQueenSide in Position.castling) then
+ Result := Result + 'q';
+ end;
+
+ // en-passant
+ if (Position.en_passant = 0) then
+ Result := Result + ' -'
+ else
+ begin
+ Result := Result + ' ' + Chr(Ord('a') - 1 + Position.en_passant);
+ end;
+
+ if (not FENFormat) then
+ exit;
+
+ if (Position.en_passant <> 0) then
+ begin
+ if (Position.color = fcWhite) then
+ Result := Result + '6'
+ else
+ Result := Result + '3'; // Black
+ end;
+
+ Result := Result + ' 0'; // TODO: 50-moves rule
+
+ Result := Result + ' ' + IntToStr(GetFENMoveNumber);
+end;
+
+
+function TChessRulesEngine.GetFENMoveNumber: integer;
+begin
+ Result := NMovesDone;
+ if ((m_Position.color = fcWhite) or (Result = 0)) then
+ inc(Result);
+end;
+
+
+procedure TChessRulesEngine.FSetMovesOffset(iValue: integer);
+begin
+ Assert(iValue >= 0);
+ m_iMovesOffset := iValue;
+end;
+
+
+procedure TChessRulesEngine.InitNewPPRandomGame;
+const
+ FIG: array[0..5] of TFigureName = (B, B, Q, R, N, N);
+ SQR: array[0..5] of byte = (2, 3, 4, 6, 7, 0);
+var
+ rnd_sqr: array[0..5] of byte;
+ i,j: integer;
+ f: boolean;
+begin
+ InitNewGame;
+
+ if (Random(2) = 0) then
+ SQR[5] := 1 // ñ êàêîé ñòîðîíû îñòàâëÿåì ëàäüþ
+ else
+ SQR[5] := 8;
+
+ for i := 0 to 5 do
+ begin
+ repeat
+ rnd_sqr[i] := SQR[Random(6)];
+ f := FALSE;
+ for j := 0 to i-1 do f := f or (rnd_sqr[i] = rnd_sqr[j]);
+ until not (f or ((i = 1) and (((rnd_sqr[0] xor rnd_sqr[1]) and 1) = 0)));
+ m_Position.board[rnd_sqr[i], 1] := TFigure(ord(FIG[i]));
+ m_Position.board[rnd_sqr[i], 8] := TFigure(ord(BK) + ord(FIG[i]));
+ end;
+end;
+
+
+function TChessRulesEngine.NMovesDone: integer;
+var
+ iMovesCount: integer;
+begin
+ if ((PositionsList.Count = 0) and (m_iMovesOffset = 0)) then
+ iMovesCount := 0
+ else
+ begin
+ if (GetColorStarts = fcWhite) then
+ iMovesCount := ((PositionsList.Count + 1) div 2)
+ else // GetColorStarts = fcBlack
+ iMovesCount := ((PositionsList.Count + 2) div 2);
+ end;
+
+ Result := m_iMovesOffset + iMovesCount;
+end;
+
+
+function TChessRulesEngine.GetColorStarts: TFigureColor;
+begin
+ if (Odd(PositionsList.Count) and (m_Position.color = fcBlack)) or
+ (not Odd(PositionsList.Count) and (m_Position.color = fcWhite)) then
+ Result := fcWhite
+ else
+ Result := fcBlack;
+end;
+
+
+function TChessRulesEngine.NPlysDone: integer; // amount of plys done
+begin
+ Result := (2 * m_iMovesOffset) + PositionsList.Count;
+end;
+
+
+function TChessRulesEngine.GetEvaluation: TEvaluation;
+begin
+ Result := evInGame;
+ if (not FCanMove(m_Position)) then
+ begin
+ if (FCheckCheck(m_Position)) then
+ Result := evMate
+ else
+ Result := evStaleMate;
+ end;
+ // TODO: Evaluate position for possible technical draw
+end;
+
+
+function TChessPosition.SetPiece(i, j: integer; APiece: TFigure): boolean;
+var
+ SavedPiece: TFigure;
+begin
+ Result := ((i in [1..8]) and (j in [1..8]));
+ if (not Result) then
+ exit;
+
+ SavedPiece := board[i, j];
+ board[i, j] := APiece;
+
+ if (SavedPiece = APiece) then
+ exit;
+
+ if ((i = 5) and (j = 1)) then
+ begin
+ FUpdateKingSideCastling(fcWhite);
+ FUpdateQueenSideCastling(fcWhite);
+ end
+ else if ((i = 8) and (j = 1)) then
+ FUpdateKingSideCastling(fcWhite)
+ else if ((i = 1) and (j = 1)) then
+ FUpdateQueenSideCastling(fcWhite)
+ else if ((i = 5) and (j = 8)) then
+ begin
+ FUpdateKingSideCastling(fcBlack);
+ FUpdateQueenSideCastling(fcBlack);
+ end
+ else if ((i = 8) and (j = 8)) then
+ FUpdateKingSideCastling(fcBlack)
+ else if ((i = 1) and (j = 8)) then
+ FUpdateQueenSideCastling(fcBlack);
+end;
+
+
+procedure TChessPosition.FUpdateKingSideCastling(AColor: TFigureColor);
+var
+ j: integer;
+ King, Rook: TFigure;
+begin
+ if (AColor = fcWhite) then
+ begin
+ j := 1;
+ King := WK;
+ Rook := WR;
+ end
+ else // fcBlack
+ begin
+ j := 8;
+ King := BK;
+ Rook := BR;
+ end;
+
+ if ((board[5, j] = King) and (board[8, j] = Rook)) then
+ begin
+ if (AColor = fcWhite) then
+ Include(castling, WhiteKingSide)
+ else
+ Include(castling, BlackKingSide);
+ end
+ else
+ begin
+ if (AColor = fcWhite) then
+ Exclude(castling, WhiteKingSide)
+ else
+ Exclude(castling, BlackKingSide);
+ end;
+
+end;
+
+
+procedure TChessPosition.FUpdateQueenSideCastling(AColor: TFigureColor);
+var
+ j: integer;
+ King, Rook: TFigure;
+begin
+ if (AColor = fcWhite) then
+ begin
+ j := 1;
+ King := WK;
+ Rook := WR;
+ end
+ else // fcBlack
+ begin
+ j := 8;
+ King := BK;
+ Rook := BR;
+ end;
+
+ if ((board[5, j] = King) and (board[1, j] = Rook)) then
+ begin
+ if (AColor = fcWhite) then
+ Include(castling, WhiteQueenSide)
+ else
+ Include(castling, BlackQueenSide);
+ end
+ else
+ begin
+ if (AColor = fcWhite) then
+ Exclude(castling, WhiteQueenSide)
+ else
+ Exclude(castling, BlackQueenSide);
+ end;
+
+end;
+
+initialization
+
+begin
+ Randomize; // It's for PP Random
+end;
+
+finalization
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ChessSet.res b/plugins/!NotAdopted/Chess4Net/ChessSet.res Binary files differnew file mode 100644 index 0000000000..869af68809 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessSet.res diff --git a/plugins/!NotAdopted/Chess4Net/ChessSet_PNG.RES b/plugins/!NotAdopted/Chess4Net/ChessSet_PNG.RES Binary files differnew file mode 100644 index 0000000000..31328ca9fb --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ChessSet_PNG.RES diff --git a/plugins/!NotAdopted/Chess4Net/ClientQueueUnit.pas b/plugins/!NotAdopted/Chess4Net/ClientQueueUnit.pas new file mode 100644 index 0000000000..7dd7d4c511 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ClientQueueUnit.pas @@ -0,0 +1,165 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ClientQueueUnit;
+
+interface
+
+type
+ TClientName = string[25];
+
+ PClientNode = ^TClientNode;
+
+ TClientNode = record
+ n: word;
+ name: TClientName;
+ handler: pointer;
+ next: PClientNode;
+ end;
+
+ TClientQueue = object
+ Number: word;
+ procedure Add(const handler: pointer; const name: TClientName = '');
+ procedure Remove(const handler: pointer);
+ function GetName(const handler: pointer): TClientName;
+ function GetNum(const handler: pointer): word;
+ function GetHandler(const num: word): pointer;
+{
+ function Contains(const handler: pointer): boolean;
+}
+ constructor Create(const max: word);
+ destructor Free;
+ private
+ first: PClientNode;
+ MaxClientsNum: word;
+ end;
+
+implementation
+
+function TClientQueue.GetHandler(const num: word): pointer;
+var
+ n: PClientNode;
+begin
+ n:= first;
+ while n <> nil do
+ begin
+ if num = n^.n then
+ begin
+ Result:= n^.handler;
+ exit;
+ end;
+ n:= n^.next;
+ end;
+ Result:= nil;
+end;
+
+procedure TClientQueue.Add(const handler: pointer; const name: TClientName);
+var
+ n: PClientNode;
+ p: ^PClientNode;
+begin
+ if Number = MaxClientsNum then exit;
+
+ n:= first; p:= @first;
+ while n <> nil do
+ begin
+ p:= addr(n^.next);
+ n:= n^.next;
+ end;
+ new(n); inc(Number);
+ n^.name:= name;
+ n^.handler:= handler;
+ n^.next:= nil;
+ n^.n:= Number;
+ p^:= n;
+end;
+
+procedure TClientQueue.Remove(const handler: pointer);
+var
+ n: PClientNode;
+ p: ^PClientNode;
+begin
+ n:= first; p:= @first;
+ while n <> nil do
+ begin
+ if n^.handler = handler then
+ begin
+ n:= n^.next;
+ dispose(p^);
+ p^:= n;
+ break;
+ end;
+ p:= addr(n^.next);
+ n:= n^.next;
+ end;
+
+ while n <> nil do
+ begin
+ dec(n^.n);
+ n:= n^.next;
+ end;
+ dec(Number);
+end;
+
+
+function TClientQueue.GetName(const handler: pointer): TClientName;
+var
+ n: PClientNode;
+begin
+ n:= first;
+ while n <> nil do
+ begin
+ if handler = n^.handler then
+ begin
+ Result:= n^.name;
+ exit;
+ end;
+ n:= n^.next;
+ end;
+ Result:= '';
+end;
+
+function TClientQueue.GetNum(const handler: pointer): word;
+var
+ n: PClientNode;
+begin
+ n:= first;
+ while n <> nil do
+ begin
+ if handler = n^.handler then
+ begin
+ Result:= n^.n;
+ exit;
+ end;
+ n:= n^.next;
+ end;
+ Result:= 0;
+end;
+
+{
+function TClientQueue.Contains(const handler: pointer): boolean;
+}
+
+constructor TClientQueue.Create(const max: word);
+begin
+ MaxClientsNum:= max;
+end;
+
+
+destructor TClientQueue.Free;
+var
+ n: PClientNode;
+begin
+ while first <> nil do
+ begin
+ n:= first^.next;
+ dispose(first);
+ first:= n;
+ end;
+ Number:= 0;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/Connecting.ico b/plugins/!NotAdopted/Chess4Net/Connecting.ico Binary files differnew file mode 100644 index 0000000000..433a21ee1d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Connecting.ico diff --git a/plugins/!NotAdopted/Chess4Net/ConnectingUnit.dfm b/plugins/!NotAdopted/Chess4Net/ConnectingUnit.dfm new file mode 100644 index 0000000000..b741f35ac7 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ConnectingUnit.dfm @@ -0,0 +1,72 @@ +object ConnectingForm: TConnectingForm
+ Left = 583
+ Top = 234
+ BorderStyle = bsDialog
+ Caption = 'Connecting...'
+ ClientHeight = 92
+ ClientWidth = 300
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object ConnectingLabel: TTntLabel
+ Left = 64
+ Top = 16
+ Width = 233
+ Height = 13
+ AutoSize = False
+ Caption = 'Wait until the connection is completed.'
+ end
+ object ConnectingImage: TImage
+ Left = 16
+ Top = 16
+ Width = 33
+ Height = 33
+ Picture.Data = {
+ 055449636F6E0000010001002020100000000000E80200001600000028000000
+ 2000000040000000010004000000000080020000000000000000000000000000
+ 0000000000000000000080000080000000808000800000008000800080800000
+ 80808000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000
+ FFFFFF00000000000000000000A000000000000000FFFFFFFFFFF0000AA00000
+ 00000000000F0F0F0F0F0000AAAAAA2A000000000000FFFFFFF0000AAAAAAAA2
+ AA0000000FF800000008FF00AAAAAAAA2A2000000F9FFFFFFFF000000AA00002
+ A2A000000FFFFFFFFFFFFF0000A000000A2A0000000000000000004400000000
+ 02A20000000000000000444444000000002A20000000FFFFFFF0C4C4C4C40000
+ 0002A0000000F00000F0444444444000000620000000F0EEC0F0C4C4C4C4C400
+ 0002A0000040F0CEC0F04C444C444C40000620000040F00000F0C4C4C4C4C4C0
+ 0002A0000440FFFFFFF04CCC4C4C4C4400062000044000000000C4C4C4C4C4C3
+ 0002600044444C4433333CCCCC4CCC433006200044C4C4C4333333C4C4C4C4C3
+ 3002600044444C43333333CCCCCCCC43322222224444C4C333333CC4CCC4C4C3
+ 3222222244444C433333CCCCCCCC33333E22E22244C4C4C334C4C4CCCCCC3333
+ 3E22E222444444433CCCC3CCCCCC33333E22E2220444C4C433C433C4CCC4C333
+ 2EEEE22204444343333333CCCCCCCC4C2EEEE2220044C333333333C4C4C433E2
+ 2EEEE22E00444333333333CCCCCC33EE2EEEE2EE0004C333333333C4C3C4332E
+ EEEEEEE200004333333C333CC3433022EEEEEE22000004333334C333C4C30022
+ 22EE2222000000044433444C440000222EEEE2220000000004C4C4C400000022
+ 22EE22228003DFFF80039FFFC00700FF0000003F0001001F00019E1F0001DF8F
+ 8000FF8FE0003FC7E0000FE7E00007E7E00003E7C00001E7C00001E7800000E7
+ 800000E700000067000000670000000000000000000000000000000000000000
+ 8000000080000000C0000000C0000000E0000000F0000400F8000C00FE003C00
+ FF80FC00}
+ end
+ object AbortButton: TTntButton
+ Left = 112
+ Top = 56
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Abort'
+ Default = True
+ ModalResult = 3
+ TabOrder = 0
+ OnClick = AbortButtonClick
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/ConnectingUnit.pas b/plugins/!NotAdopted/Chess4Net/ConnectingUnit.pas new file mode 100644 index 0000000000..567f049b46 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ConnectingUnit.pas @@ -0,0 +1,116 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ConnectingUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, TntStdCtrls,
+ Forms, {Dialogs, }ExtCtrls, StdCtrls,
+ DialogUnit, ModalForm;
+
+type
+ TConnectingHandler = procedure of object;
+
+ TConnectingForm = class(TModalForm)
+ AbortButton: TTntButton;
+ ConnectingLabel: TTntLabel;
+ ConnectingImage: TImage;
+ procedure AbortButtonClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure FormShow(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ private
+// dlgOwner: TDialogs;
+ ConnectingHandler: TConnectingHandler;
+ shuted: boolean;
+ procedure FLocalize;
+ protected
+ function GetModalID : TModalFormID; override;
+ public
+ procedure Shut;
+ constructor Create(Owner: TForm; h: TConnectingHandler = nil); reintroduce; overload;
+// constructor Create(dlgOwner: TDialogs; h: TConnectingHandler); reintroduce; overload;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ LocalizerUnit;
+
+////////////////////////////////////////////////////////////////////////////////
+// TConnectiongForm
+
+procedure TConnectingForm.AbortButtonClick(Sender: TObject);
+begin
+ Close;
+end;
+
+
+procedure TConnectingForm.FormShow(Sender: TObject);
+var
+ frmOwner: TForm;
+begin
+ frmOwner := (Owner as TForm);
+ Left:= frmOwner.Left + (frmOwner.Width - Width) div 2;
+ Top:= frmOwner.Top + (frmOwner.Height - Height) div 2;
+end;
+
+constructor TConnectingForm.Create(Owner: TForm; h: TConnectingHandler = nil);
+begin
+ self.FormStyle := Owner.FormStyle;
+ inherited Create(Owner);
+ shuted := FALSE;
+ ConnectingHandler := h;
+end;
+
+
+procedure TConnectingForm.FormClose(Sender: TObject;
+ var Action: TCloseAction);
+begin
+ if not shuted then
+ begin
+ ModalResult := AbortButton.ModalResult;
+ if Assigned(ConnectingHandler) then
+ ConnectingHandler;
+ end
+ else
+ ModalResult := mrNone;
+end;
+
+
+procedure TConnectingForm.Shut;
+begin
+ shuted:= TRUE;
+ Close;
+end;
+
+function TConnectingForm.GetModalID: TModalFormID;
+begin
+ Result := mfConnecting;
+end;
+
+
+procedure TConnectingForm.FLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ Caption := GetLabel(19);
+ ConnectingLabel.Caption := GetLabel(20);
+ AbortButton.Caption := GetLabel(21);
+ end;
+end;
+
+
+procedure TConnectingForm.FormCreate(Sender: TObject);
+begin
+ FLocalize;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ConnectionUnit.dfm b/plugins/!NotAdopted/Chess4Net/ConnectionUnit.dfm new file mode 100644 index 0000000000..859a295178 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ConnectionUnit.dfm @@ -0,0 +1,118 @@ +object ConnectionForm: TConnectionForm
+ Left = 298
+ Top = 145
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsDialog
+ Caption = 'Connection Setup'
+ ClientHeight = 171
+ ClientWidth = 292
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ KeyPreview = True
+ OldCreateOrder = False
+ OnKeyPress = FormKeyPress
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object NickLabel: TLabel
+ Left = 8
+ Top = 8
+ Width = 50
+ Height = 13
+ Caption = 'Your Nick:'
+ end
+ object IPLabel: TLabel
+ Left = 8
+ Top = 115
+ Width = 95
+ Height = 13
+ Caption = 'IP or Domain Name:'
+ end
+ object PortLabel: TLabel
+ Left = 152
+ Top = 115
+ Width = 32
+ Height = 13
+ Caption = 'Port #:'
+ end
+ object NickEdit: TEdit
+ Left = 8
+ Top = 24
+ Width = 121
+ Height = 21
+ MaxLength = 15
+ TabOrder = 0
+ Text = 'NN'
+ OnExit = NickEditExit
+ end
+ object ConnectionRadioGroup: TRadioGroup
+ Left = 8
+ Top = 56
+ Width = 185
+ Height = 49
+ Caption = 'Connect as'
+ TabOrder = 1
+ end
+ object ServerRadioButton: TRadioButton
+ Left = 24
+ Top = 72
+ Width = 57
+ Height = 17
+ Caption = 'Server'
+ Checked = True
+ TabOrder = 2
+ TabStop = True
+ OnClick = ServerRadioButtonClick
+ end
+ object ClientRadioButton: TRadioButton
+ Left = 120
+ Top = 72
+ Width = 49
+ Height = 17
+ Caption = 'Client'
+ TabOrder = 3
+ OnClick = ClientRadioButtonClick
+ end
+ object OKButton: TButton
+ Left = 208
+ Top = 16
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ ModalResult = 1
+ TabOrder = 6
+ end
+ object CancelButton: TButton
+ Left = 208
+ Top = 56
+ Width = 75
+ Height = 25
+ Caption = '&Cancel'
+ ModalResult = 2
+ TabOrder = 7
+ end
+ object IPEdit: TEdit
+ Left = 8
+ Top = 131
+ Width = 133
+ Height = 21
+ Enabled = False
+ TabOrder = 4
+ OnChange = IPEditChange
+ end
+ object PortEdit: TMaskEdit
+ Left = 152
+ Top = 131
+ Width = 42
+ Height = 21
+ EditMask = '09999;; '
+ MaxLength = 5
+ TabOrder = 5
+ Text = '5555 '
+ OnExit = PortEditExit
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/ConnectionUnit.pas b/plugins/!NotAdopted/Chess4Net/ConnectionUnit.pas new file mode 100644 index 0000000000..b5c12fef1e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ConnectionUnit.pas @@ -0,0 +1,113 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ConnectionUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ExtCtrls, Mask;
+
+type
+ TConnectionForm = class(TForm)
+ NickLabel: TLabel;
+ NickEdit: TEdit;
+ ConnectionRadioGroup: TRadioGroup;
+ ServerRadioButton: TRadioButton;
+ ClientRadioButton: TRadioButton;
+ OKButton: TButton;
+ CancelButton: TButton;
+ IPEdit: TEdit;
+ IPLabel: TLabel;
+ PortLabel: TLabel;
+ PortEdit: TMaskEdit;
+ procedure FormShow(Sender: TObject);
+ procedure ServerRadioButtonClick(Sender: TObject);
+ procedure ClientRadioButtonClick(Sender: TObject);
+ procedure NickEditExit(Sender: TObject);
+ procedure FormKeyPress(Sender: TObject; var Key: Char);
+ procedure IPEditChange(Sender: TObject);
+ procedure PortEditExit(Sender: TObject);
+ public
+ function GetPort: word;
+ constructor Create(Owner: TComponent); reintroduce;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ GlobalsLocalUnit;
+
+procedure TConnectionForm.ServerRadioButtonClick(Sender: TObject);
+begin
+ IPEdit.Enabled := FALSE;
+ OKButton.Enabled := TRUE;
+end;
+
+procedure TConnectionForm.FormShow(Sender: TObject);
+var
+ frmOwner: TForm;
+begin
+ frmOwner := (Owner as TForm);
+ Left:= frmOwner.Left + (frmOwner.Width - Width) div 2;
+ Top:= frmOwner.Top + (frmOwner.Height - Height) div 2;
+end;
+
+procedure TConnectionForm.ClientRadioButtonClick(Sender: TObject);
+begin
+ IPEdit.Enabled:= TRUE;
+ if IPEdit.Text <> '' then OKButton.Enabled:= TRUE
+ else OKButton.Enabled:= FALSE;
+end;
+
+procedure TConnectionForm.PortEditExit(Sender: TObject);
+begin
+ PortEdit.Text := IntToStr(GetPort);
+end;
+
+procedure TConnectionForm.NickEditExit(Sender: TObject);
+begin
+ if NickEdit.Text = '' then NickEdit.Text:= 'NN';
+end;
+
+procedure TConnectionForm.FormKeyPress(Sender: TObject; var Key: Char);
+begin
+ if Key = #13 then ModalResult:= mrOk;
+end;
+
+procedure TConnectionForm.IPEditChange(Sender: TObject);
+begin
+ if IPEdit.Text <> '' then OKButton.Enabled:= TRUE
+ else OKButton.Enabled:= FALSE;
+end;
+
+constructor TConnectionForm.Create(Owner: TComponent);
+begin
+ FormStyle := (Owner as TForm).FormStyle;
+ inherited;
+ PortEdit.Text := IntToStr(DEFAULT_PORT);
+end;
+
+function TConnectionForm.GetPort: word;
+var
+ port: integer;
+begin
+ try
+ port := StrToInt(Trim(PortEdit.Text));
+ if (port > 0) and (port <= $FFFF) then
+ Result := port
+ else
+ Result := DEFAULT_PORT
+ except
+ on EConvertError do
+ Result := DEFAULT_PORT;
+ end;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ContinueUnit.dfm b/plugins/!NotAdopted/Chess4Net/ContinueUnit.dfm new file mode 100644 index 0000000000..f2e442ef9e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ContinueUnit.dfm @@ -0,0 +1,40 @@ +object ContinueForm: TContinueForm
+ Left = 649
+ Top = 305
+ BorderStyle = bsDialog
+ ClientHeight = 75
+ ClientWidth = 210
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object ContinueLabel: TTntLabel
+ Left = 0
+ Top = 12
+ Width = 209
+ Height = 13
+ Alignment = taCenter
+ AutoSize = False
+ Caption = 'Press button to continue the game.'
+ end
+ object ContinueButton: TTntButton
+ Left = 67
+ Top = 38
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Continue'
+ Default = True
+ ModalResult = 1
+ TabOrder = 0
+ OnClick = ContinueButtonClick
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/ContinueUnit.pas b/plugins/!NotAdopted/Chess4Net/ContinueUnit.pas new file mode 100644 index 0000000000..d6a38a662f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ContinueUnit.pas @@ -0,0 +1,117 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ContinueUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ {Dialogs, }ExtCtrls, StdCtrls, TntStdCtrls,
+ DialogUnit, ModalForm;
+
+type
+ TContinueHandler = procedure of object;
+
+ TContinueForm = class(TModalForm)
+ ContinueButton: TTntButton;
+ ContinueLabel: TTntLabel;
+ procedure ContinueButtonClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure FormShow(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ private
+// dlgOwner: TDialogs;
+ ContinueHandler: TContinueHandler;
+ shuted: boolean;
+ procedure FLocalize;
+ protected
+ function GetModalID: TModalFormID; override;
+ public
+ procedure Shut;
+ constructor Create(Owner: TForm; h: TContinueHandler = nil); reintroduce; overload;
+// constructor Create(dlgOwner: TDialogs; h: TContinueHandler); reintroduce; overload;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ GlobalsUnit, LocalizerUnit;
+
+////////////////////////////////////////////////////////////////////////////////
+// TContinueForm
+
+procedure TContinueForm.ContinueButtonClick(Sender: TObject);
+begin
+ Close;
+end;
+
+
+procedure TContinueForm.FormShow(Sender: TObject);
+var
+ frmOwner: TForm;
+begin
+ frmOwner := (Owner as TForm);
+ Left:= frmOwner.Left + (frmOwner.Width - Width) div 2;
+ Top:= frmOwner.Top + (frmOwner.Height - Height) div 2;
+end;
+
+
+constructor TContinueForm.Create(Owner: TForm; h: TContinueHandler = nil);
+begin
+ self.FormStyle := Owner.FormStyle;
+ inherited Create(Owner);
+ shuted := FALSE;
+ ContinueHandler := h;
+end;
+
+
+procedure TContinueForm.FormClose(Sender: TObject;
+ var Action: TCloseAction);
+begin
+ if not shuted then
+ begin
+ ModalResult := ContinueButton.ModalResult;
+ if Assigned(ContinueHandler) then
+ ContinueHandler;
+ end
+ else
+ ModalResult := mrNone;
+end;
+
+
+procedure TContinueForm.Shut;
+begin
+ shuted:= TRUE;
+ Close;
+end;
+
+
+function TContinueForm.GetModalID: TModalFormID;
+begin
+ Result := mfContinue;
+end;
+
+
+procedure TContinueForm.FormCreate(Sender: TObject);
+begin
+ Caption := DIALOG_CAPTION;
+ FLocalize;
+end;
+
+
+procedure TContinueForm.FLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ ContinueLabel.Caption := GetLabel(22);
+ ContinueButton.Caption := GetLabel(23);
+ end;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/DialogUnit.pas b/plugins/!NotAdopted/Chess4Net/DialogUnit.pas new file mode 100644 index 0000000000..a8eeeb006e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/DialogUnit.pas @@ -0,0 +1,217 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit DialogUnit;
+
+interface
+
+uses
+ Forms, Dialogs, Controls, Classes, Windows,
+ ModalForm;
+
+type
+ TDialogForm = class(TModalForm)
+ procedure FormShow(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure ButtonClick(Sender: TObject);
+ private
+ m_ModID: TModalFormID;
+ m_MsgDlg: TForm;
+ function GetCaption: TCaption;
+ procedure SetCaption(capt: TCaption);
+ protected
+ function GetHandle: hWnd; override;
+ function GetEnabled_: boolean; override;
+ procedure SetEnabled_(flag: boolean); override;
+ function GetLeft_: integer; override;
+ procedure SetLeft_(x: integer); override;
+ function GetTop_: integer; override;
+ procedure SetTop_(y: integer); override;
+ function GetModalID: TModalFormID; override;
+ function RGetModalResult: TModalResult; override;
+ procedure RSetModalResult(Value: TModalResult); override;
+
+ property MsgDlg: TForm read m_MsgDlg;
+ public
+ constructor Create(frmOwner: TForm; const wstrMsg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; modID: TModalFormID = mfNone;
+ msgDlgHandler: TModalFormHandler = nil; bStayOnTopIfNoOwner: boolean = FALSE); overload;
+ constructor Create(dlgOwner: TDialogs; const wstrMsg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; modID: TModalFormID;
+ msgDlgHandler: TModalFormHandler; bStayOnTopIfNoOwner: boolean = FALSE); overload;
+ destructor Destroy; override;
+
+ procedure Show; override;
+ procedure Close; override;
+ function ShowModal: integer; reintroduce;
+ procedure SetFocus; override;
+
+ property Caption: TCaption read GetCaption write SetCaption;
+ end;
+
+implementation
+
+uses
+ StdCtrls, SysUtils, MessageDialogUnit;
+
+constructor TDialogForm.Create(frmOwner: TForm; const wstrMsg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; modID: TModalFormID = mfNone;
+ msgDlgHandler: TModalFormHandler = nil; bStayOnTopIfNoOwner: boolean = FALSE);
+var
+ i: integer;
+begin
+ inherited CreateNew(frmOwner);
+
+ m_ModID := modID;
+ RHandler := msgDlgHandler;
+
+ m_MsgDlg := MessageDialogUnit.CreateMessageDialog(frmOwner, wstrMsg, DlgType, Buttons,
+ bStayOnTopIfNoOwner);
+ // msgDlg.FormStyle := frmOwner.FormStyle;
+ m_MsgDlg.OnShow := FormShow;
+ m_MsgDlg.OnClose := FormClose;
+
+ for i := 0 to (m_MsgDlg.ComponentCount - 1) do
+ begin
+ if (m_MsgDlg.Components[i] is TButton) then
+ TButton(m_MsgDlg.Components[i]).OnClick := ButtonClick;
+ end;
+end;
+
+
+constructor TDialogForm.Create(dlgOwner: TDialogs; const wstrMsg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; modID: TModalFormID;
+ msgDlgHandler: TModalFormHandler; bStayOnTopIfNoOwner: boolean = FALSE);
+begin
+ self.dlgOwner := dlgOwner;
+ Create((dlgOwner.Owner as TForm), wstrMsg, DlgType, Buttons, modID, msgDlgHandler, bStayOnTopIfNoOwner);
+end;
+
+
+procedure TDialogForm.FormShow(Sender: TObject);
+begin
+ inherited FormShow(m_MsgDlg);
+end;
+
+
+procedure TDialogForm.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if Assigned(dlgOwner) then
+ dlgOwner.UnsetShowing(self);
+ if (fsModal in m_MsgDlg.FormState) then
+ exit;
+ if (Assigned(RHandler)) then
+ RHandler(self, GetModalID);
+// Action := caFree;
+ Release;
+end;
+
+
+procedure TDialogForm.Show;
+begin
+ m_MsgDlg.Show;
+end;
+
+
+procedure TDialogForm.Close;
+begin
+ m_MsgDlg.Close;
+end;
+
+
+function TDialogForm.ShowModal: integer;
+begin
+ Result := m_MsgDlg.ShowModal;
+end;
+
+procedure TDialogForm.ButtonClick(Sender: TObject);
+begin
+ if not (fsModal in m_MsgDlg.FormState) then
+ m_MsgDlg.Close;
+end;
+
+destructor TDialogForm.Destroy;
+begin
+ m_MsgDlg.Release;
+ inherited;
+end;
+
+function TDialogForm.GetCaption: TCaption;
+begin
+ Result := m_MsgDlg.Caption;
+end;
+
+procedure TDialogForm.SetCaption(capt: TCaption);
+begin
+ m_MsgDlg.Caption := capt;
+end;
+
+function TDialogForm.GetHandle: hWnd;
+begin
+ Result := m_MsgDlg.Handle;
+end;
+
+
+function TDialogForm.GetEnabled_: boolean;
+begin
+ Result := m_MsgDlg.Enabled;
+end;
+
+
+procedure TDialogForm.SetEnabled_(flag: boolean);
+begin
+ m_MsgDlg.Enabled := flag;
+end;
+
+
+procedure TDialogForm.SetFocus;
+begin
+ m_MsgDlg.SetFocus;
+ m_MsgDlg.Show;
+end;
+
+
+function TDialogForm.GetLeft_: integer;
+begin
+ Result := m_MsgDlg.Left;
+end;
+
+
+procedure TDialogForm.SetLeft_(x: integer);
+begin
+ m_MsgDlg.Left := x;
+end;
+
+
+function TDialogForm.GetTop_: integer;
+begin
+ Result := m_MsgDlg.Top;
+end;
+
+
+procedure TDialogForm.SetTop_(y: integer);
+begin
+ m_MsgDlg.Top := y;
+end;
+
+
+function TDialogForm.GetModalID: TModalFormID;
+begin
+ Result := m_ModID;
+end;
+
+function TDialogForm.RGetModalResult: TModalResult;
+begin
+ Result := m_MsgDlg.ModalResult;
+end;
+
+
+procedure TDialogForm.RSetModalResult(Value: TModalResult);
+begin
+ m_MsgDlg.ModalResult := Value;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/DontShowMessageDlgUnit.pas b/plugins/!NotAdopted/Chess4Net/DontShowMessageDlgUnit.pas new file mode 100644 index 0000000000..357b56c8be --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/DontShowMessageDlgUnit.pas @@ -0,0 +1,82 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit DontShowMessageDlgUnit;
+
+interface
+
+uses
+ Forms, StdCtrls,
+ //
+ DialogUnit, ModalForm;
+
+type
+ TDontShowMessageDlg = class(TDialogForm)
+ private
+ m_DontShowCheckBox: TCheckBox;
+ function FGetDontShow: boolean;
+ procedure FSetDontShow(bValue: boolean);
+ protected
+ function GetModalID: TModalFormID; override;
+ public
+ class function Create(const ADialogs: TDialogs; const wstrMsg: WideString): TDontShowMessageDlg; overload;
+ constructor Create(Owner: TForm; modHandler: TModalFormHandler = nil); overload; override;
+ property DontShow: boolean read FGetDontShow write FSetDontShow;
+ end;
+
+implementation
+
+uses
+ Dialogs, Controls;
+
+////////////////////////////////////////////////////////////////////////////////
+// TDontShowMessageDlg
+
+var
+ g_wstrMsg: WideString;
+
+constructor TDontShowMessageDlg.Create(Owner: TForm; modHandler: TModalFormHandler = nil);
+begin
+ inherited Create(Owner, g_wstrMsg, mtInformation, [mbOK], GetModalID, modHandler);
+
+ MsgDlg.Height := MsgDlg.Height + 10;
+
+ m_DontShowCheckBox := TCheckBox.Create(MsgDlg);
+ m_DontShowCheckBox.Parent := MsgDlg;
+ m_DontShowCheckBox.Caption := 'Don''t Show'; // TODO: Localize
+
+ m_DontShowCheckBox.Left := 10;
+ m_DontShowCheckBox.Top := MsgDlg.ClientHeight - m_DontShowCheckBox.Height - 5;
+end;
+
+
+class function TDontShowMessageDlg.Create(const ADialogs: TDialogs;
+ const wstrMsg: WideString): TDontShowMessageDlg;
+begin
+ g_wstrMsg := wstrMsg;
+ Result := ADialogs.CreateDialog(TDontShowMessageDlg) as TDontShowMessageDlg;
+ g_wstrMsg := '';
+end;
+
+
+function TDontShowMessageDlg.FGetDontShow: boolean;
+begin
+ Result := m_DontShowCheckBox.Checked;
+end;
+
+
+procedure TDontShowMessageDlg.FSetDontShow(bValue: boolean);
+begin
+ m_DontShowCheckBox.Checked := bValue;
+end;
+
+
+function TDontShowMessageDlg.GetModalID: TModalFormID;
+begin
+ Result := mfDontShowDlg;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.dfm b/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.dfm new file mode 100644 index 0000000000..530e34cf18 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.dfm @@ -0,0 +1,59 @@ +object DraggedFigure: TDraggedFigure
+ Left = 347
+ Top = 288
+ Cursor = crHandPoint
+ BorderIcons = []
+ BorderStyle = bsNone
+ ClientHeight = 40
+ ClientWidth = 104
+ Color = clBlack
+ Ctl3D = False
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Image1: TImage
+ Left = 0
+ Top = 0
+ Width = 40
+ Height = 40
+ Picture.Data = {
+ 07544269746D617096030000424D960300000000000076000000280000002800
+ 0000280000000100040000000000200300000000000000000000100000000000
+ 000000000000000080000080000000808000800000008000800080800000C0C0
+ C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
+ FF00666666666666666666666666666666666666666666666666666666666666
+ 6666666666666666666666666666666666666666666666666666666666666666
+ 6666666660000000000000000000000006666666666666666000000000000000
+ 000000000666666666666666600FFFFFFFFFFFFFFFFFFFF00666666666666666
+ 6600FFFFFFFFFFFFFFFFFFF006666666666666666600FFFFFFFFFFFFFFFFFFF0
+ 066666666666666666600FFFFFFFFFFFFFFFFFF00666666666666666666000FF
+ FFFFFFFFFFFFFFF006666666666660066666000FFFFFFFFFFFFFFFF006666666
+ 6600000066666000FFFFFFFFFFFFFFF00666666660000000066666000FFFFFFF
+ FFFFFFF006666666000F00F0066666600FFFFFFFFFFFFF006666666600FFFFFF
+ 0066666000FFFFFFFFFFFF006666666600F00FFFF000666600FFFFFFFFFFFF00
+ 6666666600F00FFFFF00006600FFFFFFFFFFFF0066666666600FFFFFFFFF0000
+ F00FFFFFFFFFFF0066666666600FFFFFFFFFFF00000FFFFFFFFFF00666666666
+ 6600FFFFFFFFFFFF000FFFFFFFFFF006666666666600FFFFFFFFFFFFF00FFFFF
+ FFFF00066666666666600FFFFFFFFFFFF00FFFFFFFFF00666666666666600FFF
+ FFFFFFFFFF00FFFFFFF0006666666666666600F0FFFFFFFFFF00FFFFFFF00666
+ 66666666666600F00FFFFFFFFFFFFFFFFF00066666666666666600F000FFFFFF
+ FFFFFFFFFF006666666666666666600F000FFFFFFFFFFFFFF000666666666666
+ 6666600FFFFFFFFFFFFFFFFF000666666666666666666600F00FFFFFFFFFFFF0
+ 006666666666666666666600000FFFFF00FFF000066666666666666666666660
+ 0F000FFF000000066666666666666666666666600FF000FF0000066666666666
+ 6666666666666660000000F00666666666666666666666666666666000066000
+ 0666666666666666666666666666660006666000666666666666666666666666
+ 6666660066666606666666666666666666666666666666666666666666666666
+ 6666666666666666666666666666666666666666666666666666666666666666
+ 6666666666666666666666666666666666666666666666666666666666666666
+ 6666}
+ Transparent = True
+ OnMouseDown = Image1MouseDown
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.pas b/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.pas new file mode 100644 index 0000000000..780e3bb840 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/DraggedFigureUnit.pas @@ -0,0 +1,48 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit DraggedFigureUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, ExtCtrls;
+
+type
+ TDraggedFigure = class(TForm)
+ Image1: TImage;
+ procedure FormCreate(Sender: TObject);
+ procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ DraggedFigure: TDraggedFigure;
+
+implementation
+
+{$R *.dfm}
+
+procedure TDraggedFigure.FormCreate(Sender: TObject);
+begin
+ ClientWidth:= 40;
+end;
+
+
+
+procedure TDraggedFigure.Image1MouseDown(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+const SC_DRAGMOVE = $F012;
+begin ReleaseCapture;
+ Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0 );
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/Flag.bmp b/plugins/!NotAdopted/Chess4Net/Flag.bmp Binary files differnew file mode 100644 index 0000000000..52360c210b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Flag.bmp diff --git a/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.dfm b/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.dfm new file mode 100644 index 0000000000..33bbfcefee --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.dfm @@ -0,0 +1,166 @@ +object GameChessBoard: TGameChessBoard
+ Left = 429
+ Top = 209
+ Width = 372
+ Height = 421
+ BorderIcons = [biSystemMenu]
+ Color = clBtnFace
+ TransparentColorValue = clBackground
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -13
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsBold]
+ KeyPreview = True
+ OldCreateOrder = False
+ OnActivate = FormActivate
+ OnCanResize = FormCanResize
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ OnKeyDown = FormKeyDown
+ DesignSize = (
+ 356
+ 385)
+ PixelsPerInch = 96
+ TextHeight = 16
+ object ChessBoardPanel: TPanel
+ Left = 0
+ Top = 32
+ Width = 354
+ Height = 352
+ Anchors = [akLeft, akTop, akRight, akBottom]
+ BevelOuter = bvNone
+ TabOrder = 1
+ end
+ object TimePanel: TPanel
+ Left = 0
+ Top = 0
+ Width = 356
+ Height = 33
+ Align = alTop
+ BevelInner = bvLowered
+ TabOrder = 0
+ OnResize = TimePanelResize
+ object WhitePanel: TPanel
+ Left = 8
+ Top = 4
+ Width = 145
+ Height = 25
+ BevelOuter = bvNone
+ TabOrder = 0
+ DesignSize = (
+ 145
+ 25)
+ object WhiteTimeLabel: TLabel
+ Left = 71
+ Top = 0
+ Width = 68
+ Height = 25
+ Align = alLeft
+ AutoSize = False
+ Caption = '0:00:00'
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -19
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsBold]
+ ParentFont = False
+ Layout = tlCenter
+ end
+ object WhiteFlagButton: TSpeedButton
+ Left = 115
+ Top = 2
+ Width = 23
+ Height = 22
+ Anchors = [akTop, akRight]
+ Glyph.Data = {
+ 66010000424D6601000000000000760000002800000014000000140000000100
+ 040000000000F000000000000000000000001000000000000000000000000000
+ 8000008000000080800080000000800080008080000080808000C0C0C0000000
+ FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00FFFFFFFFFFFF
+ FFFFFFFF0000FFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFFFFFFFF0000FFFF
+ FFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFFF83FFF
+ 0000FFFF99FFFFFFFFF33FFF0000FFFFF99FFFFFFF83FFFF0000FFFFF999FFFF
+ FF33FFFF0000F99999999FFFF33FFFFF0000FF99999999FF83FFFFFF0000FFF9
+ 9999999F33FFFFFF0000FFFF999999983FFFFFFF0000FFFFFF9999993FFFFFFF
+ 0000FFFFFF999999FFFFFFFF0000FFFFFFF9999FFFFFFFFF0000FFFFFFF9999F
+ FFFFFFFF0000FFFFFFFF99FFFFFFFFFF0000FFFFFFFF9FFFFFFFFFFF0000FFFF
+ FFFFFFFFFFFFFFFF0000}
+ Visible = False
+ OnClick = FlagButtonClick
+ end
+ object WhiteLabel: TTntLabel
+ Left = 0
+ Top = 0
+ Width = 71
+ Height = 25
+ Align = alLeft
+ Caption = 'White '
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -19
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = [fsBold]
+ ParentFont = False
+ end
+ end
+ object BlackPanel: TPanel
+ Left = 184
+ Top = 4
+ Width = 145
+ Height = 25
+ BevelOuter = bvNone
+ TabOrder = 1
+ DesignSize = (
+ 145
+ 25)
+ object BlackTimeLabel: TLabel
+ Left = 68
+ Top = 0
+ Width = 68
+ Height = 25
+ Align = alLeft
+ AutoSize = False
+ Caption = '0:00:00'
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -19
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsBold]
+ ParentFont = False
+ Layout = tlCenter
+ end
+ object BlackLabel: TTntLabel
+ Left = 0
+ Top = 0
+ Width = 68
+ Height = 25
+ Align = alLeft
+ Caption = 'Black '
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -19
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = [fsBold]
+ ParentFont = False
+ end
+ object BlackFlagButton: TSpeedButton
+ Left = 115
+ Top = 2
+ Width = 23
+ Height = 22
+ Anchors = [akTop, akRight]
+ Visible = False
+ OnClick = FlagButtonClick
+ end
+ end
+ end
+ object GameTimer: TTimer
+ Enabled = False
+ Interval = 100
+ OnTimer = GameTimerTimer
+ Left = 8
+ Top = 40
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.pas b/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.pas new file mode 100644 index 0000000000..779d90f309 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/GameChessBoardUnit.pas @@ -0,0 +1,849 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit GameChessBoardUnit;
+
+interface
+
+uses
+ ExtCtrls, TntStdCtrls, Buttons, Controls, StdCtrls, Classes, Forms, TntForms,
+ Graphics, Messages,
+ // Chess4net
+ ChessBoardHeaderUnit, ChessBoardUnit, ChessRulesEngine,
+ LocalizerUnit, PosBaseChessBoardLayerUnit;
+
+type
+ TGameChessBoardEvent =
+ (cbeMoved, cbeMate, cbeStaleMate, cbeInsuffMaterial, cbeKeyPressed,
+ cbeClockSwitched, cbeTimeOut, cbeExit, cbeMenu, cbeActivate, cbeFormMoving,
+ cbeRefreshAll);
+ // It's possible to add new events. cbeRefreshAll signals that global options had been changed
+
+ TGameChessBoardHandler = procedure(e: TGameChessBoardEvent;
+ d1: pointer = nil; d2: pointer = nil) of object;
+
+{$IFDEF THREADED_CHESSCLOCK}
+ TGameChessBoard = class;
+
+ TTimeLabelThread = class(TThread)
+ private
+ ChessBoard: TGameChessBoard;
+ player_time: array[TFigureColor] of TDateTime;
+ protected
+ procedure Execute; override;
+ public
+ WhiteTime, BlackTime: string;
+ constructor Create(ChessBoard: TGameChessBoard);
+ end;
+{$ENDIF}
+
+ TGameChessBoard = class(TTntForm, ILocalizable)
+ TimePanel: TPanel;
+ WhiteLabel: TTntLabel;
+ WhiteTimeLabel: TLabel;
+ BlackLabel: TTntLabel;
+ BlackTimeLabel: TLabel;
+ GameTimer: TTimer;
+ WhiteFlagButton: TSpeedButton;
+ BlackFlagButton: TSpeedButton;
+ WhitePanel: TPanel;
+ BlackPanel: TPanel;
+ ChessBoardPanel: TPanel;
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure GameTimerTimer(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure FormActivate(Sender: TObject);
+ procedure FlagButtonClick(Sender: TObject);
+ procedure FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer;
+ var Resize: Boolean);
+ procedure TimePanelResize(Sender: TObject);
+
+ private
+ m_ChessBoard: TChessBoard;
+ m_PosBaseChessBoardLayer: TPosBaseChessBoardLayer;
+
+ FHandler: TGameChessBoardHandler;
+
+ auto_flag: boolean; // èíäèêàòîð àâòîôëàãà
+ player_time: array[TFigureColor] of TDateTime; // âðåìÿ áåëûõ è ÷¸ðíûõ
+ past_time: TDateTime; // âðåìÿ íà÷àëà îáäóìûâàíèÿ õîäà
+ unlimited_var: array[TFigureColor] of boolean; // ïàðòèÿ áåç âðåìåííîãî êîíòðîëÿ
+ clock_color: TFigureColor; // öâåò àíèìèðóåìîé ôèãóðû
+
+ shuted: boolean; // èíäèêàòîð âíåøíåãî çàêðûòèÿ îêíà
+
+ // Resizing
+ m_ResizingType: (rtNo, rtHoriz, rtVert);
+// m_iDeltaWidthHeight: integer;
+
+ m_iTimePanelInitialWidth: integer;
+ m_iWhitePanelInitialLeft, m_iBlackPanelInitialLeft: integer;
+ m_iWhitePanelInitialWidth, m_iBlackPanelInitialWidth: integer;
+ m_TimeFont: TFont;
+
+ m_bFlashOnMove: boolean; // flag for flashing window on icoming move
+
+{$IFDEF THREADED_CHESSCLOCK}
+ TimeLabelThread: TTimeLabelThread; // íèòü èñïîëüçóåòñÿ äëÿ áîðüáû ñ ëàãîì â Ìèðàíäå
+{$ENDIF}
+
+ function FGetMode: TMode;
+ procedure FSetMode(const Value: TMode);
+ procedure ShowTime(const c: TFigureColor);
+ function FGetPlayerColor: TFigureColor;
+ procedure FSetPlayerColor(const Value: TFigureColor);
+ function FGetFlipped: boolean;
+ procedure FSetFlipped(bValue: boolean);
+ function FGetTime(color: TFigureColor): TDateTime;
+ procedure FSetTime(color: TFigureColor; const tm: TDateTime);
+ procedure FSetUnlimited(color: TFigureColor; const unl: boolean);
+ function FGetUnlimited(color: TFigureColor): boolean;
+ function FGetLastMoveHilighted: boolean;
+ procedure FSetLastMoveHilighted(bValue: boolean);
+ function FGetCoordinatesShown: boolean;
+ procedure FSetCoordinatesShown(bValue: boolean);
+ function GetStayOnTop: boolean;
+ procedure FSetStayOnTop(onTop: boolean);
+ procedure FSetAutoFlag(auto_flag: boolean);
+ procedure FFlashWindow;
+ function FGetAnimation: TAnimation;
+ procedure FSetAnimation(const Value: TAnimation);
+ function FGetViewGaming: boolean;
+ procedure FSetViewGaming(bValue: boolean);
+
+ // Localization
+ procedure ILocalizable.Localize = FLocalize;
+ procedure FLocalize;
+
+ procedure WMMoving(var Msg: TWMMoving); message WM_MOVING;
+ procedure WMSizing(var Msg: TMessage); message WM_SIZING;
+
+ function FGetPositionColor: TFigureColor;
+
+ function FGetTrainingMode: boolean;
+ procedure FSetTrainingMode(bValue: boolean);
+
+ function FGetUseUserBase: boolean;
+ procedure FSetUseUserBase(bValue: boolean);
+
+ procedure FChessBoardHandler(e: TChessBoardEvent; d1: pointer = nil;
+ d2: pointer = nil);
+ procedure FDoHandler(e: TGameChessBoardEvent; d1: pointer = nil;
+ d2: pointer = nil);
+
+ public
+ constructor Create(Owner: TComponent; AHandler: TGameChessBoardHandler = nil;
+ const strPosBaseName: string = ''); reintroduce;
+
+ procedure FCreateChessBoard(const strPosBaseName: string);
+ procedure FDestroyChessBoard;
+
+ procedure TakeBack; // âçÿòèå õîäà îáðàòíî
+ procedure SwitchClock(clock_color: TFigureColor);
+ procedure InitPosition;
+ procedure PPRandom;
+ procedure StopClock;
+
+ procedure ResetMoveList;
+ function SetPosition(const strPosition: string): boolean;
+ function GetPosition: string;
+ function NMoveDone: integer; // êîëè÷åñòâî ñäåëàííûõ õîäîâ
+ function DoMove(const strMove: string): boolean;
+ procedure Shut;
+
+ procedure WriteGameToBase(vGameResult: TGameResult);
+ procedure SetExternalBase(const strExtPosBaseName: string);
+ procedure UnsetExternalBase;
+
+ property Unlimited[color: TFigureColor]: boolean read FGetUnlimited write FSetUnlimited;
+ property Time[color: TFigureColor]: TDateTime read FGetTime write FSetTime;
+ property PlayerColor: TFigureColor read FGetPlayerColor write FSetPlayerColor;
+ property PositionColor: TFigureColor read FGetPositionColor; // Whos move it is in the current position
+ property ClockColor: TFigureColor read clock_color;
+ property Mode: TMode read FGetMode write FSetMode;
+ property CoordinatesShown: boolean read FGetCoordinatesShown write FSetCoordinatesShown;
+
+ property Flipped: boolean read FGetFlipped write FSetFlipped;
+ property LastMoveHilighted: boolean read FGetLastMoveHilighted write FSetLastMoveHilighted;
+ property FlashOnMove: boolean read m_bFlashOnMove write m_bFlashOnMove;
+ property StayOnTop: boolean read GetStayOnTop write FSetStayOnTop;
+ property AutoFlag: boolean read auto_flag write FSetAutoFlag;
+ property Animation: TAnimation read FGetAnimation write FSetAnimation;
+ property ViewGaming: boolean read FGetViewGaming write FSetViewGaming;
+
+ property pTrainingMode: boolean read FGetTrainingMode write FSetTrainingMode;
+ property pUseUserBase: boolean read FGetUseUserBase write FSetUseUserBase;
+ end;
+
+implementation
+
+{$J+}
+
+{$R *.dfm}
+
+uses
+ SysUtils, Types, Windows,
+ //
+ ChessClockUnit;
+
+const
+ TIME_COLOR = clBlack;
+
+ ZEITNOT_COLOR = clMaroon;
+// CHEAT_TIME_CONST = 1.5; // > 1
+ WHITE_LONG_LABEL: WideString = 'White ';
+ WHITE_MEDIUM_LABEL: WideString = 'White ';
+ WHITE_SHORT_LABEL: WideString = 'W ';
+ BLACK_LONG_LABEL: WideString = 'Black ';
+ BLACK_MEDIUM_LABEL: WideString = 'Black ';
+ BLACK_SHORT_LABEL: WideString = 'B ';
+
+////////////////////////////////////////////////////////////////////////////////
+// TTimeLabelThread
+
+{$IFDEF THREADED_CHESSCLOCK}
+procedure TTimeLabelThread.Execute;
+begin
+ while ChessBoard.GameTimer.Enabled do
+ begin
+ if self.player_time[fcWhite] <> ChessBoard.player_time[fcWhite] then
+ ChessBoard.ShowTime(fcWhite);
+ if self.player_time[fcBlack] <> ChessBoard.player_time[fcBlack] then
+ ChessBoard.ShowTime(fcBlack);
+ Sleep(ChessBoard.GameTimer.Interval div 2);
+ end;
+ ChessBoard.TimeLabelThread := nil;
+end;
+
+
+constructor TTimeLabelThread.Create(ChessBoard: TGameChessBoard);
+begin
+ self.ChessBoard := ChessBoard;
+ self.player_time[fcWhite] := ChessBoard.player_time[fcWhite];
+ self.player_time[fcBlack] := ChessBoard.player_time[fcBlack];
+
+ inherited Create(TRUE);
+//Priority := tpNormal;
+ FreeOnTerminate := TRUE;
+ Resume;
+end;
+{$ENDIF}
+
+////////////////////////////////////////////////////////////////////////////////
+// TGameChessBoard
+
+function TGameChessBoard.DoMove(const strMove: string): boolean;
+begin
+ Result := m_ChessBoard.DoMove(strMove);
+ if (Result) then
+ begin
+ if (m_bFlashOnMove and (Mode = mGame)) then
+ FFlashWindow;
+ end;
+end;
+
+
+procedure TGameChessBoard.ShowTime(const c: TFigureColor);
+var
+ time_label: TLabel;
+begin
+ if c = fcWhite then time_label:= WhiteTimeLabel
+ else time_label:= BlackTimeLabel;
+
+ if unlimited_var[c] then
+ begin
+ time_label.Caption:= '';
+ exit;
+ end;
+
+ if (TChessClock.IsZeitnot(player_time[c])) then
+ time_label.Font.Color := ZEITNOT_COLOR
+ else
+ time_label.Font.Color := TIME_COLOR;
+
+ time_label.Caption := TChessClock.ConvertToStr(player_time[c]);
+end;
+
+
+procedure TGameChessBoard.ResetMoveList;
+begin
+ m_ChessBoard.ResetMoveList;
+end;
+
+
+function TGameChessBoard.SetPosition(const strPosition: string): boolean;
+begin
+ Result := m_ChessBoard.SetPosition(strPosition);
+ if (Result) then
+ clock_color := PositionColor;
+end;
+
+
+function TGameChessBoard.GetPosition: string;
+begin
+ Result := m_ChessBoard.GetPosition;
+end;
+
+
+procedure TGameChessBoard.FormCreate(Sender: TObject);
+begin
+ m_iTimePanelInitialWidth := TimePanel.Width;
+ m_iWhitePanelInitialLeft := WhitePanel.Left;
+ m_iWhitePanelInitialWidth := WhitePanel.Width;
+ m_iBlackPanelInitialLeft := BlackPanel.Left;
+ m_iBlackPanelInitialWidth := BlackPanel.Width;
+
+ m_TimeFont := TFont.Create;
+ m_TimeFont.Assign(WhiteTimeLabel.Font);
+
+ BlackFlagButton.Glyph := WhiteFlagButton.Glyph; // For size minimization
+
+ TLocalizer.Instance.AddSubscriber(self);
+ FLocalize;
+
+ // Clock initialization
+ FSetUnlimited(fcWhite, TRUE);
+ FSetUnlimited(fcBlack, TRUE);
+end;
+
+
+constructor TGameChessBoard.Create(Owner: TComponent;
+ AHandler: TGameChessBoardHandler = nil; const strPosBaseName: string = '');
+begin
+ FHandler := AHandler;
+ inherited Create(Owner);
+ FCreateChessBoard(strPosBaseName);
+end;
+
+
+procedure TGameChessBoard.FCreateChessBoard(const strPosBaseName: string);
+begin
+ m_ChessBoard := TChessBoard.Create(self, FChessBoardHandler);
+ m_PosBaseChessBoardLayer := TPosBaseChessBoardLayer.Create(strPosBaseName);
+
+ m_ChessBoard.AddLayer(m_PosBaseChessBoardLayer);
+
+ with ChessBoardPanel do
+ SetBounds(Left, Top, m_ChessBoard.ClientWidth, m_ChessBoard.ClientHeight);
+
+ m_ChessBoard.BorderStyle := bsNone;
+ m_ChessBoard.Align := alClient;
+ m_ChessBoard.Parent := ChessBoardPanel;
+ m_ChessBoard.Visible := TRUE;
+
+ InitPosition;
+end;
+
+
+procedure TGameChessBoard.FDestroyChessBoard;
+begin
+ m_ChessBoard.RemoveLayer(m_PosBaseChessBoardLayer); // m_ChessBoard is destroyed by its parent
+ FreeAndNil(m_PosBaseChessBoardLayer);
+end;
+
+
+procedure TGameChessBoard.FormDestroy(Sender: TObject);
+begin
+ TLocalizer.Instance.DeleteSubscriber(self);
+
+ m_TimeFont.Free;
+
+ FDestroyChessBoard;
+end;
+
+
+procedure TGameChessBoard.InitPosition;
+begin
+ m_ChessBoard.InitPosition;
+end;
+
+
+procedure TGameChessBoard.FSetMode(const Value: TMode);
+begin
+ m_ChessBoard.Mode := Value;
+ if (Value <> mGame) then
+ begin
+ WhiteFlagButton.Visible := FALSE;
+ BlackFlagButton.Visible := FALSE;
+ end;
+end;
+
+
+function TGameChessBoard.FGetMode: TMode;
+begin
+ Result := m_ChessBoard.Mode;
+end;
+
+
+procedure TGameChessBoard.FSetTime(color: TFigureColor; const tm: TDateTime);
+begin
+ if (not Unlimited[color]) then
+ begin
+ if ((not auto_flag) and (not ViewGaming)) then
+ begin
+ case color of
+ fcWhite:
+ WhiteFlagButton.Visible := ((PlayerColor = fcBlack) and (tm = 0.0));
+ fcBlack:
+ BlackFlagButton.Visible := ((PlayerColor = fcWhite) and (tm = 0.0));
+ end;
+ end;
+ player_time[color] := tm;
+ ShowTime(color);
+ end;
+end;
+
+
+function TGameChessBoard.FGetTime(color: TFigureColor): TDateTime;
+begin
+ Result:= player_time[color];
+end;
+
+
+procedure TGameChessBoard.GameTimerTimer(Sender: TObject);
+begin
+ if unlimited_var[clock_color] then
+ begin
+ GameTimer.Enabled := FALSE;
+ exit;
+ end;
+ // TODO: cheating check
+ player_time[clock_color] := player_time[clock_color] - (Now - past_time);
+ if player_time[clock_color] <= 0.0 then
+ begin
+ player_time[clock_color] := 0.0;
+ ShowTime(clock_color);
+ if ((not auto_flag) and (PlayerColor <> clock_color) and (not ViewGaming)) then
+ begin
+ case clock_color of
+ fcWhite:
+ WhiteFlagButton.Visible := TRUE;
+ fcBlack:
+ BlackFlagButton.Visible := TRUE;
+ end;
+ end;
+ if ((PlayerColor <> clock_color) and (Mode = mGame) and (auto_flag)) then
+ FDoHandler(cbeTimeOut, self);
+ GameTimer.Enabled := FALSE;
+ end;
+{$IFNDEF THREADED_CHESSCLOCK}
+ ShowTime(clock_color);
+{$ENDIF}
+
+ past_time:= Now;
+end;
+
+
+procedure TGameChessBoard.FSetUnlimited(color: TFigureColor; const unl: boolean);
+begin
+ unlimited_var[color]:= unl;
+ ShowTime(color);
+end;
+
+
+function TGameChessBoard.FGetUnlimited(color: TFigureColor): boolean;
+begin
+ Result := unlimited_var[color];
+end;
+
+
+procedure TGameChessBoard.SwitchClock(clock_color: TFigureColor);
+begin
+ self.clock_color := clock_color;
+ if (not GameTimer.Enabled) then
+ begin
+ past_time := Now;
+ GameTimer.Enabled := TRUE;
+ end;
+ if (Mode = mGame) then
+ FDoHandler(cbeClockSwitched, self);
+ ShowTime(clock_color);
+
+{$IFDEF THREADED_CHESSCLOCK}
+ if (not Assigned(TimeLabelThread)) then
+ TimeLabelThread := TTimeLabelThread.Create(self);
+{$ENDIF}
+end;
+
+
+procedure TGameChessBoard.FSetPlayerColor(const Value: TFigureColor);
+begin
+ m_ChessBoard.PlayerColor := Value;
+end;
+
+
+function TGameChessBoard.FGetPlayerColor: TFigureColor;
+begin
+ Result := m_ChessBoard.PlayerColor;
+end;
+
+
+procedure TGameChessBoard.StopClock;
+begin
+ GameTimer.Enabled := FALSE;
+ WhiteFlagButton.Visible := FALSE;
+ BlackFlagButton.Visible := FALSE;
+end;
+
+
+procedure TGameChessBoard.FormCanResize(Sender: TObject; var NewWidth,
+ NewHeight: Integer; var Resize: Boolean);
+var
+ iNewChessBoardWidth, iNewChessBoardHeight: integer;
+begin
+ Resize := (m_ResizingType <> rtNo);
+ if (not Resize) then
+ exit;
+
+ iNewChessBoardWidth := m_ChessBoard.Width + (NewWidth - self.Width);
+ iNewChessBoardHeight := m_ChessBoard.Height + (NewHeight - self.Height);
+
+ m_ChessBoard.FormCanResize(self, iNewChessBoardWidth, iNewChessBoardHeight, Resize);
+ if (Resize) then
+ begin
+ NewWidth := self.Width + (iNewChessBoardWidth - m_ChessBoard.Width);
+ NewHeight := self.Height + (iNewChessBoardHeight - m_ChessBoard.Height);
+ end;
+end;
+
+procedure TGameChessBoard.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if (not shuted) then
+ begin
+ FDoHandler(cbeExit, self);
+ Action:= caNone;
+ end
+ else
+ shuted := FALSE;
+end;
+
+
+procedure TGameChessBoard.Shut;
+begin
+ shuted:= TRUE;
+ Close;
+end;
+
+
+procedure TGameChessBoard.PPRandom;
+begin
+ m_ChessBoard.PPRandom;
+end;
+
+
+procedure TGameChessBoard.TakeBack;
+begin
+ m_ChessBoard.TakeBack;
+end;
+
+
+function TGameChessBoard.FGetLastMoveHilighted: boolean;
+begin
+ Result := m_ChessBoard.LastMoveHilighted;
+end;
+
+
+procedure TGameChessBoard.FSetLastMoveHilighted(bValue: boolean);
+begin
+ m_ChessBoard.LastMoveHilighted := bValue;
+end;
+
+
+procedure TGameChessBoard.FSetCoordinatesShown(bValue: boolean);
+begin
+ m_ChessBoard.CoordinatesShown := bValue;
+end;
+
+
+function TGameChessBoard.FGetCoordinatesShown: boolean;
+begin
+ Result := m_ChessBoard.CoordinatesShown;
+end;
+
+
+function TGameChessBoard.NMoveDone: integer;
+begin
+ Result := m_ChessBoard.NMoveDone;
+end;
+
+
+procedure TGameChessBoard.FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ FDoHandler(cbeKeyPressed, Pointer(Key), self);
+end;
+
+
+function TGameChessBoard.GetStayOnTop: boolean;
+begin
+ Result := (self.FormStyle = fsStayOnTop);
+end;
+
+
+procedure TGameChessBoard.FSetStayOnTop(onTop: boolean);
+begin
+ if (onTop) then
+ self.FormStyle := fsStayOnTop
+ else
+ self.FormStyle := fsNormal;
+end;
+
+
+procedure TGameChessBoard.FormActivate(Sender: TObject);
+begin
+ FDoHandler(cbeActivate, self);
+end;
+
+
+procedure TGameChessBoard.WMMoving(var Msg: TWMMoving);
+begin
+ // TODO: it's possible to handle if form is outside of the screen
+ FDoHandler(cbeFormMoving, Pointer(Msg.DragRect.Left - Left), Pointer(Msg.DragRect.Top - Top));
+ inherited;
+end;
+
+
+procedure TGameChessBoard.WMSizing(var Msg: TMessage);
+begin
+ m_ChessBoard.Perform(Msg.Msg, Msg.WParam, Msg.LParam);
+
+ case Msg.WParam of
+ WMSZ_RIGHT, WMSZ_LEFT, WMSZ_BOTTOMRIGHT, WMSZ_TOPLEFT:
+ m_ResizingType := rtHoriz;
+ WMSZ_BOTTOM, WMSZ_TOP:
+ m_ResizingType := rtVert;
+ else
+ begin
+ m_ResizingType := rtNo;
+ PRect(Msg.LParam).Left := Left;
+ PRect(Msg.LParam).Top := Top;
+ end;
+ end; // case
+end;
+
+
+function TGameChessBoard.FGetPositionColor: TFigureColor;
+begin
+ Result := m_ChessBoard.PositionColor;
+end;
+
+
+procedure TGameChessBoard.FlagButtonClick(Sender: TObject);
+begin
+ if (Mode = mGame) then
+ FDoHandler(cbeTimeOut, self);
+end;
+
+
+procedure TGameChessBoard.FSetAutoFlag(auto_flag: boolean);
+begin
+ self.auto_flag := auto_flag;
+ if (auto_flag) then
+ begin
+ WhiteFlagButton.Visible := FALSE;
+ BlackFlagButton.Visible := FALSE;
+ end;
+end;
+
+
+procedure TGameChessBoard.TimePanelResize(Sender: TObject);
+var
+ rRatio: real;
+begin
+ // Adjust panels on TimePanel
+ rRatio := TimePanel.Width / m_iTimePanelInitialWidth;
+ WhitePanel.Left := Round(rRatio * m_iWhitePanelInitialLeft);
+ WhitePanel.Width := m_iWhitePanelInitialWidth;
+ BlackPanel.Left := Round(rRatio * m_iBlackPanelInitialLeft);
+ BlackPanel.Width := m_iBlackPanelInitialWidth;
+
+
+ WhiteTimeLabel.Font.Assign(m_TimeFont);
+ BlackTimeLabel.Font.Assign(m_TimeFont);
+
+ if (WhitePanel.Left + WhitePanel.Width < BlackPanel.Left) then
+ begin
+ WhiteLabel.Caption := WHITE_LONG_LABEL;
+ BlackLabel.Caption := BLACK_LONG_LABEL;
+ end
+ else
+ begin
+ WhitePanel.Left := 4;
+ WhitePanel.Width := TimePanel.Width div 2;
+ BlackPanel.Left := TimePanel.Width div 2;
+ BlackPanel.Width := TimePanel.Width div 2 - 4;
+
+ WhiteLabel.Caption := WHITE_MEDIUM_LABEL;
+ BlackLabel.Caption := BLACK_MEDIUM_LABEL;
+ end;
+
+ // Adjust color labels
+ if ((WhiteTimeLabel.Left + WhiteTimeLabel.Width > WhitePanel.Width) or
+ (BlackTimeLabel.Left + BlackTimeLabel.Width > BlackPanel.Width)) then
+ begin
+ WhiteLabel.Caption := WHITE_MEDIUM_LABEL;
+ BlackLabel.Caption := BLACK_MEDIUM_LABEL;
+ if ((WhiteTimeLabel.Left + WhiteTimeLabel.Width <= WhitePanel.Width) and
+ (BlackTimeLabel.Left + BlackTimeLabel.Width <= BlackPanel.Width)) then
+ exit; // TODO: a KLUDGE - make it nice!
+
+ WhiteTimeLabel.Font.Size := WhiteTimeLabel.Font.Size - 4;
+ BlackTimeLabel.Font.Size := BlackTimeLabel.Font.Size - 4;
+ WhiteLabel.Caption := WHITE_SHORT_LABEL;
+ BlackLabel.Caption := BLACK_SHORT_LABEL;
+ end;
+end;
+
+
+procedure TGameChessBoard.FFlashWindow;
+var
+ flushWindowInfo: TFlashWInfo;
+begin
+ // Flash with taskbar
+ flushWindowInfo.cbSize := SizeOf(flushWindowInfo);
+ flushWindowInfo.hwnd := Application.Handle;
+ flushWindowInfo.dwflags := FLASHW_TRAY; // FLASHW_ALL; //FLASHW_TRAY;
+ flushWindowInfo.ucount := 3; // Flash times
+ flushWindowInfo.dwtimeout := 0; // speed in msec, 0 - frequency of cursor flashing
+ FlashWindowEx(flushWindowInfo);
+
+ if (self.Focused) then
+ exit;
+ // Flash window
+ flushWindowInfo.hwnd := self.Handle; // handle of the flashing window
+ flushWindowInfo.dwflags := FLASHW_CAPTION; // FLASHW_TRAY; // FLASHW_ALL; //FLASHW_TRAY;
+ FlashWindowEx(flushWindowInfo);
+end;
+
+
+procedure TGameChessBoard.FLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ WHITE_LONG_LABEL := GetLabel(13);
+ WHITE_MEDIUM_LABEL := GetLabel(14);
+ WHITE_SHORT_LABEL := GetLabel(15);
+ BLACK_LONG_LABEL := GetLabel(16);
+ BLACK_MEDIUM_LABEL := GetLabel(17);
+ BLACK_SHORT_LABEL := GetLabel(18);
+ end;
+
+ TimePanelResize(nil);
+end;
+
+
+procedure TGameChessBoard.WriteGameToBase(vGameResult: TGameResult);
+begin
+ m_PosBaseChessBoardLayer.WriteGameToBase(vGameResult);
+end;
+
+
+procedure TGameChessBoard.SetExternalBase(const strExtPosBaseName: string);
+begin
+ m_PosBaseChessBoardLayer.SetExternalBase(strExtPosBaseName);
+end;
+
+
+procedure TGameChessBoard.UnsetExternalBase;
+begin
+ m_PosBaseChessBoardLayer.UnsetExternalBase;
+end;
+
+
+function TGameChessBoard.FGetTrainingMode: boolean;
+begin
+ Result := m_PosBaseChessBoardLayer.TrainingMode;
+end;
+
+
+procedure TGameChessBoard.FSetTrainingMode(bValue: boolean);
+begin
+ m_PosBaseChessBoardLayer.TrainingMode := bValue;
+end;
+
+
+function TGameChessBoard.FGetUseUserBase: boolean;
+begin
+ Result := m_PosBaseChessBoardLayer.UseUserBase;
+end;
+
+
+procedure TGameChessBoard.FSetUseUserBase(bValue: boolean);
+begin
+ m_PosBaseChessBoardLayer.UseUserBase := bValue;
+end;
+
+
+function TGameChessBoard.FGetFlipped: boolean;
+begin
+ Result := m_ChessBoard.Flipped;
+end;
+
+
+procedure TGameChessBoard.FSetFlipped(bValue: boolean);
+begin
+ m_ChessBoard.Flipped := bValue;
+end;
+
+
+function TGameChessBoard.FGetAnimation: TAnimation;
+begin
+ Result := m_ChessBoard.Animation;
+end;
+
+
+procedure TGameChessBoard.FSetAnimation(const Value: TAnimation);
+begin
+ m_ChessBoard.Animation := Value;
+end;
+
+
+function TGameChessBoard.FGetViewGaming: boolean;
+begin
+ Result := m_ChessBoard.ViewGaming;
+end;
+
+
+procedure TGameChessBoard.FSetViewGaming(bValue: boolean);
+begin
+ m_ChessBoard.ViewGaming := bValue;
+end;
+
+
+procedure TGameChessBoard.FChessBoardHandler(e: TChessBoardEvent; d1: pointer = nil;
+ d2: pointer = nil);
+begin
+ case e of
+ ChessBoardUnit.cbeMate:
+ FDoHandler(cbeMate, self);
+
+ ChessBoardUnit.cbeStaleMate:
+ FDoHandler(cbeStaleMate, self);
+
+ ChessBoardUnit.cbeMoved:
+ begin
+ if ((Mode = mGame) and (PositionColor <> PlayerColor)) then
+ FDoHandler(cbeMoved, d1, self);
+ SwitchClock(PositionColor);
+ end;
+
+ ChessBoardUnit.cbeMenu:
+ FDoHandler(cbeMenu, self);
+ end;
+end;
+
+
+procedure TGameChessBoard.FDoHandler(e: TGameChessBoardEvent; d1: pointer = nil;
+ d2: pointer = nil);
+begin
+ if (Assigned(FHandler)) then
+ FHandler(e, d1, d2);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.dfm b/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.dfm new file mode 100644 index 0000000000..6c529ecf8c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.dfm @@ -0,0 +1,317 @@ +object GameOptionsForm: TGameOptionsForm
+ Left = 565
+ Top = 197
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsDialog
+ Caption = 'Game Options'
+ ClientHeight = 503
+ ClientWidth = 412
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object OkButton: TTntButton
+ Left = 328
+ Top = 16
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 3
+ end
+ object CancelButton: TTntButton
+ Left = 328
+ Top = 48
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Cancel'
+ ModalResult = 2
+ TabOrder = 4
+ end
+ object TimeControlGroupBox: TTntGroupBox
+ Left = 8
+ Top = 8
+ Width = 305
+ Height = 265
+ Caption = 'Time Control'
+ TabOrder = 0
+ object EqualTimeCheckBox: TTntCheckBox
+ Left = 16
+ Top = 24
+ Width = 233
+ Height = 17
+ Caption = 'Equal time for both players'
+ Checked = True
+ State = cbChecked
+ TabOrder = 0
+ OnClick = EqualTimeCheckBoxClick
+ end
+ object YouGroupBox: TTntGroupBox
+ Left = 32
+ Top = 48
+ Width = 249
+ Height = 97
+ Caption = 'Your time'
+ TabOrder = 1
+ DesignSize = (
+ 249
+ 97)
+ object YouMinLabel: TTntLabel
+ Left = 16
+ Top = 42
+ Width = 145
+ Height = 14
+ AutoSize = False
+ Caption = 'Minutes per game:'
+ end
+ object YouIncLabel: TTntLabel
+ Left = 16
+ Top = 66
+ Width = 145
+ Height = 14
+ AutoSize = False
+ Caption = 'Increment in seconds:'
+ end
+ object YouMinEdit: TEdit
+ Left = 168
+ Top = 40
+ Width = 41
+ Height = 21
+ BiDiMode = bdLeftToRight
+ MaxLength = 3
+ ParentBiDiMode = False
+ TabOrder = 1
+ Text = '5'
+ OnChange = YouEditChange
+ end
+ object YouIncEdit: TEdit
+ Left = 168
+ Top = 64
+ Width = 41
+ Height = 21
+ TabOrder = 2
+ Text = '0'
+ OnChange = YouEditChange
+ end
+ object YouUnlimitedCheckBox: TTntCheckBox
+ Left = 16
+ Top = 16
+ Width = 217
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Unlimited'
+ TabOrder = 0
+ OnClick = UnlimitedCheckBoxClick
+ end
+ object YouMinUpDown: TUpDown
+ Left = 209
+ Top = 40
+ Width = 15
+ Height = 21
+ Associate = YouMinEdit
+ Min = 1
+ Max = 999
+ Position = 5
+ TabOrder = 3
+ end
+ object YouIncUpDown: TUpDown
+ Left = 209
+ Top = 64
+ Width = 15
+ Height = 21
+ Associate = YouIncEdit
+ Max = 999
+ TabOrder = 4
+ end
+ end
+ object OpponentGroupBox: TTntGroupBox
+ Left = 32
+ Top = 152
+ Width = 249
+ Height = 97
+ Caption = 'Opponent'#39's time'
+ TabOrder = 2
+ DesignSize = (
+ 249
+ 97)
+ object OpponentMinLabel: TTntLabel
+ Left = 16
+ Top = 42
+ Width = 145
+ Height = 13
+ AutoSize = False
+ Caption = 'Minutes per game:'
+ end
+ object OpponentIncLabel: TTntLabel
+ Left = 16
+ Top = 66
+ Width = 145
+ Height = 13
+ AutoSize = False
+ Caption = 'Increment in seconds:'
+ end
+ object OpponentIncEdit: TEdit
+ Left = 168
+ Top = 64
+ Width = 41
+ Height = 21
+ TabOrder = 2
+ Text = '0'
+ OnChange = OpponentEditChange
+ end
+ object OpponentMinEdit: TEdit
+ Left = 168
+ Top = 40
+ Width = 41
+ Height = 21
+ BiDiMode = bdLeftToRight
+ MaxLength = 3
+ ParentBiDiMode = False
+ TabOrder = 1
+ Text = '5'
+ OnChange = OpponentEditChange
+ end
+ object OpponentUnlimitedCheckBox: TTntCheckBox
+ Left = 16
+ Top = 16
+ Width = 217
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Unlimited'
+ TabOrder = 0
+ OnClick = UnlimitedCheckBoxClick
+ end
+ object OpponentMinUpDown: TUpDown
+ Left = 209
+ Top = 40
+ Width = 15
+ Height = 21
+ Associate = OpponentMinEdit
+ Min = 1
+ Max = 999
+ Position = 5
+ TabOrder = 3
+ end
+ object OpponentIncUpDown: TUpDown
+ Left = 209
+ Top = 64
+ Width = 15
+ Height = 21
+ Associate = OpponentIncEdit
+ Max = 999
+ TabOrder = 4
+ end
+ end
+ end
+ object Panel1: TPanel
+ Left = 8
+ Top = 390
+ Width = 305
+ Height = 105
+ BevelInner = bvRaised
+ BevelOuter = bvLowered
+ TabOrder = 2
+ DesignSize = (
+ 305
+ 105)
+ object AutoFlagCheckBox: TTntCheckBox
+ Left = 8
+ Top = 80
+ Width = 289
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Auto Flag'
+ Checked = True
+ State = cbChecked
+ TabOrder = 3
+ end
+ object TakeBackCheckBox: TTntCheckBox
+ Left = 8
+ Top = 56
+ Width = 289
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Allow takebacks to your partner'
+ TabOrder = 2
+ end
+ object GamePauseCheckBox: TTntCheckBox
+ Left = 8
+ Top = 8
+ Width = 289
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Game can be paused'
+ TabOrder = 0
+ end
+ object GameAdjournCheckBox: TTntCheckBox
+ Left = 8
+ Top = 32
+ Width = 289
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Game can be adjourned'
+ TabOrder = 1
+ end
+ end
+ object TrainingModeGroupBox: TTntGroupBox
+ Left = 8
+ Top = 280
+ Width = 305
+ Height = 97
+ Caption = 'Training Mode'
+ TabOrder = 1
+ DesignSize = (
+ 305
+ 97)
+ object ExtBaseLabel: TTntLabel
+ Left = 16
+ Top = 38
+ Width = 81
+ Height = 13
+ AutoSize = False
+ Caption = 'External base:'
+ end
+ object TrainingEnabledCheckBox: TTntCheckBox
+ Left = 16
+ Top = 16
+ Width = 257
+ Height = 17
+ Caption = 'Enabled'
+ TabOrder = 0
+ OnClick = TrainingEnabledCheckBoxClick
+ end
+ object ExtBaseComboBox: TTntComboBox
+ Left = 104
+ Top = 36
+ Width = 169
+ Height = 21
+ Enabled = False
+ ItemHeight = 13
+ ItemIndex = 0
+ TabOrder = 1
+ Text = '<No>'
+ OnChange = ExtBaseComboBoxChange
+ Items.Strings = (
+ '<No>')
+ end
+ object UsrBaseCheckBox: TTntCheckBox
+ Left = 40
+ Top = 64
+ Width = 257
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Use user base'
+ Enabled = False
+ TabOrder = 2
+ end
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.pas b/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.pas new file mode 100644 index 0000000000..0c8fd6cdeb --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/GameOptionsUnit.pas @@ -0,0 +1,191 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit GameOptionsUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls,
+ Dialogs, StdCtrls, TntStdCtrls, ExtCtrls, ComCtrls,
+ ModalForm;
+
+type
+ TGameOptionsForm = class(TModalForm)
+ OkButton: TTntButton;
+ CancelButton: TTntButton;
+ TimeControlGroupBox: TTntGroupBox;
+ EqualTimeCheckBox: TTntCheckBox;
+ YouGroupBox: TTntGroupBox;
+ YouMinLabel: TTntLabel;
+ YouIncLabel: TTntLabel;
+ YouMinEdit: TEdit;
+ YouIncEdit: TEdit;
+ YouUnlimitedCheckBox: TTntCheckBox;
+ OpponentGroupBox: TTntGroupBox;
+ OpponentMinLabel: TTntLabel;
+ OpponentIncLabel: TTntLabel;
+ OpponentIncEdit: TEdit;
+ OpponentMinEdit: TEdit;
+ OpponentUnlimitedCheckBox: TTntCheckBox;
+ Panel1: TPanel;
+ AutoFlagCheckBox: TTntCheckBox;
+ TakeBackCheckBox: TTntCheckBox;
+ TrainingModeGroupBox: TTntGroupBox;
+ TrainingEnabledCheckBox: TTntCheckBox;
+ ExtBaseComboBox: TTntComboBox;
+ UsrBaseCheckBox: TTntCheckBox;
+ ExtBaseLabel: TTntLabel;
+ GamePauseCheckBox: TTntCheckBox;
+ YouMinUpDown: TUpDown;
+ YouIncUpDown: TUpDown;
+ OpponentMinUpDown: TUpDown;
+ OpponentIncUpDown: TUpDown;
+ GameAdjournCheckBox: TTntCheckBox;
+ procedure YouEditChange(Sender: TObject);
+ procedure OpponentEditChange(Sender: TObject);
+ procedure EqualTimeCheckBoxClick(Sender: TObject);
+ procedure UnlimitedCheckBoxClick(Sender: TObject);
+ procedure TrainingEnabledCheckBoxClick(Sender: TObject);
+ procedure ExtBaseComboBoxChange(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ private
+ procedure FLocalize;
+ protected
+ function GetModalID: TModalFormID; override;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ LocalizerUnit;
+
+procedure TGameOptionsForm.YouEditChange(Sender: TObject);
+begin
+ YouMinEdit.Text := IntToStr(YouMinUpDown.Position);
+ YouIncEdit.Text := IntToStr(YouIncUpDown.Position);
+ if EqualTimeCheckBox.Checked then
+ begin
+ OpponentMinEdit.Text := YouMinEdit.Text;
+ OpponentIncEdit.Text := YouIncEdit.Text;
+ end;
+end;
+
+
+procedure TGameOptionsForm.OpponentEditChange(Sender: TObject);
+begin
+ OpponentMinEdit.Text := IntToStr(OpponentMinUpDown.Position);
+ OpponentIncEdit.Text := IntToStr(OpponentIncUpDown.Position);
+ if EqualTimeCheckBox.Checked then
+ begin
+ YouMinEdit.Text := OpponentMinEdit.Text;
+ YouIncEdit.Text := OpponentIncEdit.Text;
+ end;
+end;
+
+
+procedure TGameOptionsForm.EqualTimeCheckBoxClick(Sender: TObject);
+begin
+ if EqualTimeCheckBox.Checked then
+ begin
+ OpponentMinEdit.Text := YouMinEdit.Text;
+ OpponentIncEdit.Text := YouIncEdit.Text;
+ OpponentUnlimitedCheckBox.Checked := YouUnlimitedCheckBox.Checked;
+ end;
+end;
+
+
+procedure TGameOptionsForm.UnlimitedCheckBoxClick(Sender: TObject);
+begin
+ if EqualTimeCheckBox.Checked then
+ begin
+ YouUnlimitedCheckBox.Checked := TCheckBox(Sender).Checked;
+ OpponentUnlimitedCheckBox.Checked := TCheckBox(Sender).Checked;
+ end;
+
+ YouMinEdit.Enabled := (not YouUnlimitedCheckBox.Checked);
+ YouMinUpDown.Enabled := (not YouUnlimitedCheckBox.Checked);
+ YouIncEdit.Enabled := (not YouUnlimitedCheckBox.Checked);
+ YouIncUpDown.Enabled := (not YouUnlimitedCheckBox.Checked);
+
+ OpponentMinEdit.Enabled := (not OpponentUnlimitedCheckBox.Checked);
+ OpponentMinUpDown.Enabled := (not OpponentUnlimitedCheckBox.Checked);
+ OpponentIncEdit.Enabled := (not OpponentUnlimitedCheckBox.Checked);
+ OpponentIncUpDown.Enabled := (not OpponentUnlimitedCheckBox.Checked);
+end;
+
+
+procedure TGameOptionsForm.TrainingEnabledCheckBoxClick(Sender: TObject);
+begin
+ ExtBaseComboBox.Enabled := TrainingEnabledCheckBox.Checked;
+ UsrBaseCheckBox.Enabled := TrainingEnabledCheckBox.Checked and (ExtBaseComboBox.ItemIndex <> 0);
+ TakeBackCheckBox.Enabled := not TrainingEnabledCheckBox.Checked;
+end;
+
+
+procedure TGameOptionsForm.ExtBaseComboBoxChange(Sender: TObject);
+begin
+ UsrBaseCheckBox.Enabled := (ExtBaseComboBox.ItemIndex <> 0);
+ if ExtBaseComboBox.ItemIndex = 0 then
+ UsrBaseCheckBox.Checked := TRUE;
+end;
+
+
+procedure TGameOptionsForm.FormShow(Sender: TObject);
+begin
+ ExtBaseComboBoxChange(Sender);
+end;
+
+
+function TGameOptionsForm.GetModalID: TModalFormID;
+begin
+ Result := mfGameOptions;
+end;
+
+
+procedure TGameOptionsForm.FormCreate(Sender: TObject);
+begin
+ FLocalize;
+end;
+
+
+procedure TGameOptionsForm.FLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ Caption := GetLabel(24);
+
+ TimeControlGroupBox.Caption := GetLabel(25);
+ EqualTimeCheckBox.Caption := GetLabel(26);
+ YouGroupBox.Caption := GetLabel(27);
+ OpponentGroupBox.Caption := GetLabel(28);
+ YouUnlimitedCheckBox.Caption := GetLabel(29);
+ OpponentUnlimitedCheckBox.Caption := GetLabel(29);
+ YouMinLabel.Caption := GetLabel(30);
+ OpponentMinLabel.Caption := GetLabel(30);
+ YouIncLabel.Caption := GetLabel(31);
+ OpponentIncLabel.Caption := GetLabel(31);
+
+ TrainingModeGroupBox.Caption := GetLabel(32);
+ TrainingEnabledCheckBox.Caption := GetLabel(33);
+ ExtBaseLabel.Caption := GetLabel(34);
+ UsrBaseCheckBox.Caption := GetLabel(35);
+
+ GamePauseCheckBox.Caption := GetLabel(36);
+ GameAdjournCheckBox.Caption := GetLabel(37);
+ TakeBackCheckBox.Caption := GetLabel(38);
+ AutoFlagCheckBox.Caption := GetLabel(39);
+
+ OkButton.Caption := GetLabel(11);
+ CancelButton.Caption := GetLabel(12);
+ end;
+end;
+
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/GlobalsUnit.pas b/plugins/!NotAdopted/Chess4Net/GlobalsUnit.pas new file mode 100644 index 0000000000..2cd0619882 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/GlobalsUnit.pas @@ -0,0 +1,24 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit GlobalsUnit;
+
+interface
+
+const
+ DIALOG_CAPTION = 'Chess4Net';
+ GAME_LOG_FILE = 'Chess4Net_GAMELOG.txt';
+
+ INITIAL_CLOCK_TIME = '5 0 5 0'; // 5:00 5:00
+
+var
+ Chess4NetPath: string;
+ Chess4NetIniFilePath: string;
+ Chess4NetGamesLogPath: string;
+
+implementation
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/InfoUnit.dfm b/plugins/!NotAdopted/Chess4Net/InfoUnit.dfm new file mode 100644 index 0000000000..a153dac36b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/InfoUnit.dfm @@ -0,0 +1,114 @@ +object InfoForm: TInfoForm
+ Left = 489
+ Top = 506
+ BorderStyle = bsDialog
+ ClientHeight = 166
+ ClientWidth = 233
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ Position = poScreenCenter
+ OnClose = FormClose
+ OnCreate = FormCreate
+ PixelsPerInch = 96
+ TextHeight = 13
+ object PluginNameLabel: TLabel
+ Left = 0
+ Top = 8
+ Width = 233
+ Height = 17
+ Alignment = taCenter
+ AutoSize = False
+ Caption = 'Chess4Net <version>'
+ WordWrap = True
+ end
+ object PlayingViaLabel: TLabel
+ Left = 0
+ Top = 27
+ Width = 233
+ Height = 13
+ Alignment = taCenter
+ AutoSize = False
+ Caption = 'Plugin for playing chess via <Messenger name>'
+ end
+ object Label2: TLabel
+ Left = 0
+ Top = 46
+ Width = 233
+ Height = 13
+ Alignment = taCenter
+ AutoSize = False
+ Caption = 'Written by Pavel Perminov'
+ end
+ object Label3: TLabel
+ Left = 0
+ Top = 65
+ Width = 233
+ Height = 13
+ Alignment = taCenter
+ AutoSize = False
+ Caption = #169' 2007-2011 no rights reserved'
+ end
+ object Label4: TLabel
+ Left = 38
+ Top = 84
+ Width = 25
+ Height = 13
+ AutoSize = False
+ Caption = 'URL:'
+ end
+ object Label5: TLabel
+ Left = 38
+ Top = 104
+ Width = 32
+ Height = 13
+ AutoSize = False
+ Caption = 'E-Mail:'
+ end
+ object URLLabel: TLabel
+ Left = 73
+ Top = 84
+ Width = 65
+ Height = 13
+ Cursor = crHandPoint
+ Caption = 'http://<URL>'
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clBlue
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsUnderline]
+ ParentFont = False
+ OnClick = URLLabelClick
+ end
+ object EMailLabel: TLabel
+ Left = 73
+ Top = 104
+ Width = 41
+ Height = 13
+ Cursor = crHandPoint
+ Caption = '<E-Mail>'
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clBlue
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsUnderline]
+ ParentFont = False
+ OnClick = EMailLabelClick
+ end
+ object OkButton: TButton
+ Left = 80
+ Top = 128
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 0
+ OnClick = OkButtonClick
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/InfoUnit.pas b/plugins/!NotAdopted/Chess4Net/InfoUnit.pas new file mode 100644 index 0000000000..f4b349a71d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/InfoUnit.pas @@ -0,0 +1,98 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit InfoUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ShellAPI;
+
+type
+ TInfoForm = class(TForm)
+ OkButton: TButton;
+ PluginNameLabel: TLabel;
+ PlayingViaLabel: TLabel;
+ Label2: TLabel;
+ Label3: TLabel;
+ Label4: TLabel;
+ Label5: TLabel;
+ URLLabel: TLabel;
+ EMailLabel: TLabel;
+ procedure OkButtonClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure EMailLabelClick(Sender: TObject);
+ procedure URLLabelClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ end;
+
+procedure ShowInfo;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ GlobalsLocalUnit, ModalForm;
+
+var
+ infoForm: TInfoForm = nil;
+
+procedure ShowInfo;
+begin
+ if (not Assigned(infoForm)) then
+ begin
+ infoForm := TInfoForm.Create(nil);
+ if (TDialogs.HasStayOnTopOwners) then
+ infoForm.FormStyle := fsStayOnTop;
+{$IFDEF SKYPE}
+ infoForm.Icon := Chess4NetIcon;
+ infoForm.Caption := DIALOG_CAPTION;
+{$ELSE} // MI, TRILLIAN, AND_RQ, QIP
+ infoForm.Icon := pluginIcon;
+ infoForm.Caption := PLUGIN_NAME;
+{$ENDIF}
+ end;
+ if not infoForm.Showing then
+ infoForm.Show
+ else
+ infoForm.SetFocus;
+end;
+
+procedure TInfoForm.OkButtonClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TInfoForm.FormCreate(Sender: TObject);
+begin
+ PlayingViaLabel.Caption := PLUGIN_PLAYING_OVER;
+ PluginNameLabel.Caption := PLUGIN_INFO_NAME;
+ URLLabel.Caption := PLUGIN_URL;
+ EMailLabel.Caption := PLUGIN_EMAIL;
+end;
+
+procedure TInfoForm.URLLabelClick(Sender: TObject);
+begin
+ ShellExecute(Handle, nil, PChar(URLLabel.Caption), nil, nil, SW_SHOWNORMAL);
+end;
+
+procedure TInfoForm.EMailLabelClick(Sender: TObject);
+var
+ shellStr: string;
+begin
+ shellStr := 'mailto:' + EMailLabel.Caption;
+ ShellExecute(Handle, nil, PChar(shellStr), nil, nil, SW_SHOWNORMAL);
+end;
+
+procedure TInfoForm.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ infoForm := nil;
+ Action := caFree;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/IniSettingsUnit.pas b/plugins/!NotAdopted/Chess4Net/IniSettingsUnit.pas new file mode 100644 index 0000000000..468035404e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/IniSettingsUnit.pas @@ -0,0 +1,348 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit IniSettingsUnit;
+
+interface
+
+uses
+ TntIniFiles,
+ //
+ ChessBoardUnit, ChessRulesEngine;
+
+type
+ TIniSettingsID = (isidLastMoveHilighted, isidFlashOnMove, isidCoordinatesShown,
+ isidStayOnTop, isidExtraExit, isidActiveLanguage, isidDontShowLastVersion,
+ isidDontShowCredits, isidClock, isidTrainingMode, isidCanPauseGame,
+ isidCanAdjournGame, isidExternalBaseName, isidUseUserBase, isidAllowTakebacks,
+ isidAutoFlag, isidAdjourned);
+
+ TIniSettings = class
+ private
+ m_IniFile: TTntIniFile;
+
+ m_strOpponentId: string;
+
+ constructor FCreate;
+ function FGetIniFileName: string;
+
+ function FGetBooleanValue(ID: TIniSettingsID): boolean;
+ procedure FSetBooleanValue(ID: TIniSettingsID; bValue: boolean);
+
+ function FGetIntegerValue(ID: TIniSettingsID): integer;
+ procedure FSetIntegerValue(ID: TIniSettingsID; iValue: integer);
+
+ function FGetStringValue(ID: TIniSettingsID): string;
+ procedure FSetStringValue(ID: TIniSettingsID; const strValue: string);
+
+ function FGetAnimation: TAnimation;
+ procedure FSetAnimation(Value: TAnimation);
+
+ function FGetCommonSectionName: string;
+
+ function FGetPlayerColor: TFigureColor;
+ procedure FSetPlayerColor(Value: TFigureColor);
+
+ public
+ destructor Destroy; override;
+
+ class function Instance: TIniSettings;
+ class procedure FreeInstance; reintroduce;
+
+ procedure SetOpponentId(const strValue: string);
+ function HasCommonSettings: boolean;
+
+ // private settings
+ property Animation: TAnimation
+ read FGetAnimation write FSetAnimation;
+ property LastMoveHilighted: boolean index isidLastMoveHilighted
+ read FGetBooleanValue write FSetBooleanValue;
+ property FlashOnMove: boolean index isidFlashOnMove
+ read FGetBooleanValue write FSetBooleanValue;
+ property CoordinatesShown: boolean index isidCoordinatesShown
+ read FGetBooleanValue write FSetBooleanValue;
+ property StayOnTop: boolean index isidStayOnTop
+ read FGetBooleanValue write FSetBooleanValue;
+ property ExtraExit: boolean index isidExtraExit
+ read FGetBooleanValue write FSetBooleanValue;
+ property ActiveLanguage: integer index isidActiveLanguage
+ read FGetIntegerValue write FSetIntegerValue;
+ property DontShowLastVersion: integer index isidDontShowLastVersion
+ read FGetIntegerValue write FSetIntegerValue;
+ property DontShowCredits: boolean index isidDontShowCredits
+ read FGetBooleanValue write FSetBooleanValue;
+
+ // common settings
+ property PlayerColor: TFigureColor
+ read FGetPlayerColor write FSetPlayerColor;
+ property Clock: string index isidClock
+ read FGetStringValue write FSetStringValue;
+ property TrainingMode: boolean index isidTrainingMode
+ read FGetBooleanValue write FSetBooleanValue;
+ property CanPauseGame: boolean index isidCanPauseGame
+ read FGetBooleanValue write FSetBooleanValue;
+ property CanAdjournGame: boolean index isidCanAdjournGame
+ read FGetBooleanValue write FSetBooleanValue;
+ property ExternalBaseName: string index isidExternalBaseName
+ read FGetStringValue write FSetStringValue;
+ property UseUserBase: boolean index isidUseUserBase
+ read FGetBooleanValue write FSetBooleanValue;
+ property AllowTakebacks: boolean index isidAllowTakebacks
+ read FGetBooleanValue write FSetBooleanValue;
+ property AutoFlag: boolean index isidAutoFlag
+ read FGetBooleanValue write FSetBooleanValue;
+ property Adjourned: string index isidAdjourned
+ read FGetStringValue write FSetStringValue;
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ //
+ GlobalsUnit, GlobalsLocalUnit;
+
+const
+ INI_FILE_NAME = 'Chess4Net.ini';
+
+ PRIVATE_SECTION_NAME = 'Private';
+ COMMON_SECTION_PREFIX = 'Common';
+ ANIMATION_KEY_NAME = 'Animation';
+ HILIGHT_LAST_MOVE_KEY_NAME = 'HilightLastMove';
+ FLASH_ON_MOVE_NAME = 'FlashOnMove';
+ SHOW_COORDINATES_KEY_NAME = 'ShowCoordinates';
+ STAY_ON_TOP_KEY_NAME = 'StayOnTop';
+ EXTRA_EXIT_KEY_NAME = 'ExtraExit';
+ CAN_PAUSE_GAME_KEY_NAME = 'CanPauseGame';
+ CAN_ADJOURN_GAME_KEY_NAME = 'CanAdjournGame';
+ ALLOW_TAKEBACKS_KEY_NAME = 'AllowTakebacks';
+ EXTERNAL_BASE_NAME_KEY_NAME = 'ExternalBaseName';
+ USE_USER_BASE_KEY_NAME = 'UseUserBase';
+ AUTO_FLAG_KEY_NAME = 'AutoFlag';
+ TRAINING_MODE_KEY_NAME = 'TrainingMode';
+ PLAYER_COLOR_KEY_NAME = 'PlayerColor';
+ CLOCK_KEY_NAME = 'Clock';
+ ADJOURNED_KEY_NAME = 'Adjourned';
+ LANGUAGE_KEY_NAME = 'Language';
+ DONT_SHOW_CREDITS = 'DontShowCredits';
+ DONT_SHOW_LAST_VERSION = 'DontShowLastVersion';
+
+var
+ g_Instance: TIniSettings = nil;
+
+////////////////////////////////////////////////////////////////////////////////
+// TIniSettings
+
+constructor TIniSettings.FCreate;
+begin
+ inherited Create;
+ m_IniFile := TTntIniFile.Create(FGetIniFileName);
+end;
+
+
+destructor TIniSettings.Destroy;
+begin
+ m_IniFile.Free;
+ inherited;
+end;
+
+
+class function TIniSettings.Instance: TIniSettings;
+begin
+ if (not Assigned(g_Instance)) then
+ g_Instance := TIniSettings.FCreate;
+ Result := g_Instance;
+end;
+
+
+class procedure TIniSettings.FreeInstance;
+begin
+ FreeAndNil(g_Instance);
+end;
+
+
+function TIniSettings.FGetIniFileName: string;
+begin
+ Result := Chess4NetIniFilePath + INI_FILE_NAME;
+end;
+
+
+function TIniSettings.FGetAnimation: TAnimation;
+begin
+ Result := TAnimation(m_IniFile.ReadInteger(PRIVATE_SECTION_NAME, ANIMATION_KEY_NAME, Ord(aQuick)))
+end;
+
+
+procedure TIniSettings.FSetAnimation(Value: TAnimation);
+begin
+ m_IniFile.WriteInteger(PRIVATE_SECTION_NAME, ANIMATION_KEY_NAME, Ord(Value));
+end;
+
+
+function TIniSettings.FGetBooleanValue(ID: TIniSettingsID): boolean;
+begin
+ case ID of
+ isidLastMoveHilighted:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, HILIGHT_LAST_MOVE_KEY_NAME, FALSE);
+ isidFlashOnMove:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, FLASH_ON_MOVE_NAME, FALSE);
+ isidCoordinatesShown:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, SHOW_COORDINATES_KEY_NAME, TRUE);
+ isidStayOnTop:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, STAY_ON_TOP_KEY_NAME, FALSE);
+ isidExtraExit:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, EXTRA_EXIT_KEY_NAME, FALSE);
+ isidDontShowCredits:
+ Result := m_IniFile.ReadBool(PRIVATE_SECTION_NAME, DONT_SHOW_CREDITS, FALSE);
+ isidTrainingMode:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, TRAINING_MODE_KEY_NAME, FALSE);
+ isidCanPauseGame:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, CAN_PAUSE_GAME_KEY_NAME, FALSE);
+ isidCanAdjournGame:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, CAN_ADJOURN_GAME_KEY_NAME, FALSE);
+ isidUseUserBase:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, USE_USER_BASE_KEY_NAME, FALSE);
+ isidAllowTakebacks:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, ALLOW_TAKEBACKS_KEY_NAME, FALSE);
+ isidAutoFlag:
+ Result := m_IniFile.ReadBool(FGetCommonSectionName, AUTO_FLAG_KEY_NAME, FALSE);
+ else
+ Result := FALSE;
+ Assert(FALSE);
+ end;
+end;
+
+
+procedure TIniSettings.FSetBooleanValue(ID: TIniSettingsID; bValue: boolean);
+begin
+ case ID of
+ isidLastMoveHilighted:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, HILIGHT_LAST_MOVE_KEY_NAME, bValue);
+ isidFlashOnMove:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, FLASH_ON_MOVE_NAME, bValue);
+ isidCoordinatesShown:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, SHOW_COORDINATES_KEY_NAME, bValue);
+ isidStayOnTop:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, STAY_ON_TOP_KEY_NAME, bValue);
+ isidExtraExit:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, EXTRA_EXIT_KEY_NAME, bValue);
+ isidDontShowCredits:
+ m_IniFile.WriteBool(PRIVATE_SECTION_NAME, DONT_SHOW_CREDITS, bValue);
+ isidTrainingMode:
+ m_IniFile.WriteBool(FGetCommonSectionName, TRAINING_MODE_KEY_NAME, bValue);
+ isidCanPauseGame:
+ m_IniFile.WriteBool(FGetCommonSectionName, CAN_PAUSE_GAME_KEY_NAME, bValue);
+ isidCanAdjournGame:
+ m_IniFile.WriteBool(FGetCommonSectionName, CAN_ADJOURN_GAME_KEY_NAME, bValue);
+ isidUseUserBase:
+ m_IniFile.WriteBool(FGetCommonSectionName, USE_USER_BASE_KEY_NAME, bValue);
+ isidAllowTakebacks:
+ m_IniFile.WriteBool(FGetCommonSectionName, ALLOW_TAKEBACKS_KEY_NAME, bValue);
+ isidAutoFlag:
+ m_IniFile.WriteBool(FGetCommonSectionName, AUTO_FLAG_KEY_NAME, bValue);
+ else
+ Assert(FALSE);
+ end;
+end;
+
+
+function TIniSettings.FGetIntegerValue(ID: TIniSettingsID): integer;
+begin
+ case ID of
+ isidActiveLanguage:
+ Result := m_IniFile.ReadInteger(PRIVATE_SECTION_NAME, LANGUAGE_KEY_NAME, 1) - 1;
+ isidDontShowLastVersion:
+ Result := m_IniFile.ReadInteger(PRIVATE_SECTION_NAME, DONT_SHOW_LAST_VERSION, CHESS4NET_VERSION);
+ else
+ Result := 0;
+ Assert(FALSE);
+ end;
+end;
+
+
+procedure TIniSettings.FSetIntegerValue(ID: TIniSettingsID; iValue: integer);
+begin
+ case ID of
+ isidActiveLanguage:
+ m_IniFile.WriteInteger(PRIVATE_SECTION_NAME, LANGUAGE_KEY_NAME, iValue + 1);
+ isidDontShowLastVersion:
+ m_IniFile.WriteInteger(PRIVATE_SECTION_NAME, DONT_SHOW_LAST_VERSION, iValue);
+ else
+ Assert(FALSE);
+ end;
+end;
+
+
+function TIniSettings.FGetStringValue(ID: TIniSettingsID): string;
+begin
+ case ID of
+ isidClock:
+ Result := m_IniFile.ReadString(FGetCommonSectionName, CLOCK_KEY_NAME, INITIAL_CLOCK_TIME);
+ isidExternalBaseName:
+ Result := m_IniFile.ReadString(FGetCommonSectionName, EXTERNAL_BASE_NAME_KEY_NAME, '');
+ isidAdjourned:
+ Result := m_IniFile.ReadString(FGetCommonSectionName, ADJOURNED_KEY_NAME, '');
+ else
+ Result := '';
+ Assert(FALSE);
+ end;
+end;
+
+
+procedure TIniSettings.FSetStringValue(ID: TIniSettingsID; const strValue: string);
+begin
+ case ID of
+ isidClock:
+ m_IniFile.WriteString(FGetCommonSectionName, CLOCK_KEY_NAME, strValue);
+ isidExternalBaseName:
+ m_IniFile.WriteString(FGetCommonSectionName, EXTERNAL_BASE_NAME_KEY_NAME, strValue);
+ isidAdjourned:
+ begin
+ m_IniFile.WriteString(FGetCommonSectionName, ADJOURNED_KEY_NAME, strValue);
+ m_IniFile.UpdateFile;
+ end;
+ else
+ Assert(FALSE);
+ end;
+end;
+
+
+procedure TIniSettings.SetOpponentId(const strValue: string);
+begin
+ m_strOpponentId := strValue;
+end;
+
+
+function TIniSettings.HasCommonSettings: boolean;
+begin
+ Result := m_IniFile.SectionExists(FGetCommonSectionName);
+end;
+
+
+function TIniSettings.FGetCommonSectionName: string;
+begin
+ Result := COMMON_SECTION_PREFIX + ' ' + m_strOpponentId;
+end;
+
+
+function TIniSettings.FGetPlayerColor: TFigureColor;
+begin
+ Result := TFigureColor(m_IniFile.ReadInteger(
+ FGetCommonSectionName, PLAYER_COLOR_KEY_NAME, Ord(fcBlack)))
+end;
+
+
+procedure TIniSettings.FSetPlayerColor(Value: TFigureColor);
+begin
+ m_IniFile.WriteInteger(FGetCommonSectionName, PLAYER_COLOR_KEY_NAME, Ord(Value));
+end;
+
+initialization
+
+finalization
+ TIniSettings.FreeInstance;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/Lang.ini b/plugins/!NotAdopted/Chess4Net/Lang.ini Binary files differnew file mode 100644 index 0000000000..6aa5de5595 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Lang.ini diff --git a/plugins/!NotAdopted/Chess4Net/LocalizerUnit.pas b/plugins/!NotAdopted/Chess4Net/LocalizerUnit.pas new file mode 100644 index 0000000000..bd4644bbc3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/LocalizerUnit.pas @@ -0,0 +1,413 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit LocalizerUnit;
+
+interface
+
+uses
+ SysUtils, TntSysUtils, Classes, TntClasses;
+
+type
+ // A singletone that is used to localize interface
+ ILocalizable = interface
+ procedure Localize;
+ end;
+
+ ELocalizer = class(Exception);
+ TLocalizer = class
+ private
+ m_IniFileName: TFileName;
+ m_iLangugesCount: integer;
+ m_wstrarLanguageNames: array of WideString;
+ m_wstrlLabels, m_wstrlMessages: TTntStringList;
+ m_iActiveLanguage: integer;
+ m_Subscribers: TList;
+
+ constructor Create;
+ procedure FReadLanguages;
+ function FGetLangaugeName(iIndex: integer): WideString;
+ procedure FSetActiveLanguage(iIndex: integer);
+ function FReadLanguageData(iIndex: integer): boolean;
+ procedure FNotifySubscribers;
+
+ public
+ destructor Destroy; override;
+ class function Instance: TLocalizer;
+ class procedure FreeInstance; reintroduce;
+ property LanguagesCount: integer read m_iLangugesCount;
+ // Returns a language name depending on its index
+ function GetLabel(iIndex: integer): WideString;
+ function GetMessage(iIndex: integer): WideString; overload;
+ function GetMessage(iIndex: integer; wstrarParams: array of const): WideString; overload;
+ procedure AddSubscriber(const Subscriber: ILocalizable);
+ procedure DeleteSubscriber(const Subscriber: ILocalizable);
+ property LanguageName[iIndex: integer]: WideString read FGetLangaugeName;
+ property ActiveLanguage: integer read m_iActiveLanguage write FSetActiveLanguage;
+ end;
+
+implementation
+
+uses
+ StrUtils, Forms, TntIniFiles,
+ //
+ GlobalsUnit;
+
+const
+ LOCALIZER_INI_FILE = 'Lang.ini';
+
+ // Labels are used to name interface controls s.a. TLabel and the like
+ DEFAULT_LABELS: array[0..69] of WideString =
+ ('Look & Feel Options', {0}
+ 'Animate Move:',
+ 'No',
+ 'Slowly',
+ 'Quickly',
+ 'Highlight Last Move',
+ 'Flash on incoming move',
+ 'Show Coordinates',
+ 'Stay Always on Top',
+ 'Extra Exit on ESC',
+ 'GUI Language:', {10}
+ '&OK',
+ '&Cancel',
+ 'White ',
+ 'White ',
+ 'W ',
+ 'Black ',
+ 'Black ',
+ 'B ',
+ 'Connecting...',
+ 'Wait until the connection is completed.', {20}
+ '&Abort',
+ 'Press button to continue the game.',
+ '&Continue',
+ 'Game Options',
+ 'Time Control',
+ 'Equal time for both players',
+ 'Your time',
+ 'Opponent''s time',
+ 'Unlimited',
+ 'Minutes per game:', {30}
+ 'Increment in seconds:',
+ 'Training Mode',
+ 'Enabled',
+ 'External base:',
+ 'Use user base',
+ 'Game can be paused',
+ 'Game can be adjourned',
+ 'Allow takebacks to your partner',
+ 'Auto Flag',
+ 'Yes', {40}
+ 'No',
+ 'OK',
+ 'Cancel',
+ 'Abort',
+ 'Retry',
+ 'Ignore',
+ 'All',
+ 'NoToAll',
+ 'YesToAll',
+ 'Help', {50}
+ 'Start Adjourned Game',
+ 'Start Standart Game',
+ 'Start PP Random Game',
+ 'Change Color',
+ 'Game Options...',
+ 'Look && Feel Options...',
+ 'About...',
+ 'Abort',
+ 'Draw',
+ 'Resign', {60}
+ 'Adjourn',
+ 'Pause',
+ 'Takeback',
+ 'If you liked plying Chess4Net give your credits at',
+ '&Close',
+ 'Don''t show again',
+ 'Transmit Game',
+ 'Select Skype contact',
+ 'Broadcast...'
+ );
+
+ // Messages are used in message boxes
+ DEFAULT_MESSAGES: array[0..37] of WideString =
+ ('White is checkmated. You win.', {0}
+ 'White is checkmated. You loose.',
+ 'Black is checkmated. You win.',
+ 'Black is checkmated. You loose.',
+ 'It''s stalemate. No one wins.',
+ 'Your opponent leaves.',
+ 'Your opponent leaves. The game is aborted.',
+ 'An error during connection occured.',
+ 'Your opponent is using an older version of Chess4Net.' + sLineBreak +
+ 'Most of functionality will be not available.' + sLineBreak +
+ 'Please, ask him/her to update the client.',
+ 'The current version of Chess4Net is incompatible with the one of your partner.' + sLineBreak +
+ 'Please check the versions.',
+ 'Draw?', {10}
+ 'Can we abort the game?',
+ 'I resign. You win this game. Congratulations!',
+ 'The game is aborted.',
+ 'Sorry, but we have to finish this game.',
+ 'The game is drawn.',
+ 'No draw, sorry.',
+ 'You forfeited on time.',
+ 'Your opponent forfeited on time.',
+ 'Can we pause the game?',
+ 'No pause, sorry.', {20}
+ 'May I take back last move?',
+ 'Can we adjourn this game?',
+ 'No adjourns, sorry.',
+ 'Sorry, no takebacks!',
+ 'Do you really want to resign?',
+ 'Do you want to exit?',
+ 'The game is adjourned.',
+ 'You are currently playing some games. Do you want to start broadcasting?',
+ 'Black forfeits on time.',
+ 'White forfeits on time.', {30}
+ 'White resigns.',
+ 'Black resigns.',
+ 'Game transmition is not supported by this client!',
+ 'Broadcaster leaves. Transmition will be closed.',
+ 'Stalemate.',
+ 'White is checkmated.',
+ 'Black is checkmated.'
+ );
+
+var
+ LocalizerInstance: TLocalizer = nil;
+
+////////////////////////////////////////////////////////////////////////////////
+// TLocalizer
+
+constructor TLocalizer.Create;
+begin
+ m_IniFileName := Chess4NetPath + LOCALIZER_INI_FILE;
+
+ m_wstrlLabels := TTntStringList.Create;
+ m_wstrlMessages := TTntStringList.Create;
+
+ m_Subscribers := TList.Create;
+
+ m_iActiveLanguage := -1;
+ FReadLanguages;
+ FReadLanguageData(-1);
+end;
+
+
+destructor TLocalizer.Destroy;
+begin
+ Finalize(m_wstrarLanguageNames);
+
+ m_Subscribers.Free;
+
+ m_wstrlMessages.Free;
+ m_wstrlLabels.Free;
+
+ inherited;
+end;
+
+
+class function TLocalizer.Instance: TLocalizer;
+begin
+ if (not Assigned(LocalizerInstance)) then
+ LocalizerInstance := TLocalizer.Create;
+ Result := LocalizerInstance;
+end;
+
+
+class procedure TLocalizer.FreeInstance;
+begin
+ FreeAndNil(LocalizerInstance);
+end;
+
+
+procedure TLocalizer.FReadLanguages;
+var
+ IniFile: TTntIniFile;
+ i: integer;
+ wstrSection: WideString;
+begin
+ if (not FileExists(m_IniFileName)) then
+ exit;
+
+ IniFile := TTntIniFile.Create(m_IniFileName);
+ try
+ // Count available languages
+ Finalize(m_wstrarLanguageNames);
+ i := 0;
+ repeat
+ wstrSection := 'Language' + IntToStr(i + 1);
+ if (not IniFile.SectionExists(wstrSection)) then
+ break;
+ SetLength(m_wstrarLanguageNames, length(m_wstrarLanguageNames) + 1);
+ m_wstrarLanguageNames[i] := IniFile.ReadString(wstrSection, 'Name', '<unknown>');
+ inc(i);
+ until FALSE;
+ m_iLangugesCount := i;
+
+ finally
+ IniFile.Free;
+ end;
+end;
+
+
+function TLocalizer.FGetLangaugeName(iIndex: integer): WideString;
+begin
+ Result := m_wstrarLanguageNames[iIndex];
+end;
+
+
+procedure TLocalizer.FSetActiveLanguage(iIndex: integer);
+begin
+ if (iIndex <> m_iActiveLanguage) then
+ begin
+ if (FReadLanguageData(iIndex)) then
+ begin
+ m_iActiveLanguage := iIndex;
+ FNotifySubscribers;
+ end
+ else
+ m_iActiveLanguage := -1;
+ end;
+end;
+
+
+function TLocalizer.FReadLanguageData(iIndex: integer): boolean;
+
+ function NInsertLineFeeds(const wstrSource: WideString): WideString;
+ var
+ iPos, iOffset: integer;
+ begin
+ Result := '';
+ iOffset := 1;
+ repeat
+ iPos := PosEx('/n', wstrSource, iOffset);
+ if (iPos = 0) then
+ break;
+ if ((iPos = 1) or (wstrSource[iPos - 1] <> '/')) then
+ Result := Result + Copy(wstrSource, iOffset, iPos - iOffset) + sLineBreak
+ else
+ Result := Result + Copy(wstrSource, iOffset, iPos - iOffset) + 'n'; // '//n' -> '/n'
+ iOffset := iPos + 2;
+ until FALSE;
+
+ Result := Result + Copy(wstrSource, iOffset, MaxInt);
+ end;
+
+var
+ IniFile: TTntIniFile;
+ i: integer;
+ wstrSection: WideString;
+ wstrlValues: TTntStringList;
+ wstrValue: WideString;
+begin
+ Result := FALSE;
+
+ // Copy default values
+ m_wstrlLabels.Clear;
+ for i := Low(DEFAULT_LABELS) to High(DEFAULT_LABELS) do
+ m_wstrlLabels.Add(DEFAULT_LABELS[i]);
+
+ m_wstrlMessages.Clear;
+ for i := Low(DEFAULT_MESSAGES) to High(DEFAULT_MESSAGES) do
+ m_wstrlMessages.Add(DEFAULT_MESSAGES[i]);
+
+ if (not FileExists(m_IniFileName)) then
+ exit;
+
+ wstrlValues := nil;
+ IniFile := TTntIniFile.Create(m_IniFileName);
+ try
+ wstrSection := 'Language' + IntToStr(iIndex + 1);
+ if (not IniFile.SectionExists(wstrSection)) then
+ exit;
+
+ wstrlValues := TTntStringList.Create;
+ IniFile.ReadSectionValues(wstrSection, wstrlValues);
+
+ for i := 0 to m_wstrlLabels.Count - 1 do
+ begin
+ wstrValue := wstrlValues.Values['Label' + IntToStr(i)];
+ if (wstrValue <> '') then
+ begin
+ if (wstrValue[length(wstrValue)] = '|') then // labels with a width
+ wstrValue := Copy(wstrValue, 1, length(wstrValue) - 1);
+ m_wstrlLabels[i] := wstrValue;
+ end;
+ end;
+ for i := 0 to m_wstrlMessages.Count - 1 do
+ begin
+ wstrValue := wstrlValues.Values['Msg' + IntToStr(i)];
+ if (wstrValue <> '') then
+ m_wstrlMessages[i] := NInsertLineFeeds(wstrValue);
+ end;
+
+ finally
+ wstrlValues.Free;
+ IniFile.Free;
+ end;
+
+ Result := TRUE;
+end;
+
+
+function TLocalizer.GetLabel(iIndex: integer): WideString;
+begin
+ if (iIndex in [0..m_wstrlLabels.Count - 1]) then
+ Result := m_wstrlLabels[iIndex]
+ else
+ ELocalizer.Create('Wrong label index!');
+end;
+
+
+function TLocalizer.GetMessage(iIndex: integer): WideString;
+begin
+ if (iIndex in [0..m_wstrlMessages.Count - 1]) then
+ Result := m_wstrlMessages[iIndex]
+ else
+ ELocalizer.Create('Wrong message index!');
+end;
+
+
+function TLocalizer.GetMessage(iIndex: integer; wstrarParams: array of const): WideString;
+begin
+ Result := WideFormat(GetMessage(iIndex), wstrarParams)
+end;
+
+
+procedure TLocalizer.AddSubscriber(const Subscriber: ILocalizable);
+begin
+ if (m_Subscribers.IndexOf(Pointer(Subscriber)) < 0) then
+ m_Subscribers.Add(Pointer(Subscriber));
+end;
+
+
+procedure TLocalizer.DeleteSubscriber(const Subscriber: ILocalizable);
+var
+ iIndex: integer;
+begin
+ iIndex := m_Subscribers.IndexOf(Pointer(Subscriber));
+ if (iIndex >= 0) then
+ m_Subscribers.Delete(iIndex);
+end;
+
+
+procedure TLocalizer.FNotifySubscribers;
+var
+ i: integer;
+begin
+ for i := 0 to m_Subscribers.Count - 1 do
+ ILocalizable(m_Subscribers[i]).Localize;
+end;
+
+initialization
+
+finalization
+ TLocalizer.FreeInstance;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.dfm b/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.dfm new file mode 100644 index 0000000000..c3fda14bce --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.dfm @@ -0,0 +1,142 @@ +object LookFeelOptionsForm: TLookFeelOptionsForm
+ Left = 702
+ Top = 299
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsDialog
+ Caption = 'Look & Feel Options'
+ ClientHeight = 217
+ ClientWidth = 321
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ PixelsPerInch = 96
+ TextHeight = 13
+ object AnimateLabel: TTntLabel
+ Left = 8
+ Top = 11
+ Width = 89
+ Height = 13
+ AutoSize = False
+ Caption = 'Animate Move:'
+ end
+ object GUILangLabel: TTntLabel
+ Left = 8
+ Top = 187
+ Width = 97
+ Height = 13
+ AutoSize = False
+ Caption = 'GUI Language:'
+ end
+ object OkButton: TTntButton
+ Left = 240
+ Top = 8
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 2
+ end
+ object CancelButton: TTntButton
+ Left = 240
+ Top = 40
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Cancel'
+ ModalResult = 2
+ TabOrder = 3
+ end
+ object AnimationComboBox: TTntComboBox
+ Left = 104
+ Top = 8
+ Width = 81
+ Height = 21
+ Style = csDropDownList
+ ItemHeight = 13
+ ItemIndex = 0
+ TabOrder = 0
+ Text = 'No'
+ Items.Strings = (
+ 'No'
+ 'Slowly'
+ 'Quickly')
+ end
+ object BoxPanel: TPanel
+ Left = 8
+ Top = 40
+ Width = 217
+ Height = 129
+ BevelInner = bvRaised
+ BevelOuter = bvLowered
+ TabOrder = 1
+ DesignSize = (
+ 217
+ 129)
+ object HilightLastMoveBox: TTntCheckBox
+ Left = 8
+ Top = 8
+ Width = 201
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Highlight Last Move'
+ TabOrder = 0
+ end
+ object CoordinatesBox: TTntCheckBox
+ Left = 8
+ Top = 56
+ Width = 201
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Show Coordinates'
+ TabOrder = 1
+ end
+ object StayOnTopBox: TTntCheckBox
+ Left = 8
+ Top = 80
+ Width = 201
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Stay Always on Top'
+ TabOrder = 2
+ end
+ object ExtraExitBox: TTntCheckBox
+ Left = 8
+ Top = 104
+ Width = 201
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Extra Exit on ESC'
+ TabOrder = 3
+ end
+ object FlashIncomingMoveBox: TTntCheckBox
+ Left = 8
+ Top = 32
+ Width = 201
+ Height = 17
+ Anchors = [akLeft, akTop, akRight]
+ Caption = 'Flash on incoming move'
+ TabOrder = 4
+ end
+ end
+ object GUILangComboBox: TTntComboBox
+ Left = 120
+ Top = 184
+ Width = 129
+ Height = 21
+ Style = csDropDownList
+ ItemHeight = 13
+ ItemIndex = 0
+ TabOrder = 4
+ Text = 'English'
+ OnChange = GUILangComboBoxChange
+ Items.Strings = (
+ 'English')
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.pas b/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.pas new file mode 100644 index 0000000000..7fe03b2a70 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/LookFeelOptionsUnit.pas @@ -0,0 +1,110 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit LookFeelOptionsUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ExtCtrls,
+ ModalForm, TntStdCtrls,
+ // Chess4Net units
+ LocalizerUnit;
+
+type
+ TLookFeelOptionsForm = class(TModalForm, ILocalizable)
+ OkButton: TTntButton;
+ CancelButton: TTntButton;
+ AnimationComboBox: TTntComboBox;
+ AnimateLabel: TTntLabel;
+ BoxPanel: TPanel;
+ HilightLastMoveBox: TTntCheckBox;
+ FlashIncomingMoveBox: TTntCheckBox;
+ CoordinatesBox: TTntCheckBox;
+ StayOnTopBox: TTntCheckBox;
+ ExtraExitBox: TTntCheckBox;
+ GUILangLabel: TTntLabel;
+ GUILangComboBox: TTntComboBox;
+ procedure FormCreate(Sender: TObject);
+ procedure GUILangComboBoxChange(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ private
+ procedure ILocalizable.Localize = FLocalize;
+ procedure FLocalize;
+ protected
+ function GetModalID: TModalFormID; override;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+function TLookFeelOptionsForm. GetModalID: TModalFormID;
+begin
+ Result := mfLookFeel;
+end;
+
+
+procedure TLookFeelOptionsForm.FormCreate(Sender: TObject);
+var
+ i: integer;
+begin
+ // Fill GUI Languages combo box
+ GUILangComboBox.Clear;
+ with TLocalizer.Instance do
+ begin
+ for i := 0 to LanguagesCount - 1 do
+ GUILangComboBox.Items.Add(LanguageName[i]);
+ GUILangComboBox.ItemIndex := ActiveLanguage;
+ end;
+
+ TLocalizer.Instance.AddSubscriber(self);
+ FLocalize;
+end;
+
+
+procedure TLookFeelOptionsForm.FLocalize;
+var
+ iSavedAnimation: integer;
+begin
+ with TLocalizer.Instance do
+ begin
+ Caption := GetLabel(0);
+ AnimateLabel.Caption := GetLabel(1);
+ with AnimationComboBox do
+ begin
+ iSavedAnimation := ItemIndex;
+ Items[0] := GetLabel(2);
+ Items[1] := GetLabel(3);
+ Items[2] := GetLabel(4);
+ ItemIndex := iSavedAnimation;
+ end;
+ HilightLastMoveBox.Caption := GetLabel(5);
+ FlashIncomingMoveBox.Caption := GetLabel(6);
+ CoordinatesBox.Caption := GetLabel(7);
+ StayOnTopBox.Caption := GetLabel(8);
+ ExtraExitBox.Caption := GetLabel(9);
+ GUILangLabel.Caption := GetLabel(10);
+
+ OkButton.Caption := GetLabel(11);
+ CancelButton.Caption := GetLabel(12);
+ end;
+end;
+
+
+procedure TLookFeelOptionsForm.GUILangComboBoxChange(Sender: TObject);
+begin
+ TLocalizer.Instance.ActiveLanguage := GUILangComboBox.ItemIndex;
+end;
+
+
+procedure TLookFeelOptionsForm.FormDestroy(Sender: TObject);
+begin
+ TLocalizer.Instance.DeleteSubscriber(self);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.cfg b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.cfg new file mode 100644 index 0000000000..6d8fdcc3db --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.cfg @@ -0,0 +1,45 @@ +-$A8
+-$B-
+-$C-
+-$D-
+-$E-
+-$F-
+-$G+
+-$H+
+-$I-
+-$J+
+-$K-
+-$L-
+-$M-
+-$N+
+-$O+
+-$P+
+-$Q-
+-$R-
+-$S-
+-$T-
+-$U-
+-$V+
+-$W-
+-$X+
+-$Y-
+-$Z1
+-cg
+-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+-H+
+-W+
+-M
+-$M16384,1048576
+-K$00400000
+-E"..\bin"
+-N".\dcu"
+-LE"c:\program files\borland\delphi7\Projects\Bpl"
+-LN"c:\program files\borland\delphi7\Projects\Bpl"
+-U".\MirandaINC;..\res\Delphi;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source"
+-O".\MirandaINC;..\res\Delphi;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source"
+-I".\MirandaINC;..\res\Delphi;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source"
+-R".\MirandaINC;..\res\Delphi;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source"
+-DMIRANDA;xFASTMM4;xDEBUG_LOG
+-w-UNSAFE_TYPE
+-w-UNSAFE_CODE
+-w-UNSAFE_CAST
diff --git a/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dof b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dof new file mode 100644 index 0000000000..5b7c6eacea --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dof @@ -0,0 +1,170 @@ +[FileVersion]
+Version=7.0
+[Compiler]
+A=8
+B=0
+C=0
+D=0
+E=0
+F=0
+G=1
+H=1
+I=0
+J=1
+K=0
+L=0
+M=0
+N=1
+O=1
+P=1
+Q=0
+R=0
+S=0
+T=0
+U=0
+V=1
+W=0
+X=1
+Y=0
+Z=1
+ShowHints=1
+ShowWarnings=1
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+NamespacePrefix=
+SymbolDeprecated=1
+SymbolLibrary=1
+SymbolPlatform=1
+UnitLibrary=1
+UnitPlatform=1
+UnitDeprecated=1
+HResultCompat=1
+HidingMember=1
+HiddenVirtual=1
+Garbage=1
+BoundsError=1
+ZeroNilCompat=1
+StringConstTruncated=1
+ForLoopVarVarPar=1
+TypedConstVarPar=1
+AsgToTypedConst=1
+CaseLabelRange=1
+ForVariable=1
+ConstructingAbstract=1
+ComparisonFalse=1
+ComparisonTrue=1
+ComparingSignedUnsigned=1
+CombiningSignedUnsigned=1
+UnsupportedConstruct=1
+FileOpen=1
+FileOpenUnitSrc=1
+BadGlobalSymbol=1
+DuplicateConstructorDestructor=1
+InvalidDirective=1
+PackageNoLink=1
+PackageThreadVar=1
+ImplicitImport=1
+HPPEMITIgnored=1
+NoRetVal=1
+UseBeforeDef=1
+ForLoopVarUndef=1
+UnitNameMismatch=1
+NoCFGFileFound=1
+MessageDirective=1
+ImplicitVariants=1
+UnicodeToLocale=1
+LocaleToUnicode=1
+ImagebaseMultiple=1
+SuspiciousTypecast=1
+PrivatePropAccessor=1
+UnsafeType=0
+UnsafeCode=0
+UnsafeCast=0
+[Linker]
+MapFile=0
+OutputObjs=0
+ConsoleApp=1
+DebugInfo=0
+RemoteSymbols=0
+MinStackSize=16384
+MaxStackSize=1048576
+ImageBase=4194304
+ExeDescription=
+[Directories]
+OutputDir=..\bin
+UnitOutputDir=.\dcu
+PackageDLLOutputDir=
+PackageDCPOutputDir=
+SearchPath=.\MirandaINC;..\res\Delphi;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source
+Packages=vcl;rtl;dbrtl;vcldb;vclx;bdertl;delphiclxide;proide;delphivclide;direct;vclie;stride;VclSmp;vclactnband
+Conditionals=MIRANDA;xFASTMM4;xDEBUG_LOG
+DebugSourceDirs=
+UsePackages=0
+[Parameters]
+RunParams=
+HostApplication=
+Launcher=
+UseLauncher=0
+DebugCWD=
+[Language]
+ActiveLang=
+ProjectLang=
+RootDir=
+[Version Info]
+IncludeVerInfo=0
+AutoIncBuild=0
+MajorVer=1
+MinorVer=0
+Release=0
+Build=0
+Debug=0
+PreRelease=0
+Special=0
+Private=0
+DLL=0
+Locale=1049
+CodePage=1251
+[Version Info Keys]
+CompanyName=
+FileDescription=
+FileVersion=1.0.0.0
+InternalName=
+LegalCopyright=
+LegalTrademarks=
+OriginalFilename=
+ProductName=
+ProductVersion=1.0.0.0
+Comments=
+[HistoryLists\hlConditionals]
+Count=15
+Item0=SKYPE;xFASTMM4;TESTING;SKYPE_API
+Item1=SKYPE;xFASTMM4;xTESTING;SKYPE_API
+Item2=SKYPE;xFASTMM4;xTESTING;xSKYPE_API
+Item3=SKYPE;xFASTMM4;xTESTING;xSKYPE_API;TESTING
+Item4=SKYPE;xFASTMM4;xTESTING;SKYPE_API;TESTING
+Item5=SKYPE;xFASTMM4;xTESTING;SKYPE_API;xDEBUG_LOG
+Item6=SKYPE;xFASTMM4;TESTING;SKYPE_API;xDEBUG_LOG
+Item7=SKYPE;xFASTMM4;xTESTING;xSKYPE_API;xDEBUG_LOG
+Item8=SKYPE;xFASTMM4;TESTING;xSKYPE_API;xDEBUG_LOG;xTESTING
+Item9=SKYPE;xFASTMM4;TESTING;xSKYPE_API;xDEBUG_LOG;TESTING
+Item10=SOCKET;xFASTMM4
+Item11=SKYPE;xFASTMM4;xTESTING;xSKYPE_API;xDEBUG_LOG;TESTING
+Item12=SKYPE;xFASTMM4;xTESTING;xSKYPE_API;DEBUG_LOG
+Item13=SKYPE;xFASTMM4;TESTING;xSKYPE_API;DEBUG_LOG
+Item14=SKYPE;xFASTMM4;TESTING;xSKYPE_API;xDEBUG_LOG
+[HistoryLists\hlUnitAliases]
+Count=1
+Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+[HistoryLists\hlSearchPath]
+Count=5
+Item0=$(DELPHI)\Lib\Debug;..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source;.\SkypeAPI
+Item1=..\lib\FastMM4;..\lib\PNGImage;..\lib\XIE;..\lib\TntUnicodeControls\Source;.\SkypeAPI
+Item2=$(DELPHI)\Lib\Debug;..\lib\FastMM4;..\lib\PNGImage;..\lib\TntUnicodeControls\Source
+Item3=..\lib\FastMM4;..\lib\PNGImage;..\lib\TntUnicodeControls\Source;.\SkypeAPI
+Item4=$(DELPHI)\Lib\Debug;..\lib\FastMM4;..\lib\PNGImage;..\lib\TntUnicodeControls\Source;.\SkypeAPI
+[HistoryLists\hlUnitOutputDirectory]
+Count=1
+Item0=.\dcu
+[HistoryLists\hlOutputDirectorry]
+Count=2
+Item0=..\bin\Chess4Net_Skype
+Item1=..\bin
diff --git a/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dpr b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dpr new file mode 100644 index 0000000000..bc07ffc32c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/Chess4Net_MI.dpr @@ -0,0 +1,82 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+library Chess4Net_MI;
+{*******************************
+ plugin library for Miranda
+********************************}
+
+(*
+{$IFDEF FASTMM4}
+ FastMM4,
+{$ENDIF}
+*)
+
+uses
+{$IFDEF FASTMM4}
+ FastMM4,
+{$ENDIF}
+ Forms,
+ SysUtils,
+ Windows,
+ BitmapResUnit in '..\BitmapResUnit.pas',
+ ChessBoardHeaderUnit in '..\ChessBoardHeaderUnit.pas',
+ ChessBoardUnit in '..\ChessBoardUnit.pas' {ChessBoard},
+ PosBaseChessBoardLayerUnit in '..\PosBaseChessBoardLayerUnit.pas',
+ GameChessBoardUnit in '..\GameChessBoardUnit.pas' {GameChessBoard},
+ ConnectingUnit in '..\ConnectingUnit.pas' {ConnectingForm},
+ ConnectorUnit in 'ConnectorUnit.pas',
+ ContinueUnit in '..\ContinueUnit.pas' {ContinueForm},
+ ControlUnit in 'ControlUnit.pas',
+ DialogUnit in '..\DialogUnit.pas',
+ GameOptionsUnit in '..\GameOptionsUnit.pas' {GameOptionsForm},
+ GlobalsLocalUnit in 'GlobalsLocalUnit.pas',
+ GlobalsUnit in '..\GlobalsUnit.pas',
+ InfoUnit in '..\InfoUnit.pas' {InfoForm},
+ LocalizerUnit in '..\LocalizerUnit.pas',
+ LookFeelOptionsUnit in '..\LookFeelOptionsUnit.pas' {OptionsForm},
+ ManagerUnit in '..\ManagerUnit.pas' {Manager},
+ MessageDialogUnit in '..\MessageDialogUnit.pas',
+ ModalForm in '..\ModalForm.pas',
+ PluginCommonUnit in 'PluginCommonUnit.pas',
+ PosBaseUnit in '..\PosBaseUnit.pas',
+ PromotionUnit in '..\PromotionUnit.pas' {PromotionForm},
+ ChessRulesEngine in '..\ChessRulesEngine.pas',
+ ManagerUnit.MI in 'ManagerUnit.MI.pas',
+ TransmitGameSelectionUnit in 'TransmitGameSelectionUnit.pas' {TransmitGameSelectionForm},
+ ChessClockUnit in '..\ChessClockUnit.pas',
+ URLVersionQueryUnit in '..\URLVersionQueryUnit.pas',
+ DontShowMessageDlgUnit in '..\DontShowMessageDlgUnit.pas',
+ IniSettingsUnit in '..\IniSettingsUnit.pas',
+ NonRefInterfacedObjectUnit in '..\NonRefInterfacedObjectUnit.pas';
+
+{$R ..\Chess4Net.res}
+
+begin
+ ControlUnit.PLUGIN_NAME := 'Chess4Net';
+ PLUGIN_MENU_NAME := '&Chess4Net';
+
+ with _PluginInfo^ do
+ begin
+ shortName := 'Chess4Net';
+ version := MakeMirandaPluginVersion(201,1,0,1); // 2010.0
+ description := PLUGIN_PLAYING_OVER;
+ author := 'Pavel Perminov';
+ authorEmail := 'packpaul@mail.ru';
+ copyright := '(c) 2007-2011 No Copyrights';
+ homepage := 'http://www.chess4net.ru';
+ end;
+
+ guidPlugin := StringToGUID('{BF17C6E3-C52C-4CB8-88ED-E0FC5F5D566A}');
+ miidPlugin := StringToGUID('{EBB410F6-E9AA-4F1B-8912-8C41E4EC0F90}'); // interface
+
+ MirandaPluginMenuPosition := $7FFFFFFF; // or < $7FFFFFFF
+
+ gCreatePluginInstance := CreatePluginInstance;
+ gInitializeControls := InitializeControls;
+ gDeinitializeControls := DeinitializeControls;
+ gErrorDuringPluginStart := ErrorDuringPluginStart;
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/ConnectorUnit.pas b/plugins/!NotAdopted/Chess4Net/MI/ConnectorUnit.pas new file mode 100644 index 0000000000..525ebb3b22 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/ConnectorUnit.pas @@ -0,0 +1,841 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ConnectorUnit;
+
+interface
+
+uses
+ Classes, ExtCtrls,
+ m_globaldefs;
+
+type
+ TConnectorEvent = (ceConnected, ceDisconnected, ceData, ceError);
+
+ TConnectorHandler = procedure(ce: TConnectorEvent; d1: pointer = nil;
+ d2: pointer = nil) of object;
+
+ IConnectorable = interface
+ procedure ConnectorHandler(ce: TConnectorEvent; d1: pointer = nil; d2: pointer = nil);
+ end;
+
+ TConnector = class
+ private
+ _sendTimer, _sendSystemTimer: TTimer;
+
+ _connected, _opened: boolean;
+ _plugin: IConnectorable;
+ _hContact, _hFilterMsg: THandle;
+ _lstId, _contactLstId: integer;
+ // îòñûëàåìîå ñîîáùåíèå
+ _msg_sending, _unformated_msg_sending: string;
+ _cntrMsgIn: integer; // ñ÷¸ò÷èê âõîäÿùèõ ñîîáùåíèé
+ _cntrMsgOut: integer; // ñ÷¸ò÷èê èñõîäÿùèõ ñîîáùåíèé
+ m_iLastCntrMsgOutInFormatting: integer;
+ _msg_buf: string; // áóôåð ñîîáùåíèé
+ // ñèñòåìíîå ñîîáùåíèå
+ _systemDataList: TStringList;
+ m_lwId: Longword;
+ m_LastSendTime: TDateTime;
+
+{$IFDEF DEBUG_LOG}
+ _logFile: Text;
+
+ procedure InitLog;
+ procedure WriteToLog(const s: string);
+ procedure CloseLog;
+{$ENDIF}
+
+ procedure FsendTimerTimer(Sender: TObject);
+ procedure FsendSystemTimerTimer(Sender: TObject);
+
+ function FGetOwnerNick: string;
+ function FGetContactNick: string;
+ function FFilterMsg(msg: string): boolean;
+ function FSendMessage(const vMessage: string): boolean;
+// function FNotifySender(const vMessage: string): boolean;
+ procedure FNotifySender;
+ procedure FSendSystemData(sd: string);
+ function FDeformatMsg(var msg: string; out lstId, msgCntr: integer): boolean;
+ // Formatting of outgoing messages
+ function FFormatMsg(const msg: string): string;
+ function FGetOwnerID: integer;
+ function FGetMultiSession: boolean;
+ procedure FSetMultiSession(bValue: boolean);
+ procedure FPluginConnectorHandler(ce: TConnectorEvent;
+ d1: pointer = nil; d2: pointer = nil);
+
+ public
+ constructor Create(hContact: THandle); reintroduce;
+ destructor Destroy; override;
+
+ procedure Close;
+ function Open(bMultiSession: boolean = TRUE): boolean;
+ function SendData(const d: string): boolean;
+ procedure SetPlugin(plugin: IConnectorable);
+
+ property Connected: boolean read _connected;
+ property Opened: boolean read _opened;
+ property OwnerID: integer read FGetOwnerID;
+ property OwnerNick: string read FGetOwnerNick;
+ property ContactID: integer read _hContact;
+ property ContactNick: string read FGetContactNick;
+ property MultiSession: boolean read FGetMultiSession write FSetMultiSession;
+ end;
+
+procedure InitConnectorGlobals(const invitationStr, promtHeadStr, dataSeparator: string; maxMsgSize: integer = 256);
+
+implementation
+
+{$J+} {$I-}
+
+uses
+ SysUtils, DateUtils, StrUtils, Types,
+ m_api,
+ ControlUnit;
+
+type
+ TConnectorList = class(TList)
+ private
+ _iterator: integer;
+ _hContact: THandle;
+
+ function FGetLastAddedConnector: TConnector;
+
+ public
+ procedure AddConnector(Connector: TConnector);
+ procedure RemoveConnector(Connector: TConnector);
+ function GetFirstConnector(hContact: THandle): TConnector;
+ function GetNextConnector: TConnector;
+ property LastAddedConnector: TConnector read FGetLastAddedConnector;
+ end;
+
+var
+ g_connectorList: TConnectorList = nil;
+ g_msgBufferSize: integer;
+ g_bMultiSession: boolean;
+
+ g_hNotifySender: THandle;
+
+ // cntrMsgIn è cntrMsgOut áûëè ââåäåíû äëÿ ïðåîäîëåíèÿ áàãà ñ çàâèñàþùèìè ñîîáùåíèÿìè
+
+const
+ MSG_INVITATION: string = '!&This is a plugin invitation message&!';
+ // MSG_RESPOND: string = '!&This is a plugin respond message&!';
+ // <ñîîáùåíèå> ::= PROMPT_HEAD [PROMPT_SEPARATOR <èä êëèåíòà>] PROMPT_SEPARATOR <íîìåð ñîîáùåíèÿ> PROMPT_TAIL <ñîîáùåíèå>
+ PROMPT_HEAD: string = 'Plgn';
+ PROMPT_SEPARATOR = ':';
+ PROMPT_TAIL = '>';
+
+ DATA_SEPARATOR: string = '&&';
+
+ CMD_CLOSE = 'ext';
+ CMD_CONTACT_LIST_ID = 'lstid';
+
+ MAX_MSG_TRYS = 3; // ìàêñèìàëüíîå êîëè÷åñòâî ïîïûòîê ïåðåñûëà ïîñëå îøèáêè
+ MAX_RESEND_TRYS = 9; // ìàêñèìàëüíîå êîëè÷åñòâî ïîïûòîê ïåðåñûëà â òàéìåðå
+ MIN_TIME_BETWEEN_MSG = 30; // âðåìÿ ìåæäó îòïðàâêîé ñîîáùåíèé ñèñòåìå IM â ìñ
+
+ OWNER_ID = 0;
+
+(*
+function TConnector.FSendMessage(const vMessage: string): boolean;
+const
+ LAST_SEND_TIME: TDateTime = 0.0;
+var
+ _now: TDateTime;
+begin
+ _now := Now;
+ if (MilliSecondsBetween(_now, LAST_SEND_TIME) < MIN_TIME_BETWEEN_MSG) then
+ Result := FALSE
+ else
+ begin
+ LAST_SEND_TIME := _now;
+ CallContactService(_hContact, PSS_MESSAGE, 0, LPARAM(PChar(vMessage)));
+ Result := TRUE;
+ end;
+end;
+*)
+
+// PP: Let's hope Miranda IM can messages to different contacts at the same time
+
+function TConnector.FSendMessage(const vMessage: string): boolean;
+// const
+// LAST_SEND_TIME: TDateTime = 0.0;
+var
+ _now: TDateTime;
+begin
+ _now := Now;
+ if (MilliSecondsBetween(_now, m_LastSendTime) < MIN_TIME_BETWEEN_MSG) then
+ Result := FALSE
+ else
+ begin
+ m_LastSendTime := _now;
+ CallContactService(_hContact, PSS_MESSAGE, 0, LPARAM(PChar(vMessage)));
+ Result := TRUE;
+ end;
+end;
+
+
+function NotifySender(wParam: WPARAM; lParam_: LPARAM): int; cdecl;
+const
+ MSG_TRYS: integer = 1;
+var
+ connector: TConnector;
+ hContact: THandle;
+begin
+ Result := 0;
+ hContact := PACKDATA(lParam_).hContact;
+
+ if (PACKDATA(lParam_).type_ <> ACKTYPE_MESSAGE) then
+ exit;
+
+ case PACKDATA(lParam_)^.result_ of
+ ACKRESULT_SUCCESS:
+ begin
+ MSG_TRYS := 1;
+
+ connector := g_connectorList.GetFirstConnector(hContact);
+ while Assigned(connector) do
+ begin
+ if (connector._msg_sending <> '') then
+ connector.FNotifySender;
+ connector := g_connectorList.GetNextConnector;
+ end;
+ end;
+
+ ACKRESULT_FAILED:
+ begin
+ inc(MSG_TRYS);
+ if (MSG_TRYS <= MAX_MSG_TRYS) then
+ begin
+ connector := g_connectorList.GetFirstConnector(hContact);
+ while (Assigned(connector)) do
+ begin
+ if connector._msg_sending <> '' then
+ with connector do
+ begin
+ _msg_buf := _unformated_msg_sending + _msg_buf;
+ _sendTimer.Enabled := TRUE;
+ end;
+ connector := g_connectorList.GetNextConnector;
+ end; // while
+ end
+ else
+ begin
+ connector := g_connectorList.GetFirstConnector(hContact);
+ while (Assigned(connector)) do
+ begin
+ if (connector._msg_sending <> '') then
+ begin
+ connector.FPluginConnectorHandler(ceError);
+ end;
+ connector := g_connectorList.GetNextConnector;
+ end;
+ end; // if (MSG_TRYS <= MAX_MSG_TRYS)
+ end; // ACKRESULT_FAILED
+ end; // case PACKDATA
+end;
+
+
+procedure TConnector.FNotifySender;
+begin
+{$IFDEF DEBUG_LOG}
+ WriteToLog('<< ' + _msg_sending);
+{$ENDIF}
+ if (Connected and (_msg_sending <> MSG_INVITATION)) then
+ begin
+ _unformated_msg_sending := '';
+ inc(_cntrMsgOut);
+ if (_cntrMsgOut > m_iLastCntrMsgOutInFormatting) then
+ _cntrMsgOut := m_iLastCntrMsgOutInFormatting + 1;
+ end;
+ _msg_sending := '';
+end;
+
+
+// äåôîðìàòèðîâàíèå âõîäÿùèõ ñîîáùåíèé. TRUE - åñëè äåêîäèðîâàíèå óäàëîñü
+function TConnector.FDeformatMsg(var msg: string; out lstId, msgCntr: integer): boolean;
+var
+ l: integer;
+begin
+ Result := FALSE;
+ if LeftStr(msg, length(PROMPT_HEAD + PROMPT_SEPARATOR)) = (PROMPT_HEAD + PROMPT_SEPARATOR) then
+ begin
+ msg := RightStr(msg, length(msg) - length(PROMPT_HEAD + PROMPT_SEPARATOR));
+
+ // contactListId
+// if (_contactLstId >= 0) then
+ if (g_bMultiSession) then
+ begin
+ l := pos(PROMPT_SEPARATOR, msg);
+ if (l > 0) then
+ begin
+ if (not TryStrToInt(LeftStr(msg, l - 1), lstId)) then
+ exit;
+ msg := RightStr(msg, length(msg) - l);
+ end
+ else
+ lstId := g_connectorList.LastAddedConnector._lstId;
+ end
+ else
+ lstId := -1; // no contactListId specified in message
+
+ // Message counter
+ l := pos(PROMPT_TAIL, msg);
+ if ((l = 0) or (not TryStrToInt(LeftStr(msg, l - 1), msgCntr))) then
+ exit;
+
+ msg := RightStr(msg, length(msg) - l);
+ // msg := AnsiReplaceStr(msg, '&', '&');
+
+ Result := TRUE;
+ end;
+end;
+
+
+function TConnector.FFilterMsg(msg: string): boolean;
+
+ procedure NProceedData(msg: string);
+
+ function NProceedSystemCommand(msg: string): boolean;
+ begin
+ Result := TRUE;
+ if (LeftStr(msg, length(CMD_CONTACT_LIST_ID)) = CMD_CONTACT_LIST_ID) then
+ begin
+ msg := RightStr(msg, length(msg) - length(CMD_CONTACT_LIST_ID) - 1);
+ TryStrToInt(msg, _contactLstId);
+ end
+ else if (msg = CMD_CLOSE) then
+ begin
+ FPluginConnectorHandler(ceDisconnected);
+ _connected := FALSE;
+ _opened := FALSE;
+ end
+ else
+ Result := FALSE;
+ end;
+
+ var
+ n, l, i: integer;
+ arrDatas: TStringDynArray;
+ strCommand: string;
+ bSystemCommand: boolean;
+ begin { \NProceedData }
+ if (RightStr(msg, length(DATA_SEPARATOR)) <> DATA_SEPARATOR) then
+ msg := msg + DATA_SEPARATOR;
+
+ n := -1;
+ l := 1;
+ repeat
+ inc(n);
+ l := PosEx(DATA_SEPARATOR, msg, l);
+ inc(l, length(DATA_SEPARATOR));
+ until (l = length(DATA_SEPARATOR));
+
+ SetLength(arrDatas, n);
+
+ bSystemCommand := TRUE;
+ i := 0;
+ while (i < n) do
+ begin
+ l := pos(DATA_SEPARATOR, msg);
+ strCommand := LeftStr(msg, l - 1);
+
+ if (bSystemCommand) then // System commands can go only in the beginning by definition
+ begin
+ bSystemCommand := NProceedSystemCommand(strCommand);
+ if (bSystemCommand) then
+ begin
+ dec(n);
+ SetLength(arrDatas, n);
+ continue;
+ end;
+ end;
+
+ arrDatas[i] := strCommand;
+ msg := RightStr(msg, length(msg) - length(DATA_SEPARATOR) - l + 1);
+
+ inc(i);
+ end; { while }
+
+ if (n > 0) then
+ begin
+ FPluginConnectorHandler(ceData, arrDatas);
+ end;
+
+ Finalize(arrDatas);
+ end;
+
+var
+ lstId, cntrMsg: integer;
+begin { TConnector.FFilterMsg }
+{$IFDEF DEBUG_LOG}
+ WriteToLog('>> ' + msg);
+{$ENDIF}
+ if (not Connected) then
+ begin
+ // if (msg = MSG_INVITATION) or (msg = MSG_RESPOND) then
+ if (msg = MSG_INVITATION) then
+ begin
+ // if msg = MSG_INVITATION then
+ // FSendMessage(MSG_RESPOND);
+ FSendSystemData(MSG_INVITATION);
+ if (g_bMultiSession) then
+ FSendSystemData(FFormatMsg(CMD_CONTACT_LIST_ID + ' ' + IntToStr(_lstId)));
+ _connected := TRUE;
+ FPluginConnectorHandler(ceConnected);
+ Result := TRUE;
+ end
+ else
+ Result := FALSE;
+ end
+ else // Connected
+ begin
+ if (FDeformatMsg(msg, lstId, cntrMsg) and ((not g_bMultisession) or (lstId = _lstId))) then
+ begin
+ Result := TRUE;
+
+ if (cntrMsg > _cntrMsgIn) then
+ begin
+ inc(_cntrMsgIn);
+ if (cntrMsg > _cntrMsgIn) then
+ begin
+ FPluginConnectorHandler(ceError); // ïàêåò èñ÷åç
+ exit;
+ end;
+ end
+ else if (cntrMsg < _cntrMsgIn) then
+ exit; // skipping packets with lower numbers
+
+ // if (cntrMsg = _cntrMsgIn) there's no garantee that packets are synchronized, but let's hope it's so.
+
+ NProceedData(msg);
+ end
+ else
+ Result := FALSE;
+ end;
+end;
+
+
+function TConnector.FFormatMsg(const msg: string): string;
+var
+ contactLstIdStr: string;
+begin
+ if (_contactLstId >= 0) then
+ contactLstIdStr := PROMPT_SEPARATOR + IntToStr(_contactLstId)
+ else // -1
+ contactLstIdStr := '';
+ Result := PROMPT_HEAD + contactLstIdStr + PROMPT_SEPARATOR + IntToStr(_cntrMsgOut) + PROMPT_TAIL + msg;
+ m_iLastCntrMsgOutInFormatting := _cntrMsgOut;
+end;
+
+
+procedure TConnector.Close;
+begin
+ if (Connected) then
+ begin
+ FSendSystemData(FFormatMsg(CMD_CLOSE));
+
+ _connected := FALSE;
+ FPluginConnectorHandler(ceDisconnected);
+ end;
+
+ _sendTimer.Enabled := FALSE;
+ _opened := FALSE;
+
+{$IFDEF DEBUG_LOG}
+ CloseLog;
+{$ENDIF}
+end;
+
+
+function TConnector.Open(bMultiSession: boolean = TRUE): boolean;
+var
+ AConnector: TConnector;
+begin
+ Result := FALSE;
+
+ if (not g_bMultiSession) then
+ g_bMultiSession := bMultisession;
+
+ if (Assigned(g_connectorList)) then
+ begin
+ AConnector := g_connectorList.GetFirstConnector(_hContact);
+ while (Assigned(AConnector)) do
+ begin
+ if (AConnector.Opened and (AConnector._contactLstId < 0)) then
+ exit;
+ AConnector := g_connectorList.GetNextConnector;
+ end;
+ end;
+
+ _cntrMsgIn := 0;
+ _cntrMsgOut := 1;
+ _msg_sending := '';
+ _unformated_msg_sending := '';
+ _msg_buf := '';
+ _contactLstId := -1;
+ _opened := TRUE;
+
+ FSendSystemData(MSG_INVITATION);
+
+ Result := TRUE;
+end;
+
+
+function TConnector.SendData(const d: string): boolean;
+begin
+ Result := FALSE;
+ if (d = '') or
+ (length(_msg_buf) + length(d) + length(DATA_SEPARATOR) > g_msgBufferSize) or
+ (LeftStr(d, length(CMD_CLOSE)) = CMD_CLOSE) or
+ (LeftStr(d, length(CMD_CONTACT_LIST_ID)) = CMD_CONTACT_LIST_ID) or
+ (pos(DATA_SEPARATOR, d) > 0) then
+ begin
+ exit;
+ end
+ else
+ begin
+ _msg_buf := _msg_buf + d + DATA_SEPARATOR;
+ _sendTimer.Enabled := TRUE; // Îòîñëàòü ñîîáùåíèå ñ íåêîòîðîé îòòÿæêîé -> âñ¸ îäíèì ïàêåòîì
+ end;
+ Result := TRUE;
+end;
+
+
+function FilterMsg(wParam: WPARAM; lParam_: LPARAM): int; cdecl;
+var
+ msg: string;
+ hContact: THandle;
+ connector: TConnector;
+ proceeded: boolean;
+begin
+ msg := string(PPROTORECVEVENT(PCCSDATA(lParam_).lParam).szMessage);
+ hContact := PCCSDATA(lParam_).hContact;
+
+ proceeded := FALSE;
+
+ if Assigned(g_connectorList) then
+ begin
+ connector := g_connectorList.GetFirstConnector(hContact);
+ while (Assigned(connector)) do
+ begin
+ if connector.Opened then
+ proceeded := (connector.FFilterMsg(msg) or proceeded);
+ connector := g_connectorList.GetNextConnector;
+ end;
+ end;
+
+ if proceeded then
+ Result := 0
+ else
+ Result := CallService(MS_PROTO_CHAINRECV, wParam, lParam_);
+end;
+
+
+constructor TConnector.Create(hContact: THandle);
+const
+ ID_COUNTER: Longword = 0;
+var
+ connector: TConnector;
+begin
+// inherited Create;
+ _sendTimer := TTimer.Create(nil);
+ with _sendTimer do
+ begin
+ Enabled := FALSE;
+ Interval := 100;
+ OnTimer := FsendTimerTimer;
+ end;
+
+ _sendSystemTimer := TTimer.Create(nil);
+ with _sendSystemTimer do
+ begin
+ Enabled := FALSE;
+ Interval := 50;
+ OnTimer := FsendSystemTimerTimer;
+ end;
+
+ _hContact := hContact;
+ _systemDataList := TStringList.Create;
+
+ if (not Assigned(g_connectorList)) then
+ g_connectorList := TConnectorList.Create;
+
+ connector := g_connectorList.GetFirstConnector(_hContact);
+ if Assigned(connector) then
+ _hFilterMsg := connector._hFilterMsg
+ else
+ begin
+ _hFilterMsg := CreateProtoServiceFunction(PChar(PLUGIN_NAME), PSR_MESSAGE, FilterMsg);
+ if CallService(MS_PROTO_ISPROTOONCONTACT, _hContact, LPARAM(PChar(PLUGIN_NAME))) = 0 then
+ CallService(MS_PROTO_ADDTOCONTACT, _hContact, LPARAM(PChar(PLUGIN_NAME)));
+ end;
+
+ if (g_connectorList.Count = 0) then
+ g_hNotifySender := HookEvent(ME_PROTO_ACK, NotifySender);
+
+ inc(ID_COUNTER);
+ m_lwId := ID_COUNTER;
+
+ g_connectorList.AddConnector(self);
+
+{$IFDEF DEBUG_LOG}
+ InitLog;
+{$ENDIF}
+end;
+
+
+destructor TConnector.Destroy;
+begin
+ if Connected then
+ while (not FSendMessage(FFormatMsg(CMD_CLOSE))) do
+ Sleep(1);
+
+ _systemDataList.Free;
+
+ g_connectorList.RemoveConnector(self);
+ if (g_connectorList.Count = 0) then
+ g_bMultiSession := FALSE;
+
+ if (not Assigned(g_connectorList.GetFirstConnector(_hContact))) then
+ begin
+ if CallService(MS_PROTO_ISPROTOONCONTACT, _hContact, LPARAM(PChar(PLUGIN_NAME))) <> 0 then
+ CallService(MS_PROTO_REMOVEFROMCONTACT, _hContact, LPARAM(PChar(PLUGIN_NAME)));
+ PluginLink.DestroyServiceFunction(_hFilterMsg);
+ end;
+
+ if (g_connectorList.Count = 0) then
+ begin
+ if (g_hNotifySender <> 0) then
+ UnhookEvent(g_hNotifySender);
+ FreeAndNil(g_connectorList);
+ end;
+
+ _sendSystemTimer.Free;
+ _sendTimer.Free;
+
+{$IFDEF DEBUG_LOG}
+ CloseLog;
+{$ENDIF}
+
+ inherited;
+end;
+
+{$IFDEF DEBUG_LOG}
+procedure TConnector.InitLog;
+begin
+ AssignFile(_logFile, MirandaPluginPath + 'Chess4Net_CONNECTORLOG.txt');
+ Append(_logFile);
+ if IOResult <> 0 then
+ begin
+ Rewrite(_logFile);
+ if IOResult <> 0 then
+ begin
+ AssignFile(_logFile, MirandaPluginPath + 'Chess4Net_CONNECTORLOG~.txt');
+ Append(_logFile);
+ if IOResult <> 0 then Rewrite(_logFile);
+ end;
+ end;
+
+ WriteToLog('[' + DateTimeToStr(Now) + ']');
+end;
+
+
+procedure TConnector.WriteToLog(const s: string);
+begin
+ writeln(_logFile, s);
+ Flush(_logFile);
+end;
+
+
+procedure TConnector.CloseLog;
+begin
+ CloseFile(_logFile);
+end;
+{$ENDIF}
+
+procedure TConnector.FsendTimerTimer(Sender: TObject);
+const
+ RESEND_COUNT : integer = 0;
+begin
+ if (_systemDataList.Count > 0) then
+ exit; // System data goes first
+
+ if (_msg_sending = '') then
+ begin
+ _sendTimer.Enabled := FALSE;
+ if (_msg_buf <> '') then
+ begin
+ _unformated_msg_sending := _msg_buf;
+ _msg_sending := FFormatMsg(_msg_buf);
+ _msg_buf := '';
+
+ _sendTimer.Enabled := (not FSendMessage(_msg_sending));
+ end;
+ end
+ else
+ begin
+{$IFDEF DEBUG_LOG}
+ WriteToLog('resend: ' + _msg_sending);
+{$ENDIF}
+ inc(RESEND_COUNT);
+ if (RESEND_COUNT = MAX_RESEND_TRYS) then
+ begin
+ RESEND_COUNT := 0;
+ FSendMessage(_msg_sending);
+ end;
+ end;
+end;
+
+
+procedure TConnector.SetPlugin(plugin: IConnectorable);
+begin
+ _plugin := plugin;
+end;
+
+
+function TConnector.FGetOwnerNick: string;
+begin
+ Result := PChar(CallService(MS_CLIST_GETCONTACTDISPLAYNAME, 0, 0));
+end;
+
+
+function TConnector.FGetContactNick: string;
+begin
+ Result := PChar(CallService(MS_CLIST_GETCONTACTDISPLAYNAME, _hContact, 0));
+end;
+
+
+procedure InitConnectorGlobals(const invitationStr, promtHeadStr, dataSeparator: string; maxMsgSize: integer = 256);
+begin
+ MSG_INVITATION := invitationStr;
+ PROMPT_HEAD := promtHeadStr;
+ DATA_SEPARATOR := dataSeparator;
+ g_msgBufferSize := maxMsgSize;
+end;
+
+{---------------------------- TConnectorList ---------------------------------}
+
+procedure TConnectorList.AddConnector(Connector: TConnector);
+var
+ i: integer;
+begin
+ for i := 0 to Count - 1 do
+ begin
+ if (not Assigned(Items[i])) then
+ begin
+ Connector._lstId := i;
+ Items[i] := Connector;
+ exit;
+ end;
+ end; // for
+ Add(Connector);
+ Connector._lstId := Count - 1;
+end;
+
+
+procedure TConnectorList.RemoveConnector(Connector: TConnector);
+begin
+ Items[Connector._lstId] := nil;
+ while ((Count > 0) and (not Assigned(Items[Count - 1]))) do
+ Delete(Count - 1);
+end;
+
+
+function TConnectorList.GetFirstConnector(hContact: THandle): TConnector;
+begin
+ _hContact := hContact;
+
+ _iterator := -1;
+ Result := GetNextConnector;
+end;
+
+
+function TConnectorList.GetNextConnector: TConnector;
+begin
+ Result := nil;
+
+ while (_iterator < (Count - 1)) do
+ begin
+ inc(_iterator);
+ if (Assigned(Items[_iterator]) and
+ (_hContact = TConnector(Items[_iterator])._hContact)) then
+ begin
+ Result := Items[_iterator];
+ exit;
+ end;
+ end;
+end;
+
+
+function TConnectorList.FGetLastAddedConnector: TConnector;
+var
+ i: integer;
+begin
+ Result := nil;
+ for i := 0 to Count - 1 do
+ begin
+ if ((not Assigned(Result)) or (TConnector(Items[i]).m_lwId > Result.m_lwId)) then
+ Result := Items[i];
+ end;
+end;
+
+
+procedure TConnector.FSendSystemData(sd: string);
+begin
+ if ((sd <> MSG_INVITATION) and (sd <> CMD_CLOSE)) then
+ sd := sd + DATA_SEPARATOR;
+ _systemDataList.Add(sd);
+ _sendSystemTimer.Enabled := TRUE;
+end;
+
+
+procedure TConnector.FsendSystemTimerTimer(Sender: TObject);
+begin
+ if _systemDataList.Count = 0 then
+ begin
+ _sendSystemTimer.Enabled := FALSE;
+ exit;
+ end;
+
+ _msg_sending := _systemDataList[0];
+ if FSendMessage(_msg_sending) then
+ _systemDataList.Delete(0);
+ // else: try to resend
+end;
+
+
+function TConnector.FGetOwnerID: integer;
+begin
+ Result := OWNER_ID;
+end;
+
+
+procedure TConnector.FSetMultiSession(bValue: boolean);
+begin
+ if ((not g_bMultiSession) and bValue) then
+ begin
+ FSendSystemData(FFormatMsg(CMD_CONTACT_LIST_ID + ' ' + IntToStr(_lstId)));
+ g_bMultiSession := TRUE;
+ end;
+end;
+
+procedure TConnector.FPluginConnectorHandler(ce: TConnectorEvent;
+ d1: pointer = nil; d2: pointer = nil);
+begin
+ if (Assigned(_plugin)) then
+ _plugin.ConnectorHandler(ce, d1, d2);
+end;
+
+
+function TConnector.FGetMultiSession: boolean;
+begin
+ Result := g_bMultiSession;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/ControlUnit.pas b/plugins/!NotAdopted/Chess4Net/MI/ControlUnit.pas new file mode 100644 index 0000000000..5a2743ca3c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/ControlUnit.pas @@ -0,0 +1,177 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ControlUnit;
+
+interface
+
+uses
+ Graphics,
+ SysUtils, //Classes,
+ m_globaldefs, m_api,
+ ConnectorUnit;
+
+type
+ IMirandaPlugin = interface(IConnectorable) // Implementatation class must be non-referenced
+ ['{CE794050-DBA2-4D2E-867E-59A873DF7304}']
+ procedure Start;
+ procedure Stop;
+ end;
+
+const
+ PLUGIN_NAME: string = 'MirandaPlugin';
+ PLUGIN_MENU_NAME: string = 'Miranda&Plugin';
+
+var
+ _PluginInfo: PPLUGININFO = @PLUGININFO;
+ guidPlugin, miidPlugin: TGUID;
+
+ MirandaPluginsPath, MirandaPluginPath: string;
+
+ MirandaPluginIcon: TIcon = nil;
+ MirandaPluginMenuPosition: integer = $7FFFFFFF;
+
+// gShowPluginOptions: TProcedure = nil;
+// gShowWrongSDKVersion: TProcedure = nil;
+ gCreatePluginInstance: function(Connector: TConnector): IMirandaPlugin = nil;
+ gInitializeControls: TProcedure = nil;
+ gDeinitializeControls: TProcedure = nil;
+// gStartOnWrongMsgProtocol: function: boolean = nil;
+ gErrorDuringPluginStart: TProcedure = nil;
+
+function MirandaPluginInfo(mirandaVersion: DWORD): PPLUGININFO; cdecl;
+function MirandaPluginInfoEx(mirandaVersion: DWORD): PPLUGININFO; cdecl;
+function MirandaPluginInterfaces: PGUID; cdecl;
+function Load(link: PPLUGINLINK): int; cdecl;
+function Unload: int; cdecl;
+
+function MakeMirandaPluginVersion(a, b, c, d: byte): int;
+
+exports
+ MirandaPluginInfo, MirandaPluginInfoEx, MirandaPluginInterfaces, Load, Unload;
+
+implementation
+
+uses
+ Dialogs, Controls, Forms,
+ PluginCommonUnit;
+
+var
+ PluginInterfaces: array[0..1] of TGUID;
+ g_hMenuCommand: THandle;
+
+function MirandaPluginInfo(mirandaVersion: DWORD): PPLUGININFO; cdecl;
+begin
+ PLUGININFO.cbSize := sizeof(TPLUGININFO);
+ PLUGININFO.isTransient := 0;
+ PLUGININFO.replacesDefaultModule := 0;
+
+ Result := @PLUGININFO;
+end;
+
+
+function MirandaPluginInfoEx(mirandaVersion: DWORD): PPLUGININFO; cdecl;
+begin
+ MirandaPluginInfo(mirandaVersion); // Initialize PLUGININFO
+
+ Move(PLUGININFO, PLUGININFOEX, sizeof(TPLUGININFO));
+ PLUGININFOEX.cbSize := sizeof(TPLUGININFOEX);
+ PLUGININFOEX.uuid := guidPlugin;
+
+ Result := @PLUGININFOEX;
+end;
+
+
+function MirandaPluginInterfaces: PGUID; cdecl;
+begin
+ PluginInterfaces[0] := miidPlugin;
+ PluginInterfaces[1] := MIID_LAST;
+
+ Result := @PluginInterfaces;
+end;
+
+
+function Start(wParam: WPARAM; lParam_: LPARAM): Integer; cdecl;
+var
+ Connector: TConnector;
+ pluginInstance: IMirandaPlugin;
+begin
+ Connector := nil;
+ Pointer(pluginInstance) := nil;
+
+ try
+ Connector := TConnector.Create(wParam);
+ pluginInstance := gCreatePluginInstance(Connector);
+ Connector.SetPlugin(pluginInstance);
+ pluginInstance.Start;
+ Pointer(pluginInstance) := nil;
+ Result := 0;
+ except
+ if (Assigned(gErrorDuringPluginStart)) then
+ gErrorDuringPluginStart;
+ if (Assigned(Connector)) then
+ Connector.SetPlugin(nil);
+ if (Assigned(pluginInstance)) then
+ begin
+ pluginInstance.Stop;
+ Pointer(pluginInstance) := nil;
+ end;
+ Result := -1;
+ end;
+end;
+
+
+function Load(link: PPLUGINLINK): int; cdecl;
+var
+ mi: TCListMenuItem;
+ prt: TPROTOCOLDESCRIPTOR;
+begin
+ if Assigned(gInitializeControls) then
+ gInitializeControls;
+
+ PLUGINLINK := Pointer(link);
+ g_hMenuCommand := pluginLink^.CreateServiceFunction(PChar(PLUGIN_NAME + '/MenuCommand'), @Start);
+ FillChar(mi, sizeof(mi), 0);
+ mi.cbSize := sizeof(mi);
+ mi.position := MirandaPluginMenuPosition;
+ mi.flags := 0; // ?
+// mi.hIcon := LoadSkinnedIcon(SKINICON_OTHER_MIRANDA); // çàãðóçêà ðîäíîé èêîíêè
+// mi.hIcon := LoadIcon(hInstance, 'MAINICON'); // çàãðóçêà èêîíêè èç ðåñóðñà
+ if Assigned(MirandaPluginIcon) then
+ mi.hIcon := MirandaPluginIcon.Handle;
+ mi.pszName := PChar(PLUGIN_MENU_NAME);
+ mi.pszService := PChar(PLUGIN_NAME + '/MenuCommand');
+ CallService(MS_CLIST_ADDCONTACTMENUITEM, 0, LPARAM(@mi));
+
+ // ðåãèñòðàöèÿ ôèëüòðà ñîîáùåíèé
+ prt.cbSize := sizeof(prt);
+ prt.szName := PChar(PLUGIN_NAME);
+ prt.type_ := PROTOTYPE_FILTER;
+ CallService(MS_PROTO_REGISTERMODULE, 0, LPARAM(@prt));
+
+ Result := 0;
+end;
+
+
+function Unload: int; cdecl;
+begin
+ if Assigned(gDeinitializeControls) then
+ gDeinitializeControls;
+ pluginLink^.DestroyServiceFunction(g_hMenuCommand);
+ g_hMenuCommand := 0;
+ Result := 0;
+end;
+
+
+function MakeMirandaPluginVersion(a, b, c, d: byte): int;
+begin
+ Result := PLUGIN_MAKE_VERSION(a,b,c,d);
+end;
+
+initialization
+ MirandaPluginsPath := ExtractFileDir(Application.ExeName) + '\Plugins\';
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/GlobalsLocalUnit.pas b/plugins/!NotAdopted/Chess4Net/MI/GlobalsLocalUnit.pas new file mode 100644 index 0000000000..30eef7a2a8 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/GlobalsLocalUnit.pas @@ -0,0 +1,36 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit GlobalsLocalUnit;
+
+// Ìîäóëü äëÿ ãëîáàëüíûõ ïåðåìåííûõ è êîíñòàíò âåðñèè äëÿ Ìèðàíäû
+
+interface
+
+uses
+ Graphics;
+
+const
+ CHESS4NET = 'Chess4Net';
+ CHESS4NET_VERSION = 201100; // 2011.0
+ CHESS4NET_TITLE = 'Chess4Net 2011.0 (http://chess4net.ru)';
+ MSG_INVITATION = 'Wellcome to Chess4Net. If you don''t have it, please download it from http://chess4net.ru';
+ PROMPT_HEAD = 'Ch4N';
+ MSG_DATA_SEPARATOR = '&&';
+
+ PLUGIN_NAME = CHESS4NET;
+ PLUGIN_VERSION = CHESS4NET_VERSION;
+ PLUGIN_PLAYING_OVER = 'Plugin for playing chess over Miranda';
+ PLUGIN_INFO_NAME = 'Chess4Net 2011.0.0';
+ PLUGIN_URL = 'http://chess4net.ru';
+ PLUGIN_EMAIL = 'packpaul@mail.ru';
+
+var
+ Chess4NetIcon, pluginIcon: TIcon;
+
+implementation
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/ManagerUnit.MI.pas b/plugins/!NotAdopted/Chess4Net/MI/ManagerUnit.MI.pas new file mode 100644 index 0000000000..c50aa58e4d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/ManagerUnit.MI.pas @@ -0,0 +1,845 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ManagerUnit.MI;
+
+interface
+
+uses
+ SysUtils,
+ //
+ ControlUnit, ManagerUnit, ConnectorUnit, ModalForm, NonRefInterfacedObjectUnit;
+
+type
+ TManagerMIFactory = class(TNonRefInterfacedObject, IMirandaPlugin)
+ private
+ m_Connector: TConnector;
+ m_Manager: IMirandaPlugin;
+ m_Dialogs: TDialogs;
+ m_bOwnExceptionHandler: boolean;
+ FErrorDuringPluginStart: TProcedure;
+ procedure FDialogsHandler(modSender: TModalForm; msgDlgID: TModalFormID);
+ function FGetDialogs: TDialogs;
+ procedure FStartGaming;
+ procedure FStartTransmitting; overload;
+ procedure FStartTransmitting(ManagerForTransmition: TManager); overload;
+ function FCanStartTransmitting: boolean;
+ procedure FHandleStartException;
+ property Dialogs: TDialogs read FGetDialogs;
+ protected
+ procedure Start;
+ procedure Stop;
+ procedure ConnectorHandler(ce: TConnectorEvent; d1: pointer = nil; d2: pointer = nil);
+ public
+ constructor Create(Connector: TConnector; AErrorDuringPluginStart: TProcedure); reintroduce;
+ destructor Destroy; override;
+ end;
+
+procedure StopAllPlugins;
+
+implementation
+
+uses
+ Types, StrUtils, Classes, Dialogs, Controls,
+ //
+ LocalizerUnit, TransmitGameSelectionUnit, GlobalsLocalUnit, ChessBoardUnit,
+ GameChessBoardUnit;
+
+type
+ TManagerMI = class(TManager, IMirandaPlugin) // abstract
+ protected
+ procedure Start;
+ procedure Stop;
+ procedure RSendData(const cmd: string); override;
+ procedure ROnDestroy; override;
+
+ procedure ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil); override;
+ procedure RSetOpponentClientVersion(lwVersion: LongWord); override;
+
+ public
+ constructor Create(Connector: TConnector); reintroduce;
+ destructor Destroy; override;
+ end;
+
+ TTransmittingManagerMI = class;
+
+ EGamingManagerMI = class(Exception);
+ TGamingManagerMI = class(TManagerMI, IMirandaPlugin)
+ private
+ m_lstTransmittingManagers: TList;
+
+ procedure FAddTransmitter(ATransmitter: TTransmittingManagerMI);
+ function FRemoveTransmitter(ATransmitter: TTransmittingManagerMI): boolean;
+ procedure FSetGameContextToTransmitter(ATransmitter: TTransmittingManagerMI);
+ function FContainsContactIDInTransmitters(iContactID: integer): boolean;
+ procedure FUpdateChessBoardCaptions;
+
+ protected
+ procedure Start;
+ procedure ROnCreate; override;
+ procedure ROnDestroy; override;
+ procedure ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil); override;
+ procedure RSetConnectionOccured; override;
+ procedure RHandleConnectorDataCommand(sl: string); override;
+ procedure RRetransmit(const strCmd: string); override;
+ function RGetGameName: string; override;
+ end;
+
+ ETransmittingManagerMI = class(Exception);
+ TTransmittingManagerMI = class(TManagerMI, IMirandaPlugin) // TODO: move to separate hierarchy
+ private
+ m_GamingManager: TGamingManagerMI;
+ m_bReady: boolean; // ready for transmition
+ property Ready: boolean read m_bReady;
+ protected
+ procedure Start;
+ procedure ROnCreate; override;
+ procedure ROnDestroy; override;
+
+ procedure ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil); override;
+ procedure RHandleConnectorDataCommand(sl: string); override;
+// procedure RWriteSettings; override; // no need because m_bConnectionOccured is always FALSE
+
+ public
+ constructor Create(Connector: TConnector; GamingManager: TGamingManagerMI); reintroduce;
+ end;
+
+var
+ g_lstGamingManagers: TList = nil;
+ g_Plugins: TInterfaceList = nil;
+
+procedure AddToPlugins(Plugin: IMirandaPlugin);
+begin
+ if (not Assigned(g_Plugins)) then
+ g_Plugins := TInterfaceList.Create;
+ g_Plugins.Add(Plugin);
+end;
+
+procedure RemoveFromPlugins(Plugin: IMirandaPlugin);
+begin
+ if (not Assigned(g_Plugins)) then
+ exit;
+ g_Plugins.Remove(Plugin);
+ if (g_Plugins.Count = 0) then
+ FreeAndNil(g_Plugins);
+end;
+
+
+procedure StopAllPlugins;
+var
+ i: integer;
+ Plugin: IMirandaPlugin;
+begin
+ if (not Assigned(g_Plugins)) then
+ exit;
+ i := g_Plugins.Count - 1;
+ while ((i >= 0) and Assigned(g_Plugins)) do
+ begin
+ Plugin := g_Plugins[i] as IMirandaPlugin;
+ Plugin.Stop;
+ Pointer(Plugin) := nil;
+ dec(i);
+ end;
+ FreeAndNil(g_Plugins);
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TGamingManagerMI
+
+procedure TGamingManagerMI.FAddTransmitter(ATransmitter: TTransmittingManagerMI);
+begin
+ if (not Assigned(m_lstTransmittingManagers)) then
+ m_lstTransmittingManagers := TList.Create;
+ m_lstTransmittingManagers.Add(ATransmitter);
+end;
+
+
+function TGamingManagerMI.FRemoveTransmitter(ATransmitter: TTransmittingManagerMI): boolean;
+var
+ i: integer;
+begin
+ Result := FALSE;
+
+ if (not Assigned(m_lstTransmittingManagers)) then
+ exit;
+
+ for i := 0 to m_lstTransmittingManagers.Count - 1 do
+ begin
+ if (m_lstTransmittingManagers[i] = ATransmitter) then
+ begin
+ m_lstTransmittingManagers.Delete(i);
+ if (m_lstTransmittingManagers.Count = 0) then
+ FreeAndNil(m_lstTransmittingManagers);
+
+ Result := TRUE;
+ exit;
+ end;
+ end; // for
+end;
+
+
+procedure TGamingManagerMI.FSetGameContextToTransmitter(ATransmitter: TTransmittingManagerMI);
+begin
+ if (not (Assigned(ATransmitter) and ATransmitter.Ready)) then
+ exit;
+
+ ATransmitter.RSendData(CMD_NICK_ID + ' ' + PlayerNickId + ' ' + OpponentNickId + ' ' + OpponentNick);
+ ATransmitter.RSendData(CMD_GAME_CONTEXT + ' ' + RGetGameContextStr);
+
+ if (ChessBoard.Mode = mGame) then
+ ATransmitter.RSendData(CMD_CONTINUE_GAME);
+end;
+
+
+function TGamingManagerMI.FContainsContactIDInTransmitters(iContactID: integer): boolean;
+var
+ i: integer;
+ ATransmitter: TTransmittingManagerMI;
+begin
+ Result := FALSE;
+ if (not Assigned(m_lstTransmittingManagers)) then
+ exit;
+ for i := 0 to m_lstTransmittingManagers.Count - 1 do
+ begin
+ ATransmitter := m_lstTransmittingManagers[i];
+ if (Assigned(ATransmitter) and (ATransmitter.Connector.ContactID = iContactID)) then
+ begin
+ Result := TRUE;
+ exit;
+ end;
+ end;
+end;
+
+
+procedure TGamingManagerMI.Start;
+begin
+ if (Assigned(ChessBoard)) then
+ begin
+ Show;
+ exit;
+ end;
+
+ if (not Connector.Opened) then
+ begin
+ if (not Connector.Open(FALSE)) then
+ raise EGamingManagerMI.Create('ERROR: Cannot open connector!');
+ end;
+
+ RCreateChessBoardAndDialogs;
+ RSetChessBoardToView;
+
+ RReadPrivateSettings;
+
+ RShowConnectingForm;
+end;
+
+
+procedure TGamingManagerMI.ROnCreate;
+begin
+ RCreateAndPopulateExtBaseList;
+
+ // Nicks initialization
+ PlayerNick := Connector.OwnerNick;
+ OpponentNick := Connector.ContactNick;
+ OpponentId := IntToStr(Connector.ContactID);
+
+ TLocalizer.Instance.AddSubscriber(self); // TODO: -> TManager.ROnCreate
+ RLocalize;
+end;
+
+
+procedure TGamingManagerMI.ROnDestroy;
+
+ procedure NRemoveFromGamings;
+ var
+ lstTmp: TList;
+ i: integer;
+ ATransmitter: TTransmittingManagerMI;
+ begin
+ if (Assigned(g_lstGamingManagers)) then
+ g_lstGamingManagers.Remove(self);
+
+ if (not Assigned(m_lstTransmittingManagers)) then
+ exit;
+
+ lstTmp := m_lstTransmittingManagers;
+ m_lstTransmittingManagers := nil;
+
+ for i := 0 to lstTmp.Count - 1 do
+ begin
+ ATransmitter := lstTmp[i];
+ if (Assigned(ATransmitter)) then
+ begin
+ lstTmp[i] := nil;
+ ATransmitter.Stop;
+ end;
+ end;
+
+ lstTmp.Free;
+ end;
+
+begin // TGamingManagerMI.ROnDestroy
+ NRemoveFromGamings;
+ FUpdateChessBoardCaptions;
+ inherited ROnDestroy;
+end;
+
+
+procedure TGamingManagerMI.ConnectorHandler(e: TConnectorEvent;
+ d1: pointer = nil; d2: pointer = nil);
+begin
+ case e of
+ ceError:
+ begin
+ Connector.Close;
+ end;
+ end; // case
+
+ inherited ConnectorHandler(e, d1, d2);
+end;
+
+
+procedure TGamingManagerMI.RSetConnectionOccured;
+var
+ iIndex: integer;
+begin
+ inherited RSetConnectionOccured;
+
+ if (not Assigned(g_lstGamingManagers)) then
+ g_lstGamingManagers := TList.Create;
+
+ iIndex := g_lstGamingManagers.IndexOf(self);
+ if (iIndex < 0) then
+ g_lstGamingManagers.Add(self);
+
+ FUpdateChessBoardCaptions;
+end;
+
+
+procedure TGamingManagerMI.FUpdateChessBoardCaptions;
+var
+ i: integer;
+ GM: TGamingManagerMI;
+begin
+ if (not Assigned(g_lstGamingManagers)) then
+ exit;
+ for i := 0 to g_lstGamingManagers.Count - 1 do
+ begin
+ GM := g_lstGamingManagers[i];
+ if (Assigned(GM)) then
+ GM.RUpdateChessBoardCaption;
+ end;
+end;
+
+
+procedure TGamingManagerMI.RRetransmit(const strCmd: string);
+var
+ i: integer;
+ ATransmitter: TTransmittingManagerMI;
+begin
+ if (Transmittable or (not Assigned(m_lstTransmittingManagers))) then
+ exit;
+
+ for i := 0 to m_lstTransmittingManagers.Count - 1 do
+ begin
+ ATransmitter := m_lstTransmittingManagers[i];
+ if (Assigned(ATransmitter) and (ATransmitter.Ready)) then
+ ATransmitter.RSendData(strCmd);
+ end;
+end;
+
+
+function TGamingManagerMI.RGetGameName: string;
+var
+ i: integer;
+ iIndex: integer;
+ iWithSameConnectorCount: integer;
+ GM: TGamingManagerMI;
+begin
+ Result := inherited RGetGameName;
+
+ if (not Assigned(g_lstGamingManagers)) then
+ exit;
+
+ iWithSameConnectorCount := 0;
+ iIndex := 0;
+
+ for i := 0 to g_lstGamingManagers.Count - 1 do
+ begin
+ GM := g_lstGamingManagers[i];
+ if (Assigned(GM) and (GM.Connector.ContactID = self.Connector.ContactID)) then
+ begin
+ inc(iWithSameConnectorCount);
+ if (GM = self) then
+ iIndex := iWithSameConnectorCount;
+ end; // if
+ end; // for
+
+ if (iWithSameConnectorCount > 1) then
+ Result := Result + ' (' + IntToStr(iIndex) + ')';
+end;
+
+
+procedure TGamingManagerMI.RHandleConnectorDataCommand(sl: string);
+var
+ strCmdSaved, sr: string;
+begin
+ strCmdSaved := sl;
+
+ RSplitStr(sl, sl, sr);
+
+ if (sl = CMD_TRANSMITTING) then
+ begin
+ Transmittable := TRUE;
+ exit;
+ end;
+
+ if (not Transmittable) then
+ begin
+ inherited RHandleConnectorDataCommand(strCmdSaved);
+ exit;
+ end;
+
+ if (sl = CMD_WELCOME) then
+ begin
+ if (Assigned(ChessBoard)) then
+ ChessBoard.InitPosition;
+ RSetConnectionOccured;
+ end
+ else if (sl = CMD_NICK_ID) then
+ begin
+ // sr ::= <PlayerNickId><OpponentNickId><OpponentNick>
+ PlayerNick := OpponentNick; // change for transmittion
+
+ RSplitStr(sr, sl, sr);
+ PlayerNickId := sl;
+
+ RSplitStr(sr, sl, sr);
+ OpponentNickId := sl;
+
+ RSplitStr(sr, sl, sr);
+ OpponentNick := sl;
+
+ ChessBoard.Caption := RGetGameName;
+ end
+ else if (sl = CMD_GAME_CONTEXT) then
+ begin
+ RSetGameContext(sr);
+ end
+ else
+ inherited RHandleConnectorDataCommand(strCmdSaved);
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TManagerMIFactory
+
+constructor TManagerMIFactory.Create(Connector: TConnector; AErrorDuringPluginStart: TProcedure);
+begin
+ inherited Create;
+ m_Connector := Connector;
+ FErrorDuringPluginStart := AErrorDuringPluginStart;
+ AddToPlugins(self);
+end;
+
+
+destructor TManagerMIFactory.Destroy;
+begin
+ RemoveFromPlugins(self);
+ m_Dialogs.Free;
+ inherited;
+end;
+
+
+procedure TManagerMIFactory.Start;
+begin
+ if (FCanStartTransmitting) then
+ begin
+ Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(28), mtCustom,
+ [mbYes, mbNo], mfTransmitting); // You are currently playing some games. Do you want to start broadcasting?
+ m_bOwnExceptionHandler := TRUE;
+ exit;
+ end;
+
+ FStartGaming;
+end;
+
+
+function TManagerMIFactory.FCanStartTransmitting: boolean;
+var
+ i: integer;
+ GM: TGamingManagerMI;
+begin
+ Result := FALSE;
+
+ if (not (Assigned(g_lstGamingManagers) and Assigned(m_Connector))) then
+ exit;
+
+ for i := 0 to g_lstGamingManagers.Count - 1 do
+ begin
+ GM := g_lstGamingManagers[i];
+ Result := (Assigned(GM) and (not GM.Transmittable) and
+ (m_Connector.ContactID <> GM.Connector.ContactID) and
+ (not GM.FContainsContactIDInTransmitters(m_Connector.ContactID)));
+ if (Result) then
+ exit;
+ end; // for
+end;
+
+
+procedure TManagerMIFactory.FStartGaming;
+begin
+ m_Manager := TGamingManagerMI.Create(m_Connector);
+ m_Connector.SetPlugin(m_Manager);
+ m_Connector := nil;
+
+ try
+ m_Manager.Start;
+ Pointer(m_Manager) := nil;
+ except
+ if (m_bOwnExceptionHandler) then
+ FHandleStartException
+ else
+ raise;
+ end;
+
+ Stop;
+end;
+
+
+procedure TManagerMIFactory.FHandleStartException;
+begin
+ if (Assigned(FErrorDuringPluginStart)) then
+ FErrorDuringPluginStart;
+end;
+
+
+procedure TManagerMIFactory.FStartTransmitting(ManagerForTransmition: TManager);
+begin
+ m_Manager := TTransmittingManagerMI.Create(m_Connector, ManagerForTransmition as TGamingManagerMI);
+ m_Connector.SetPlugin(m_Manager);
+ m_Connector := nil;
+
+ try
+ m_Manager.Start;
+ Pointer(m_Manager) := nil;
+ except
+ if (m_bOwnExceptionHandler) then
+ FHandleStartException
+ else
+ raise;
+ end;
+
+ Stop;
+end;
+
+
+procedure TManagerMIFactory.FStartTransmitting;
+var
+ strlGames: TStringList;
+ i: integer;
+ GM: TGamingManagerMI;
+ ATransmitGameSelectionForm: TTransmitGameSelectionForm;
+begin
+ if (not Assigned(g_lstGamingManagers)) then
+ begin
+ Stop; // Don't do anything
+ exit;
+ end;
+
+ strlGames := TStringList.Create;
+ try
+ for i := 0 to g_lstGamingManagers.Count - 1 do
+ begin
+ GM := g_lstGamingManagers[i];
+ if (Assigned(GM) and (not GM.Transmittable) and
+ (m_Connector.ContactID <> GM.Connector.ContactID) and
+ (not GM.FContainsContactIDInTransmitters(m_Connector.ContactID))) then
+ strlGames.AddObject(GM.RGetGameName, GM);
+ end;
+
+ if (strlGames.Count > 1) then
+ begin
+ ATransmitGameSelectionForm :=
+ Dialogs.CreateDialog(TTransmitGameSelectionForm) as TTransmitGameSelectionForm;
+ ATransmitGameSelectionForm.SetGames(strlGames);
+ ATransmitGameSelectionForm.Show;
+ end
+ else if (strlGames.Count = 1) then
+ begin
+ GM := strlGames.Objects[0] as TGamingManagerMI;
+ FStartTransmitting(GM);
+ end
+ else // = 0
+ Stop;
+
+ finally
+ strlGames.Free;
+ end;
+end;
+
+
+procedure TManagerMIFactory.Stop;
+begin
+ if (Assigned(m_Connector)) then
+ begin
+ m_Connector.SetPlugin(nil);
+ m_Connector.Free;
+ end;
+ if (Assigned(m_Manager)) then
+ begin
+ m_Manager.Stop;
+ Pointer(m_Manager) := nil;
+ end;
+ Free;
+end;
+
+
+procedure TManagerMIFactory.ConnectorHandler(ce: TConnectorEvent;
+ d1: pointer = nil; d2: pointer = nil);
+begin
+end;
+
+
+function TManagerMIFactory.FGetDialogs: TDialogs;
+begin
+ if (not Assigned(m_Dialogs)) then
+ m_Dialogs := TDialogs.Create(nil, FDialogsHandler);
+ Result := m_Dialogs;
+end;
+
+
+procedure TManagerMIFactory.FDialogsHandler(modSender: TModalForm; msgDlgID: TModalFormID);
+var
+ modRes: TModalResult;
+ GM: TGamingManagerMI;
+begin
+ modRes := modSender.ModalResult;
+ case msgDlgID of
+ mfNone:
+ ;
+ mfTransmitting:
+ begin
+ if (modRes = mrYes) then
+ FStartTransmitting
+ else // mrNo
+ FStartGaming;
+ end;
+
+ mfTransmitGame:
+ begin
+ if (modRes = mrOk) then
+ begin
+ with modSender as TTransmitGameSelectionForm do
+ begin
+ GM := GetSelected as TGamingManagerMI;
+ FStartTransmitting(GM);
+ end;
+ end
+ else
+ Stop;
+ end;
+ end; // case
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TTransmittingManagerMI
+
+constructor TTransmittingManagerMI.Create(Connector: TConnector; GamingManager: TGamingManagerMI);
+begin
+ inherited Create(Connector);
+ m_GamingManager := GamingManager;
+end;
+
+procedure TTransmittingManagerMI.Start;
+begin
+ if (not Connector.Opened) then
+ begin
+ if (not Connector.Open(FALSE)) then
+ raise ETransmittingManagerMI.Create('ERROR: Cannot open connector!');
+ end;
+ m_GamingManager.FAddTransmitter(self);
+end;
+
+
+procedure TTransmittingManagerMI.ROnDestroy;
+
+ procedure NRemoveFromTransmittings;
+ var
+ i: integer;
+ GM: TGamingManagerMI;
+ begin
+ if (not Assigned(g_lstGamingManagers)) then
+ exit;
+
+ for i := 0 to g_lstGamingManagers.Count - 1 do
+ begin
+ GM := g_lstGamingManagers[i];
+ if (Assigned(GM) and GM.FRemoveTransmitter(self)) then
+ break;
+ end;
+ end;
+
+begin // TTransmittingManagerMI.ROnDestroy
+ NRemoveFromTransmittings;
+ inherited ROnDestroy;
+end;
+
+
+procedure TTransmittingManagerMI.ROnCreate;
+begin
+// PlayerNick := m_GamingManager.PlayerNick;
+// OpponentNick := m_GamingManager.OpponentNick;
+// OpponentId := m_GamingManager.OpponentId;
+end;
+
+
+procedure TTransmittingManagerMI.ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil);
+begin
+ case e of
+ ceConnected:
+ begin
+ RSendData(CMD_VERSION + ' ' + IntToStr(CHESS4NET_VERSION));
+ RSendData(CMD_TRANSMITTING);
+ end;
+
+ ceError, ceDisconnected:
+ begin
+ Connector.Close;
+ Stop;
+ end;
+
+ else
+ inherited ConnectorHandler(e, d1, d2);
+ end; // case
+end;
+
+
+procedure TTransmittingManagerMI.RHandleConnectorDataCommand(sl: string);
+var
+ sr: string;
+ lwOpponentClientVersion: Longword;
+begin
+ RSplitStr(sl, sl, sr);
+ if (sl = CMD_VERSION) then
+ begin
+ RSplitStr(sr, sl, sr);
+ lwOpponentClientVersion := StrToIntDef(sl, CHESS4NET_VERSION);
+
+ if (lwOpponentClientVersion < 201000) then
+ begin
+ RSendData(CMD_GOODBYE);
+ RReleaseWithConnectorGracefully;
+ end;
+
+ RSetOpponentClientVersion(lwOpponentClientVersion);
+ end
+ else if (sl = CMD_TRANSMITTING) then
+ begin
+ RSendData(CMD_GOODBYE); // TODO: some message or output to log
+ RReleaseWithConnectorGracefully;
+ end
+ else if (sl = CMD_GOODBYE) then
+ begin
+ Stop;
+ end
+ else if (sl = CMD_WELCOME) then
+ begin
+ RSendData(CMD_WELCOME);
+ m_bReady := TRUE;
+ m_GamingManager.FSetGameContextToTransmitter(self);
+ end;
+end;
+
+
+////////////////////////////////////////////////////////////////////////////////
+// TManagerMI
+
+constructor TManagerMI.Create(Connector: TConnector);
+begin
+ self.Connector := Connector;
+ RCreate;
+ AddToPlugins(self);
+end;
+
+
+destructor TManagerMI.Destroy;
+begin
+ RemoveFromPlugins(self);
+ inherited;
+end;
+
+
+procedure TManagerMI.Start;
+begin
+ Assert(FALSE);
+end;
+
+
+procedure TManagerMI.Stop;
+begin
+ Release;
+end;
+
+
+procedure TManagerMI.RSendData(const cmd: string);
+begin
+ Connector.SendData(cmd);
+end;
+
+
+procedure TManagerMI.ROnDestroy;
+begin
+ if (Assigned(Connector)) then
+ begin
+ Connector.Free;
+ Connector := nil;
+ end;
+
+ inherited ROnDestroy;
+end;
+
+
+procedure TManagerMI.ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil);
+var
+ iData: integer;
+ strCmd: string;
+ strLeft: string;
+begin
+ case e of
+ ceData:
+ begin
+ Assert(High(TStringDynArray(d1)) >= 0);
+ iData := 0;
+ repeat
+ strLeft := TStringDynArray(d1)[iData];
+ inc(iData);
+ strCmd := IfThen((iData <= High(TStringDynArray(d1))), '*');
+
+ RHandleConnectorDataCommand(strLeft);
+ until (strCmd = '');
+ end; // ceData
+
+ else
+ inherited ConnectorHandler(e, d1, d2);
+ end; // case
+end;
+
+
+procedure TManagerMI.RSetOpponentClientVersion(lwVersion: LongWord);
+begin
+ inherited RSetOpponentClientVersion(lwVersion);
+
+ if (lwVersion >= 200901) then
+ Connector.MultiSession := TRUE;
+end;
+
+
+initialization
+
+finalization
+ FreeAndNil(g_lstGamingManagers);
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_addcontact.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_addcontact.inc new file mode 100644 index 0000000000..6bf08e8208 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_addcontact.inc @@ -0,0 +1,54 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_ADDCONTACT}
+{$DEFINE M_ADDCONTACT}
+
+const
+
+ HANDLE_SEARCHRESULT = 0;
+ HANDLE_EVENT = 1;
+ HANDLE_CONTACT = 2;
+
+type
+
+ PADDCONTACTSTRUCT = ^TADDCONTACTSTRUCT;
+ TADDCONTACTSTRUCT = record
+ handleType: Integer;
+ handle: THandle; // HDBEVENT, HCONTACT, SearchResult
+ szProto: PChar; // used by search result only
+ psr: Pointer; // @PROTOSEARCHRESULT
+ end;
+
+const
+
+ {
+ wParam : (HWND) Parent window of the dialog that will be presented
+ lParam : Pointer to an initialised TADDCONTACTSTRUCT
+ Affect : Open's the add contact dialog
+ Version: 0.1.2.2+
+ }
+ MS_ADDCONTACT_SHOW = 'AddContact/Show';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_api.pas b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_api.pas new file mode 100644 index 0000000000..412d33e517 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_api.pas @@ -0,0 +1,75 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFDEF FPC}
+ {$PACKRECORDS C}
+ {$MODE Delphi}
+{$ENDIF}
+
+unit m_api;
+
+interface
+
+uses
+
+ m_globaldefs, windows;
+
+ {$include m_plugins.inc}
+ {$include m_system.inc}
+ {$include m_database.inc}
+ {$include m_findadd.inc}
+ {$include m_awaymsg.inc}
+ {$include m_email.inc}
+ {$include m_history.inc}
+ {$include m_message.inc}
+ {$include m_url.inc}
+ {$include newpluginapi.inc}
+ {$include m_clui.inc}
+ {$include m_ignore.inc}
+ {$include m_skin.inc}
+ {$include m_file.inc}
+ {$include m_netlib.inc}
+ {$include m_langpack.inc}
+ {$include m_clist.inc}
+ {$include m_clc.inc}
+ {$include m_userinfo.inc}
+ {$include m_protosvc.inc}
+ {$include m_options.inc}
+ {$include m_icq.inc}
+ {$include m_protocols.inc}
+ {$include m_protomod.inc}
+ {$include m_utils.inc}
+ {$include m_addcontact.inc}
+ {$include statusmodes.inc}
+ {$include m_contacts.inc}
+ {$define M_API_UNIT}
+ {$include m_helpers.inc}
+
+implementation
+
+ {$undef M_API_UNIT}
+ {$include m_helpers.inc}
+
+end.
+
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_awaymsg.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_awaymsg.inc new file mode 100644 index 0000000000..44be914423 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_awaymsg.inc @@ -0,0 +1,40 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_AWAYMSG}
+{$DEFINE M_AWAYMSG}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Show the away/na/etc message for a contact
+ Returns: 0 on success, non zero on failure, see notes
+ notes : returns without waiting for the message to be shown.
+ version: v0.1.0.1+
+ }
+ MS_AWAYMSG_SHOWAWAYMSG = 'SRAway/GetMessage';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clc.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clc.inc new file mode 100644 index 0000000000..743d8370aa --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clc.inc @@ -0,0 +1,284 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_CLC}
+{$DEFINE M_CLC}
+
+const
+
+ CLISTCONTROL_CLASS = 'CListControl';
+
+ // styles
+
+ CLS_MANUALUPDATE = $0001; // todo
+ CLS_SHOWHIDDEN = $0002;
+ CLS_HIDEOFFLINE = $0004; // hides all offline users
+ CLS_CHECKBOXES = $0008;
+ CLS_MULTICOLUMN = $0010; // not true multi-column, just for ignore/vis options
+ CLS_HIDEEMPTYGROUPS = $0020; // note: this flag will be spontaneously removed if the 'new subgroup' menu item is clicked, for obvious reasons
+ CLS_USEGROUPS = $0040;
+ CLS_NOHIDEOFFLINE = $0080; // overrides CLS_HIDEOFFLINE and the per-group hideoffline setting
+ CLS_GREYALTERNATE = $0100; // make every other line slightly grey
+ CLS_GROUPCHECKBOXES = $0200; // put checkboxes on groups too (managed by CLC)
+
+ CLS_EX_DISABLEDRAGDROP = $00000001;
+ CLS_EX_EDITLABELS = $00000002;
+ CLS_EX_SHOWSELALWAYS = $00000004;
+ CLS_EX_TRACKSELECT = $00000008;
+ CLS_EX_SHOWGROUPCOUNTS = $00000010;
+ CLS_EX_DIVIDERONOFF = $00000020;
+ CLS_EX_HIDECOUNTSWHENEMPTY = $00000040;
+ CLS_EX_NOTRANSLUCENTSEL = $00000080;
+ CLS_EX_LINEWITHGROUPS = $00000100;
+ CLS_EX_QUICKSEARCHVISONLY = $00000200;
+ CLS_EX_SORTGROUPSALPHA = $00000400;
+ CLS_EX_NOSMOOTHSCROLLING = $00000800;
+
+ CLM_FIRST = $1000; // this is the same as LVM_FIRST
+ CLM_LAST = $1100;
+
+// messages, compare with equivalent TVM_* in the WINAPI
+
+ CLM_ADDCONTACT = (CLM_FIRST+0); // wParam=hContact
+ CLM_ADDGROUP = (CLM_FIRST+1); // wParam=hGroup
+ CLM_AUTOREBUILD = (CLM_FIRST+2);
+ CLM_DELETEITEM = (CLM_FIRST+3); // wParam=hItem
+ CLM_EDITLABEL = (CLM_FIRST+4); // wParam=hItem
+ CLM_ENDEDITLABELNOW = (CLM_FIRST+5); // wParam=cancel, 0 to save
+ CLM_ENSUREVISIBLE = (CLM_FIRST+6); // wParam=hItem, lParam=partialOk
+
+ CLE_TOGGLE = -1;
+ CLE_COLLAPSE = 0;
+ CLE_EXPAND = 1;
+ CLE_INVALID = $FFFF;
+
+ CLM_EXPAND = (CLM_FIRST+7); // wParam=hItem, lParam=CLE_
+ CLM_FINDCONTACT = (CLM_FIRST+8); // wParam=hContact, returns an hItem
+ CLM_FINDGROUP = (CLM_FIRST+9); // wParam=hGroup, returns an hItem
+ CLM_GETBKCOLOR = (CLM_FIRST+10); // returns a COLORREF
+ CLM_GETCHECKMARK = (CLM_FIRST+11); // wParam=hItem, returns 1 or 0
+ CLM_GETCOUNT = (CLM_FIRST+12); // returns the total number of items
+
+ CLM_GETEDITCONTROL = (CLM_FIRST+13); // returns the HWND, or NULL
+ CLM_GETEXPAND = (CLM_FIRST+14); // wParam=hItem, returns a CLE_, CLE_INVALID if not a group
+ CLM_GETEXTRACOLUMNS = (CLM_FIRST+15); // returns number of extra columns
+ CLM_GETEXTRAIMAGE = (CLM_FIRST+16); // wParam=hItem, lParam=MAKELPARAM(iColumn (0 based),0), returns iImage or $FF
+ CLM_GETEXTRAIMAGELIST = (CLM_FIRST+17); // returns HIMAGELIST
+ CLM_GETFONT = (CLM_FIRST+18); // wParam=fontId, see clm_setfont. returns hFont.
+ CLM_GETINDENT = (CLM_FIRST+19); // wParam=new group indent
+ CLM_GETISEARCHSTRING = (CLM_FIRST+20); // lParam=(char*)pszStr, max 120 bytes, returns number of chars in string
+ CLM_GETITEMTEXT = (CLM_FIRST+21); // wParam=hItem, lParam=(char*)pszStr, max 120 bytes
+ CLM_GETSCROLLTIME = (CLM_FIRST+22); // returns time in ms
+ CLM_GETSELECTION = (CLM_FIRST+23); // returns hItem
+
+ CLCHT_ABOVE = $0001; // above client area
+ CLCHT_BELOW = $0002; // below client area
+ CLCHT_TOLEFT = $0004; // left of client area
+ CLCHT_TORIGHT = $0008; // right of client area
+ CLCHT_NOWHERE = $0010; // in client area, not on an item
+ CLCHT_ONITEMICON = $0020;
+ CLCHT_ONITEMCHECK = $0040;
+ CLCHT_ONITEMLABEL = $0080;
+ CLCHT_ONITEMINDENT = $0100; // to the left of an item icon
+ CLCHT_ONITEMEXTRA = $0200; // on an extra icon, HIBYTE(HIWORD()) says which
+ CLCHT_ONITEM = $03E0;
+ CLCHT_INLEFTMARGIN = $0400;
+ CLCHT_BELOWITEMS = $0800; // in client area but below last item
+
+ CLM_HITTEST = (CLM_FIRST+25); // lParam=MAKELPARAM(x,y) (relative to control), wParam=(PDWORD)&hitTest (see encoding of HitTest() in clc.h, can be NULL) returns hItem or NULL
+ CLM_SELECTITEM = (CLM_FIRST+26); // wParam=hItem
+
+ CLB_TOPLEFT = 0;
+ CLB_STRETCHV = 1;
+ CLB_STRETCHH = 2; // and tile vertically
+ CLB_STRETCH = 3;
+
+ CLBM_TYPE = $00FF;
+ CLBF_TILEH = $1000;
+ CLBF_TILEV = $2000;
+ CLBF_PROPORTIONAL = $4000;
+ CLBF_SCROLL = $8000;
+
+ CLM_SETBKBITMAP = (CLM_FIRST+27); // wParam=mode, lParam=hBitmap (don't delete it), NULL for none
+ CLM_SETBKCOLOR = (CLM_FIRST+28); // wParam=a COLORREF, default is GetSysColor(COLOR_3DFACE)
+ CLM_SETCHECKMARK = (CLM_FIRST+29); // wParam=hItem, lParam=1 or 0
+ CLM_SETEXTRACOLUMNS = (CLM_FIRST+30); // wParam=number of extra columns (zero to MAXEXTRACOLUMNS from clc.h, currently 16)
+ CLM_SETEXTRAIMAGE = (CLM_FIRST+31); // wParam=hItem, lParam=MAKELPARAM(iColumn (0 based),iImage). iImage=$FF is a blank
+ CLM_SETEXTRAIMAGELIST = (CLM_FIRST+32); // lParam=HIMAGELIST
+
+ FONTID_CONTACTS = 0;
+ FONTID_INVIS = 1;
+ FONTID_OFFLINE = 2;
+ FONTID_NOTONLIST = 3;
+ FONTID_GROUPS = 4;
+ FONTID_GROUPCOUNTS = 5;
+ FONTID_DIVIDERS = 6;
+ FONTID_OFFINVIS = 7;
+ FONTID_MAX = 7;
+
+ CLM_SETFONT = (CLM_FIRST+33); // wParam=hFont, lParam=MAKELPARAM(fRedraw,fontId)
+ CLM_SETINDENT = (CLM_FIRST+34); // wParam=new indent, default is 3 pixels
+ CLM_SETITEMTEXT = (CLM_FIRST+35); // wParam=hItem, lParam=(char*)pszNewText
+ CLM_SETSCROLLTIME = (CLM_FIRST+36); // wParam=time in ms, default 200
+ CLM_SETHIDEEMPTYGROUPS = (CLM_FIRST+38); // wParam=TRUE/FALSE
+
+ GREYF_UNFOCUS = $80000000;
+ MODEF_OFFLINE = $40000000;
+
+ // and use the PF2_ #defines from m_protosvc.inc
+ CLM_SETGREYOUTFLAGS = (CLM_FIRST+39); // wParam=new flags
+ CLM_GETHIDEOFFLINEROOT = (CLM_FIRST+40); // returns TRUE/FALSE
+ CLM_SETHIDEOFFLINEROOT = (CLM_FIRST+41); // wParam=TRUE/FALSE
+ CLM_SETUSEGROUPS = (CLM_FIRST+42); // wParam=TRUE/FALSE
+ CLM_SETOFFLINEMODES = (CLM_FIRST+43); // for 'hide offline', wParam=PF2_ flags and MODEF_OFFLINE
+ CLM_GETEXSTYLE = (CLM_FIRST+44); // returns CLS_EX_ flags
+ CLM_SETEXSTYLE = (CLM_FIRST+45); // wParam=CLS_EX_ flags
+ CLM_GETLEFTMARGIN = (CLM_FIRST+46); // returns count of pixels
+ CLM_SETLEFTMARGIN = (CLM_FIRST+47); // wParam=pixels
+ // the order of info items is never changed, so make sure you add them in the
+ // order you want them to remain
+ CLM_ADDINFOITEM = (CLM_FIRST+48); // lParam=&TCLCINFOITEM, returns hItem
+ CLM_GETITEMTYPE = (CLM_FIRST+49); // wParam=hItem, returns a CLCIT_
+ CLM_GETNEXTITEM = (CLM_FIRST+50); // wParam=flag, lParam=hItem, returns an hItem
+ CLM_GETTEXTCOLOR = (CLM_FIRST+51); // wParam=FONTID_, returns COLORREF
+ CLM_SETTEXTCOLOR = (CLM_FIRST+52); // wParam=FONTID_, lParam=COLORREF
+
+ CLCIIF_BELOWGROUPS = 1; // put it between groups and contacts, default is at top
+ CLCIIF_BELOWCONTACTS = 2; // put it at the bottom
+ CLCIIF_CHECKBOX = $40; // give this item a check box
+ CLCIIF_GROUPFONT = $80; // draw the item using FONTID_GROUPS
+
+ CLCIT_INVALID = -1;
+ CLCIT_GROUP = 0;
+ CLCIT_CONTACT = 1;
+ CLCIT_DIVIDER = 2;
+ CLCIT_INFO = 3;
+
+ CLGN_ROOT = 0;
+ CLGN_CHILD = 1;
+ CLGN_PARENT = 2;
+ CLGN_NEXT = 3;
+ CLGN_PREVIOUS = 4;
+ CLGN_NEXTCONTACT = 5;
+ CLGN_PREVIOUSCONTACT = 6;
+ CLGN_NEXTGROUP = 7;
+ CLGN_PREVIOUSGROUP = 8;
+
+ CLNF_ISGROUP = 1;
+ CLNF_ISINFO = 2;
+
+ CLN_FIRST = (0-100);
+ CLN_EXPANDED = (CLN_FIRST-0); // hItem=hGroup, action=CLE_*
+ CLN_LISTREBUILT = (CLN_FIRST-1);
+ CLN_ITEMCHECKED = (CLN_FIRST-2); // todo // hItem,action,flags valid
+ CLN_DRAGGING = (CLN_FIRST-3); // hItem,pt,flags valid. only sent when cursor outside window, return nonzero if processed
+ CLN_DROPPED = (CLN_FIRST-4); // hItem,pt,flags valid. only sent when cursor outside window, return nonzero if processed
+ CLN_LISTSIZECHANGE = (CLN_FIRST-5); // pt.y valid. the vertical height of the visible items in the list has changed.
+ CLN_OPTIONSCHANGED = (CLN_FIRST-6); // nothing valid. If you set some extended options they have been overwritten and should be re-set
+ CLN_DRAGSTOP = (CLN_FIRST-7); // hItem,flags valid. sent when cursor goes back in to the window having been outside, return nonzero if processed
+ CLN_NEWCONTACT = (CLN_FIRST-8); // hItem,flags valid. sent when a new contact is added without a full list rebuild
+ CLN_CONTACTMOVED = (CLN_FIRST-9); // hItem,flags valid. sent when contact is moved without a full list rebuild
+ CLN_CHECKCHANGED = (CLN_FIRST-10); // hItem,flags valid. sent when any check mark is changed, but only for one change if there are many
+
+type
+
+ PCLCINFOITEM = ^TCLCINFOITEM;
+ TCLCINFOITEM = record
+ cbSize: int;
+ pszText: PChar;
+ hParentGroup: THandle;
+ flags: DWORD;
+ hIcon: THandle; // todo
+ end;
+
+ PNMCLISTCONTROL = ^TNMCLISTCONTROL;
+ TNMCLISTCONTROL = record
+ hdr: TNMHDR; // depends on Windows.pas
+ hItem: THandle;
+ action: int;
+ iColumn: int; // -1 if not on an extra column
+ flags: DWORD;
+ pt: TPoint; // depends on Windows.pas
+ end;
+
+ PCLCINFOTIP = ^TCLCINFOTIP;
+ TCLCINFOTIP = record
+ cbSize: int;
+ isTreeFocused: int; // so the plugin can provide an option
+ isGroup: int; // 0 if it's contact, 1 if it's a group
+ hItem: THandle; // handle to group or contact
+ ptCursor: TPoint;
+ rcItem: TRect;
+ end;
+
+const
+
+ {
+ wParam : 0
+ lParam : Pointer to a TCLCINFOTIP structure
+ Affect : An InfoTip for an item should be shown now, see notes
+ Returns: [non zero] if you process this, because it makes no sense
+ for more than one module to process this.
+ Notes : It's upto the module where to put the InfoTip, Normally
+ it's a few pixels below and to the right of the cursor.
+ -
+ This event is called after the mouse ehas been stationary over
+ a contact for (by default) 200ms
+ }
+ ME_CLC_SHOWINFOTIP = 'CLC/ShowInfoTip';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initialised TCLCINFOTIP
+ Affect : It's time to destroy an infotip, see notes
+ Notes : Only cbSize, isGroup, hItem are set
+ notes : This is sent when the mouse moves off a contact when ME_CLC_SHOWINFOTIP
+ has previously been called.
+ -
+ If you don't want this behaviour, you should have grabbed the mouse
+ capture yourself --
+ }
+ ME_CLC_HIDEINFOTIP = 'CLC/HideInfoTip';
+
+ {
+ wParam : new_time
+ lParam : 0
+ Affect : Set a new hover time before the info tip hooks are called, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : The value of this setting is applid to all current CLC windows
+ and saved to b applied to all future windows, it is persistent.
+ -
+ Time is in milliseconds, default is 750ms
+ }
+ MS_CLC_SETINFOTIPHOVERTIME = 'CLC/SetInfoTipHoverTime';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : get the hover time before the infotip hooks are called
+ returns: the hover time in MS
+ }
+ MS_CLC_GETINFOTIPHOVERTIME = 'CLC/GetInfoTipHoverTime';
+
+{$ENDIF}
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clist.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clist.inc new file mode 100644 index 0000000000..20a3fb0e29 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clist.inc @@ -0,0 +1,641 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_CLIST}
+{$DEFINE M_CLIST}
+
+{$ifndef STATUSMODES}
+ {$include statusmodes.inc}
+{$endif}
+
+const
+
+ // for MS_CLIST_GETSTATUSMODEDESCRIPTION
+
+ GSMDF_PREFIXONLINE = 1; // prefix "Online :" for online submodes, e.g. 'away'
+
+ // for MS_CLIST_ADDMAINMENUITEM
+
+ CMIF_GRAYED = 1;
+ CMIF_CHECKED = 2;
+ CMIF_HIDDEN = 4; // only works on contact menus
+ CMIF_NOTOFFLINE = 8; // item won't appear for contacts that are offline
+ CMIF_NOTONLINE = 16; // " online
+ CMIF_NOTONLIST = 32; // item won't appear on standard contacts
+ CMIF_NOTOFFLIST = 64; // item won't appear on contacts that have the 'NotOnList' setting
+
+ // for MS_CLIST_MODIFYMENUITEM
+
+ CMIM_NAME = $80000000;
+ CMIM_FLAGS = $40000000;
+ CMIM_ICON = $20000000;
+ CMIM_HOTKEY = $10000000;
+ CMIM_ALL = $F0000000;
+
+ // for MS_CLIST_GETCONTACTDISPLAYNAME
+
+ // will never return the user's custom name, even if that's the one to be displayed
+ GCDNF_NOMYHANDLE = 1;
+
+ // for MS_CLIST_ADDEVENT
+
+ //flashes the icon even if the user is occupied, and puts the event
+ // at the top of the queue
+ CLEF_URGENT = 1;
+ { icon will not flash forever, only a few times, e.g. online alert }
+ CLEF_ONLYAFEW = 2;
+
+ // for MS_CLIST_GETICONSIMAGELIST
+
+ IMAGE_GROUPOPEN = 11;
+ IMAGE_GROUPSHUT = 12;
+
+ // for MS_CLIST_MENUPROCESSCOMMAND
+
+ MPCF_CONTACTMENU = 1; // test commands from a contact menu
+ MPCF_MAINMENU = 2; // test commands from the main menu
+
+ // for MS_CLIST_GROUPGETNAME/2
+
+ GROUPF_EXPANDED = $04;
+ GROUPF_HIDEOFFLINE = $08;
+
+ //
+
+ SETTING_TOOLWINDOW_DEFAULT = 1;
+ SETTING_SHOWMAINMENU_DEFAULT = 1;
+ SETTING_SHOWCAPTION_DEFAULT = 1;
+ SETTING_CLIENTDRAG_DEFAULT = 0;
+ SETTING_ONTOP_DEFAULT = 1;
+ SETTING_MIN2TRAY_DEFAULT = 1;
+ SETTING_TRAY1CLICK_DEFAULT = 0;
+ SETTING_HIDEOFFLINE_DEFAULT = 0;
+ SETTING_HIDEEMPTYGROUPS_DEFAULT = 0;
+ SETTING_USEGROUPS_DEFAULT = 1;
+ SETTING_SORTBYSTATUS_DEFAULT = 0;
+ SETTING_TRANSPARENT_DEFAULT = 0;
+ SETTING_ALPHA_DEFAULT = 200;
+ SETTING_AUTOALPHA_DEFAULT = 150;
+ SETTING_CONFIRMDELETE_DEFAULT = 1;
+ SETTING_AUTOHIDE_DEFAULT = 0;
+ SETTING_HIDETIME_DEFAULT = 30;
+ SETTING_CYCLETIME_DEFAULT = 4;
+ SETTING_ALWAYSSTATUS_DEFAULT = 0;
+ SETTING_ALWAYSMULTI_DEFAULT = 0;
+ SETTING_TRAYICON_SINGLE = 0;
+ SETTING_TRAYICON_CYCLE = 1;
+ SETTING_TRAYICON_MULTI = 2;
+ SETTING_TRAYICON_DEFAULT = SETTING_TRAYICON_SINGLE;
+ SETTING_STATE_HIDDEN = 0;
+ SETTING_STATE_MINIMIZED = 1;
+ SETTING_STATE_NORMAL = 2;
+
+type
+
+ PCLISTMENUITEM = ^TCLISTMENUITEM;
+ TCLISTMENUITEM = record
+ cbSize: int; // size in bytes of this structure
+ pszName: PChar; // text of the menu item
+ flags: DWORD;
+ position: int; // approx position on the menu, lower numbers go nearer the top
+ hIcon: THandle; // icon to put by the item, if this was *not* loaded from
+ // a resource, you can delete it straight after the call
+ pszService: PChar; // name of the service to call when the service is clicked
+ pszPopupName: PChar;// name of the popup menu that this item is on, if this
+ // is NULL the iteem is on the root of the menu
+ popupPosition: int; // position of the popup menu on the root menu, ignored
+ // if pszPopupName is NULL(0) or if the popup menu already exists
+ hotKey: DWORD; // keyboard accelerator, same as lParam of WM_HOTKEY, 0 for none
+ pszContactOwner: PChar; // contact menus only, the protocol module that owns
+ // the contacts to which this to which this menu item
+ // applies, NULL(0) if it applies to all contacts.
+ // if it applies to multiple but not all protocols
+ // add multiple menu items or use ME_CLIST_PREBUILDCONTACTMENU
+ end;
+
+ PCLISTDOUBLECLICKACTION = ^TCLISTDOUBLECLICKACTION;
+ TCLISTDOUBLECLICKACTION = record
+ cbSize: int;
+ pszContactOwner: PChar; // name of the protocol owning the contact or NULL(0) for all
+ flags: DWORD; // CMIF_NOT flags above
+ pszService: PChar; // service to call on double click, is called with wParam=hContact, lParam=0
+ end;
+
+ PCLISTEVENT = ^TCLISTEVENT;
+ TCLISTEVENT = record
+ cbSize: int; // size in bytes
+ hContact: THandle; // handle to the contact to put the icon by
+ hIcon: THandle; // icon to flash!
+ flags: DWORD;
+ hDBEvent: THandle; // caller defined, but should be unique for hContact
+ lParam: LPARAM;
+ pszService: PChar; // name of service to call on activation
+ pszTooltip: PChar; // short description of the event to display as a tooltip on the systray
+ end;
+
+const
+
+ {
+ wParam : new_status
+ lParam : 0
+ Affect : Sent when the user acks to change their status, see notes
+ Notes : Also sent due to a MS_CLIST_SETSTATUSMODE
+ }
+ ME_CLIST_STATUSMODECHANGE = 'CList/StatusModeChange';
+
+ {
+ wParam : new_status
+ lParam : 0
+ Affect : Force a change of status mode, see statusmodes.inc
+ }
+ MS_CLIST_SETSTATUSMODE = 'CList/SetStatusMode';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Get the current status mode, see notes
+ Notes : This is the status, as set by the user, not any protocol specific status
+ all protocol modules will attempt to conform to this setting at ALL times.
+ }
+ MS_CLIST_GETSTATUSMODE = 'CList/GetStatusMode';
+
+ {
+ wParam : status_mode
+ lParam : flags
+ Affect : Get a textual description of the given status mode
+ Returns: pointer to a static buffer of the description of the given status mode
+ or NULL(0) if the mode was unknown.
+ Version: v0.1.0.1+
+ }
+ MS_CLIST_GETSTATUSMODEDESCRIPTION = 'CList/GetStatusModeDescription';
+
+ {
+ wParam : 0
+ lParam : Pointer to a initalised TCLISTMENUITEM structure
+ Affect : Add a new menu item to the main menu, see notes
+ Returns: A handle to the new MENU item or NULL(0) on failure
+ Notes : The given TCLISTMENUITEM.pszService in is called when the item
+ get clicked with :
+ -
+ wParam = 0, lParam = hwndContactList
+ }
+ MS_CLIST_ADDMAINMENUITEM = 'CList/AddMainMenuItem';
+
+ {
+ wParam : 0
+ lParam : Pointer to a initalised TCLISTMENUITEM structure
+ Affect : Add a new item to the user contact menus, see notes
+ Notes : exactly the same as MS_CLIST_ADDMAINMENUITEM except when an item
+ is selected, the service gets called with wParam=hContact,
+ pszContactOwner is obeyed.
+ -
+ Popup menus are not supported, pszPopupName and popupPosition
+ are ignored. If CTRL is held down when right clicking the menu
+ position numbers will be displayed in brackets afterr the menu item
+ text, this only works in debug builds!
+ }
+ MS_CLIST_ADDCONTACTMENUITEM = 'CList/AddContactMenuItem';
+
+ {
+ wParam : HMENUITEM
+ lParam : Pointer to a initalised TCLISTMENUITEM
+ Affect : Modify an existing menu item, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : hMenuItem will have been returned by MS_CLIST_ADD[MAIN]MENUITEM
+ TCLISTMENUITEM.flags should contain CMIM_* constants (see above)
+ to mark which fields should be updated, if it's not present, they
+ can't be updated -- if flags do not exist for a field it can not
+ be updated.
+ Version: v0.1.0.1+
+ }
+ MS_CLIST_MODIFYMENUITEM = 'CList/ModifyMenuItem';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : the context menu for a contact is about to be built, see notes
+ Notes : modules should use this to change menu items that are specific
+ to the contact that has them
+ Version: v0.1.0.1+
+ }
+ ME_CLIST_PREBUILDCONTACTMENU = 'CList/PreBuildContactMenu';
+
+ {
+ wParam : 0
+ lParam : Pointer to a initalised TCLISTDOUBLECLICKACTION structure
+ Affect : Sets the service to call when a contact is double-clicked, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : in case of conflicts, the first module to have registered
+ will get the double click, no others will, this service
+ will return success even for duplicates
+ -
+ This service was dropped from development during 0.3.0.0, it is no
+ longer supported, see ME_CLIST_DOUBLECLICKED
+ Version: 0.1.2.2+, 0.2.0+ ONLY (not 3.0a)
+ }
+ MS_CLIST_SETDOUBLECLICKACTION = 'CList/SetDoubleClickAction';
+
+ {
+ wParam : HCONTACT
+ lParam : <none>
+ Affect : Register with this event to be notified of a double click on the CList
+ against a HCONTACT, you will not be notified if there is a pending CList event
+ that the double click clears, (i.e. flashing icon is presented to be clicked)
+ Version: 0.3.0.0
+ }
+ ME_CLIST_DOUBLECLICKED = 'CList/DoubleClicked';
+
+ {
+ wParam : HCONTACT
+ lParam : flags
+ Affect : Gets the string that the contact list will use to represent a contact
+ Returns: Always a pointer
+ Notes : Returns a pointer to the name, will always succeed, even if it needs
+ to return "(Unknown Contact)"
+ -
+ this pointer is a statically allocated buffer which will
+ be overwritten on every call to this service, callers should make
+ sure that they copy the information before they call it again
+ Version: v0.1.2.0+, 0.2.0+ ONLY (0.3a supports the contacts module)
+ }
+ MS_CLIST_GETCONTACTDISPLAYNAME = 'CList/GetContactDisplayName';
+
+ {
+ wParam : 0
+ lParam : Pointer to a TCLISTEVENT
+ Affect : Add's an event to the list
+ Notes : The service will flash TCLISTEVENT.hIcon, next to the
+ contact, TCLISTEVENT.hContact
+ -
+ pszService is called is called wParam=hwndContactList,
+ lParam=pointer to a TCLISTEVENT.
+ -
+ the TCLISTEVENT data is invalidated after this service returns
+ so copy anything from it if required.
+ -
+ TCLISTEVENT.pszService will also be called if the user
+ double clicks on the icon, at which point it will be removed
+ from the contact lists queue automatically.
+ -
+ TCLISTEVENT.hContact and TCLISTEVENT.hDBEvent should be unique.
+ }
+ MS_CLIST_ADDEVENT = 'CList/AddEvent';
+
+ {
+ wParam : HCONTACT
+ lParam : HDBEVENT
+ Affect : Remove an event from the contact list queue
+ Returns: 0 on success, [non zero] on failure
+ }
+ MS_CLIST_REMOVEEVENT = 'Clist/RemoveEvent';
+
+ {
+ wParam : HCONTACT
+ lParam : iEvent
+ Affect : Get the details of an event in the queue, see notes
+ Returns: A CLISTEVENT* or NULL(0) on failure
+ Notes : Returns the iEvent'1st/2nd/3rd/nth elemented queried,
+ e.g. iEvent=0 will get the event that will be returned if the
+ user double clicks on that HCONTACT
+ -
+ Use HCONTACT=NULL, iEvent=0 for example to get the event
+ the user will get if they double click on the tray.
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_GETEVENT = 'CList/GetEvent';
+
+ {
+ wParam : ControlID
+ lParam : Pointer to MEASUREITEMSTRUCT struct
+ Affect : Process a WM_MEASUREITEM message for user context menus, see notes
+ Notes : just because wParam, lParam is defined here, only pass them
+ opaquely to this service, as is.
+ -
+ This is just to draw icons, if it is not called, the icons
+ will not be drawn
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUMEASUREITEM = 'CList/MenuMeasureItem';
+
+ {
+ wParam :
+ lParam :
+ Affect : Process a WM_DRAWITEM message for user context menus,
+ wParam, lParam should be passed from such message handler.
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUDRAWITEM = 'CList/MenuDrawItem';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Built the context menu for a specific contact
+ Returns: A HMENU handle identifying the menu, thhis should be DestroyMenu()ed
+ when done.
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUBUILDCONTACT = 'CList/MenuBuildContact';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Get the image list handle with all the useful icons in it
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GETICONSIMAGELIST = 'CList/GetIconsImageList';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Get the icon that should be associated with a contact
+ Returns: an index into the contact list imagelist, if the icon
+ is a flashing icon, this service won't return information about it
+ see below
+ Version: v0.1.2.0+
+ }
+ MS_CLIST_GETCONTACTICON = 'CList/GetContactIcon';
+
+ {
+ wParam : HCONTACT
+ lParam : ICON_ID
+ Affect : The icon of a contact in the contact list has changed,
+ ICON_ID is an index to what image has changed
+ Version: v0.1.2.1+
+ }
+ ME_CLIST_CONTACTICONCHANGED = 'CList/ContactIconChanged';
+
+ // ideally only used by a CLIST UI module
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Get the handle to Miranda's main menu
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUGETMAIN = 'CList/MenuGetMain';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Get a handle to Miranda's status menu
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUGETSTATUS = 'CList/MenuGetStatus';
+
+ {
+ wParam : MAKEWPARAM(LOWORD(wParam of WM_COMMAND),flags)
+ lParam : HCONTACT
+ Affect : Process a mennu selection from a menu, see notes
+ Returns: True if it processed the command, False otherwise
+ notes : hContact is the currently selected contact, it is not used
+ if this is a main menu command, if this is NULL then the command
+ is a contact menu one, the command is ignored
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUPROCESSCOMMAND = 'CList/MenuProcessCommand';
+
+ {
+ wParam : virtual key code
+ lParam : MPCF_* flags
+ Affect : Process a menu hotkey, see notes
+ Returns: True if it processed the command, False otherwise
+ Notes : this should be called in WM_KEYDOWN
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_MENUPROCESSHOTKEY = 'CList/MenuProcessHotkey';
+
+ {
+ wParam : Pointer to a MSG structurer
+ lParam : Pointer to an LRESULT
+ Affect : Process all the messages required for docking, see notes
+ Returns: True if the message should NOT be processed anymore, False otherwise
+ Notes : only msg.hwnd, msg.message, msg.wParam and msg.lParam are used
+ your WndProc should return the lResult if AND only IF, TRUE is returned
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_DOCKINGPROCESSMESSAGE = 'CList/DockingProcessMessage';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Determines wheter the contact list docked
+ Returns: pnon zero] if the contact list is docked, or 0 if it's not
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_DOCKINGISDOCKED = 'CList/DockingIsDocked';
+
+ {
+ wParam : Pointer to a TMSG
+ lParam : Pointer to an LRESULT
+ Affect : Process all the messages required for the tray icon, see notes
+ Returns: TRUE if the message should not be processed anymore, False otherwise
+ Notes : Only msg.hwnd, msg.message, msg.wparam and msg.lParam are used
+ your WndProc should return LRESULT if and ONLY if TRUE is returned
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_TRAYICONPROCESSMESSAGE = 'CList/TrayIconProcessMessage';
+
+ {
+ wParam : Pointer to TMSG
+ lParam : Pointer to an LRESULT
+ Affect : Process all the messages required for hotkeys, see notes
+ Returns: True if the message should not be processed anymore or False otherwise
+ Notes : only msg.hwnd, msg.message, msg.wParam, msg.lParam are used
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_HOTKEYSPROCESSMESSAGE = 'CList/HotkeysProcessMessage';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Toggles the show/hide status of the contact list
+ Returns: 0 on success, [non zero] on failure
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_SHOWHIDE = 'CList/ShowHide';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : temporarily disable the autohide feature, see notes
+ Notes : this service will restart the auto hide timer, so if you need
+ to keep the window visible you'll have to bee getting user input
+ or calling this service each time
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_PAUSEAUTOHIDE = 'CList/PauseAutoHide';
+
+ {
+ wParam : HPARENTGROUP
+ lParam : 0
+ Affect : Create a new group and calls CLUI to display it, see notes
+ Returns: A handle to the new group.
+ Notes : If HPARENTGROUP is NULL(0) it will create a group at the root.
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GROUPCREATE = 'CList/GroupCreate';
+
+ {
+ wParam : HGROUP
+ lParam : 0
+ Affect : Delete a group and call CLUI to display the change
+ Returns: 0 on success, [non zero] on failure
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GROUPDELETE = 'CList/GroupDelete';
+
+ {
+ wParam : HGROUP
+ lParam : newState
+ Affect : Change the expanded state flag for a group internally, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : if newState is non zero then the group is expanded, 0 it's collapsed
+ CLUI IS *NOT* called when the change is made.
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GROUPSETEXPANDED = 'CList/GroupSetExpanded';
+
+ {
+ wParam : HGROUP
+ lParam : MAKELPARAM(flags, flagsMask)
+ Affect : Change the flag for a group, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : only if flags given in flagsmask are altered,
+ CLUI is called on change to GROUPF_HIDEOFFLINE
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_GROUPSETFLAGS = 'CList/GroupSetFlags';
+
+ {
+ wParam : HGROUP
+ lParam : Pointer to a integer to be filled with expanded state
+ Affect : get the name of a group, see notes
+ Returns: a static buffer pointing to the name of the group
+ returns NULL(0) if HGROUP is invalid.
+ Notes : the returned buffer is only valid til the next call
+ to this service, lParam can be NULL(0) if you don't
+ want to know if the group is expanded
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GROUPGETNAME = 'CList/GroupGetName';
+
+ {
+ wParam : HGROUP
+ lParam : Pointer to flags
+ Affect : Get the name of the group, see notes
+ Returns: A static buffer pointing to the name of the group
+ returns NULL(0) if HGROUP is invalid
+ Note : this buffer is only valid til the next call to this service
+ flags can be NULL(0), otherwise it'll return GROUPF_* constants
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_GROUPGETNAME2 = 'CList/GroupGetName2';
+
+ {
+ wParam : HGROUP
+ lParam : HBEFOREGROUP
+ Affect : Move a group directly before another group
+ Returns: the new handle of the group on success, NULL(0) on failure
+ Notes : the order is represented by the order in which MS_CLUI_GROUPADDED
+ is called, however UI's are free to ignore this order and sort
+ if they wish.
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_GROUPMOVEBEFORE = 'CList/GroupMoveBefore';
+
+ {
+ wParam : HGROUP
+ lParam : Pointer to a null terminated string containing the new name
+ Affect : Rename a group internally, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : this will fail if the group name is a duplicate of an existing
+ a name, CLUI is not called when this change is made.
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_GROUPRENAME = 'CList/GroupRename';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Build a menu of the group tree, see notes
+ Returns: Handle to the menu, NULL(0) on failure
+ Notes : NULL be returned if the user doesn't have any groups
+ the dwItemData of every menu item is the handle to that group.
+ Menu item ID's are assigned starting at 100 in no particular order
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_GROUPBUILDMENU = 'CList/GroupBuildMenu';
+
+ {
+ wParam : newValue
+ lParam : 0
+ Affect : Changes the 'hide offline contacts' flag and calls CLUI, see notes
+ Returns: 0 success, [non zero] on failure
+ Notes : newValue is 0 to show all contacts, 1 to show only online contacts
+ -1 to toggle the value
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_SETHIDEOFFLINE = 'CList/SetHideOffline';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Do the message processing associated with the double clicking a contact
+ Returns: 0 on success, [non zero] on failure
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_CONTACTDOUBLECLICKED = 'CList/ContactDoubleClicked';
+
+ {
+ wParam : HCONTACT
+ lParam : Pointer to an array of pchar's containing files/dirs
+ Affect : Do the processing when some files are droppeed on a contact, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : the array is terminated when a NULL(0) entry is found
+ Version: v0.1.2.1+
+ }
+ MS_CLIST_CONTACTFILESDROPPED = 'CList/ContactFilesDropped';
+
+ {
+ wParam : HCONTACT
+ lParam : HGROUP
+ Affect : Change the group a contact belongs to, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : use hGroup=NULL(0) to remove any group association with the contact
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_CONTACTCHANGEGROUP = 'CList/ContactChangeGroup';
+
+ {
+ wParam : HCONTACT_1
+ lParam : HCONTACT_2
+ Affect : Determine the ordering of two given contacts
+ Returns: 0 if hContact1 is the same as hContact2
+ 1 if hContact1 should be displayed before hContact2
+ -1 if hContact1 should be displayed after hCotnact2
+ Version: v0.1.1.0+
+ }
+ MS_CLIST_CONTACTSCOMPARE = 'CList/ContactsCompare';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clui.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clui.inc new file mode 100644 index 0000000000..c62b40e458 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_clui.inc @@ -0,0 +1,215 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_CLUI}
+{$DEFINE M_CLUI}
+
+ {<</
+ this header was created for use for v0.1.1.0, most of it's UI related
+ stuff and you probably don't need to call it, see m_clist.inc instead.
+ -- There are some functions that were implemented in v0.1.2.0 though
+ />>}
+
+const
+
+ {
+ wParam : 0
+ lParam : 0
+ Affects: Returns a window handle for the contact list window, see notes
+ Returns: ""
+ Notes : This call has a very specific purpose internally Miranda
+ and shouldn't be used gratuitously, in almost all cases
+ there's another call to do whatever it is that you're
+ trying to do.
+ }
+ MS_CLUI_GETHWND = 'CLUI/GetHwnd';
+
+ {
+ wParam : new status
+ lParam : null terminated string to a protocol ID
+ Affects: Change the protocol specific status indicators, see notes!
+ Returns: 0 on success, [non zero] on failure
+ Notes : protocol modules don't want to call this, they want
+ clist/protocolstatuschanged instead
+ }
+ MS_CLUI_PROTOCOLSTATUSCHANGED = 'CLUI/ProtocolStatusChanged';
+
+ {
+ wParam : Handle to a group
+ lParam : 1 or 0
+ Affect : A new group was created, add it to the list, see notes
+ Notes : lParam is set to 1 or 0 if the user just created
+ the group or not.
+ -
+ this is also called when the contact list is being rebuilt,
+ new groups are always created with the name 'New group'
+ }
+ MS_CLUI_GROUPADDED = 'CLUI/GroupCreated';
+
+ {
+ wParam : HCONTACT
+ lParam : ICON_ID
+ Affect : Change the icon for a contact, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : ICON_ID is an offset in the imagelist, see clist/geticonsimagelist
+ }
+ MS_CLUI_CONTACTSETICON = 'CLUI/ContactSetIcon';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Remove a contact from the list, see notes
+ Returns: 0 on success, [non zereo] on failure
+ Notes : this contact is NOT actually being deleted, since if
+ a contact goes offline while 'hide offline' option is sset,
+ this service will be called then ALSO
+ }
+ MS_CLUI_CONTACTDELETED = 'CLUI/ContactDeleted';
+
+ {
+ wParam : HCONTACT
+ lParam : ICON_ID
+ Affect : Add a contact to the list, see note
+ returns: 0 on success, [non zero] on failure
+ Notes : the caller processes the 'hide offline' setting, so the callee
+ should not do further processing based on the value of this setting
+ -
+ WARNING: this will be called to re-add a contact when they come
+ online if 'hide offline' is on, but it cannot determine if
+ the contact is already on the list, so you may get requests to
+ add a contact when it is already on the list, which you should ignore.
+ -
+ You'll also get this whenever an event is added for a contact,
+ since if the contact was offline, it needs to be shown to
+ display the mesage, even if 'hide offlines' is on.
+ -
+ you should not resort the list on this call, a seperate resort
+ request will be sent.
+ -
+ ICON_ID is an offset in the image list, see clist/geticonsimagelist
+
+ }
+ MS_CLUI_CONTACTADDED = 'CLUI/ContactAdded';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Reename a contact in the lists, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : You should not re-sort the list on this call, a separate resort
+ request will be sent, you can get the new name from clist/getcontactdisplayname
+ }
+ MS_CLUI_CONTACTRENAMED = 'CLUI/ContactRenamed';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Start a rebuild of the contact list, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : this is the cue to clear the existing content of the list
+ expect to get a series of :
+
+ clui/groupadded
+ clui/contactadded
+ clui/resortlist
+ }
+ MS_CLUI_LISTBEGINREBUILD = 'CLUI/ListBeginRebuild';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : End a rebuild of the contact list, see notes
+ Returns: 0 on success, [non zero] on error
+ Notes : if you dissplayed an hourglass in beginbuild, set it back
+ here, you do not need to explicitly sort the list
+ }
+ MS_CLUI_LISTENDREBUILD = 'CLUI/ListEndRebuild';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Sort the contact list now, see notes
+ Returns: 0 success, [non zero] on failure
+ Notes : Sorts are buffered so you won't get this message lots of times
+ if the lists needs to be resorted many times rapidly
+ }
+ MS_CLUI_SORTLIST = 'CLUI/SortList';
+
+ {
+ wParam : CLUICAPS_*
+ lParam : 0
+ Affect : Gets a load of capabilites for the loaded CLUI, see notes
+ Returns: the requested value, 0 of wParam is unknown --
+ if this service is not implemented it is assumed all return
+ values will be 0.
+ Version: v0.1.2.1+
+ }
+
+ { can only provide this flag to return the following set of caps, the strings
+ show the database setting/type to store the list option, changing the value
+ does not reflect what the change is, i.e. ontop can only be affected with
+ a call to SetWindowPos() }
+ CLUICAPS_FLAGS1 = 0;
+ { empty groups aren't shown, 'CList/HideEmptyGroups' (byte) [changes make the list reload] }
+ CLUIF_HIDEEMPTYGROUPS = 1;
+ { groups can be disabled, lists can be merged into one seamlessly, (byte) 'CList/UseGroups' }
+ CLUIF_DISABLEGROUPS = 2;
+ { list can be displayed 'on top' of all other windows, 4 (byte) 'CList/OnTop' }
+ CLUIF_HASONTOPOPTION = 4;
+ { can disappear after a while of inactive use,
+ (byte) 'CList/AutoHide' (word) 'CList/HideTime' }
+ CLUIF_HASAUTOHIDEOPTION = 8;
+
+ MS_CLUI_GETCAPS = 'CLUI/GetCaps';
+
+ {
+ wParam : HCONTACT
+ lParam : MAKELPARAM(screenX, screenY)
+ Affect : A contact is being dragged outside the main window
+ Return : return [non zero] to show the drag cursor as "accepting" the drag
+ or zero to show the circle/slash 'not allowed'
+ Version: v0.1.2.0+
+ }
+ ME_CLUI_CONTACTDRAGGING = 'CLUI/ContactDragging';
+
+ {
+ wParam : HCONTACT
+ lParam : MAKELPARAM(screenX, screenY)
+ Affect : a contact has just been dropped outside the main window, see notes
+ Notes : return non zero to stop other hooks processing this event.
+ Version: v0.1.2.0+
+ }
+ ME_CLUI_CONTACTDROPPED = 'CLUI/ContactDropped';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : A contact that *was* being dragged outside the main window
+ has gone back to the main window
+ Return : always return 0
+ Version: v0.1.2.1+
+ }
+ ME_CLUI_CONTACTDRAGSTOP = 'CLUI/ContactDragStop';
+
+{$ENDIF}
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_contacts.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_contacts.inc new file mode 100644 index 0000000000..4ea0d936c3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_contacts.inc @@ -0,0 +1,84 @@ +(*
+Miranda IM
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+type
+
+ PCONTACTINFO = ^TCONTACTINFO;
+ TCONTACTINFO = record
+ cbSize: int;
+ dwFlag: Byte;
+ hContact: THandle;
+ szProto: PChar;
+ type_: Byte;
+ retval: record (* in C this is a nameless union *)
+ case longint of
+ 0: (bVal: Byte);
+ 1: (wVal: WORD);
+ 2: (dVal: DWORD);
+ 3: (pszVal: PChar);
+ 4: (cchVal: Word);
+ end;
+ end;
+
+const
+
+// CNF_* Types of information you can retreive by setting the dwFlag in CONTACTINFO
+
+ CNF_FIRSTNAME = 1; // returns first name (string)
+ CNF_LASTNAME = 2; // returns last name (string)
+ CNF_NICK = 3; // returns nick name (string)
+ CNF_CUSTOMNICK = 4; // returns custom nick name, clist name (string)
+ CNF_EMAIL = 5; // returns email (string)
+ CNF_CITY = 6; // returns city (string)
+ CNF_STATE = 7; // returns state (string)
+ CNF_COUNTRY = 8; // returns country (string)
+ CNF_PHONE = 9; // returns phone (string)
+ CNF_HOMEPAGE = 10; // returns homepage (string)
+ CNF_ABOUT = 11; // returns about info (string)
+ CNF_GENDER = 12; // returns gender (byte,'M','F' character)
+ CNF_AGE = 13; // returns age (byte, 0==unspecified)
+ CNF_FIRSTLAST = 14; // returns first name + last name (string)
+ CNF_UNIQUEID = 15; // returns uniqueid, protocol username (must check type for type of return)
+
+// Special types
+// Return the custom name using the name order setting
+// IMPORTANT: When using CNF_DISPLAY you MUST free the string returned
+// You must **NOT** do this from your version of free() you have to use Miranda's free()
+// you can get a function pointer to Miranda's free() via MS_SYSTEM_GET_MMI, see m_system.h
+ CNF_DISPLAY = 16;
+// Same as CNF_DISPLAY except the custom handle is not used
+// IMPORTANT: When using CNF_DISPLAYNC you MUST free the string returned
+// You must **NOT** do this from your version of free() you have to use Miranda's free()
+// you can get a function pointer to Miranda's free() via MS_SYSTEM_GET_MMI, see m_system.h
+ CNF_DISPLAYNC = 17;
+
+// If MS_CONTACT_GETCONTACTINFO returns 0 (valid), then one of the following
+// types is setting telling you what type of info you received
+ CNFT_BYTE = 1;
+ CNFT_WORD = 2;
+ CNFT_DWORD = 3;
+ CNFT_ASCIIZ = 4;
+
+ {
+ wParam : not used
+ lParam : Pointer to an initialised TCONTACTINFO structure
+ affects: Get contact information
+ returns: Zero on success, non zero on failure.
+ notes : If successful, the type is set and the result is put into the associated member of TCONTACTINFO
+ }
+ MS_CONTACT_GETCONTACTINFO = 'Miranda/Contact/GetContactInfo';
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_database.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_database.inc new file mode 100644 index 0000000000..678977979c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_database.inc @@ -0,0 +1,654 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_DATABASE}
+{$DEFINE M_DATABASE}
+
+const
+
+ DBVT_DELETED = 0; // setting got deleted, no values are valid
+ DBVT_BYTE = 1; // bVal, cVal are valid
+ DBVT_WORD = 2; // wVal, sVal are valid
+ DBVT_DWORD = 4; // dVal, lVal are valid
+ DBVT_ASCIIZ = 255; // pszVal is valid
+ DBVT_BLOB = 254; // cpbVal and pbVal are valid
+ DBVTF_VARIABLELENGTH = $80; // ?
+
+type
+
+ HCONTACT = Integer;
+ HDBEVENT = Integer;
+
+ PDBVARIANT = ^TDBVARIANT;
+ TDBVARIANT = record
+ type_: Byte;
+ case LongInt of
+ 0: (bVal: Byte);
+ 1: (cVal: Char);
+ 2: (wVal: Word);
+ 3: (sVal: SmallInt);
+ 4: (dVal: LongInt);
+ 5: (lVal: Integer);
+ 6: (
+ pszVal: PChar;
+ cchVal: Word;
+ );
+ 7: (
+ cpbVal: Word;
+ pbVal: PByte;
+ );
+ end;
+
+const
+
+ {
+ wParam : size of the buffer to be filled
+ lParam : pointer to the buffer to be filled
+ affect : Get's the name of the current profile being used by the database
+ module -- this is the same as the filename of the profile without
+ the .ext
+ return : 0 on success, non zero on failure
+ }
+ MS_DB_GETPROFILENAME = 'DB/GetProfileName';
+
+ {
+ wParam : size of buffer pointed to by lParam
+ lParam : pointer to a buffer to be filled
+ affect : Fill a buffer with the current profile path being used, this does not include the trailing backslash.
+ return : 0 on success, non zero on failure
+ version: 0.3a only
+ }
+ MS_DB_GETPROFILEPATH = 'DB/GetProfilePath';
+
+type
+
+ PDBCONTACTGETSETTING = ^TDBCONTACTGETSETTING;
+ TDBCONTACTGETSETTING = record
+ { name of the module that wrote the setting to get }
+ szModule: PChar;
+ { the name of the setting to get }
+ szSetting: PChar;
+ { pointer to DBVARIANT to receive the value -- must be allocated for GETSETTINGSTATIC
+ calls thou }
+ pValue: PDBVARIANT;
+ end;
+
+ PDBCONTACTWRITESETTING = ^TDBCONTACTWRITESETTING;
+ TDBCONTACTWRITESETTING = record
+ { module sig to write this setting under }
+ szModule: PChar;
+ { setting name to write }
+ szSetting: PChar;
+ { variant containing value to set }
+ value: TDBVARIANT;
+ end;
+
+const
+
+ {
+ wParam : Handle of a contact to get the setting for (see notes)
+ lParam : pointer to a TDBCONTACTGETSETTING structure to be filled with setting
+ this structure also has to be initalised (see notes)
+ affect : Queries the database module for a setting from a contact.
+ returns: 0 on success, non zero on failure (contact not found, setting doesn't exist)
+ notes : TDBCONTACTGETSETTING must be filled with the module name that created
+ /wrote the setting you want to get (e.g. your module name)
+ and the actual setting to read with TDBCONTACTGETSETTING.szModule and
+ TDBCONTACTGETSETTING.szSetting -- TDBCONTACTGETSETTING.pValue is
+ a pointer to a TDBVARIANT with the returned setting, this maybe nil
+ and MUST be freed after you're done with it with FreeVariant()
+
+ There are helper functions for reading/writing/deleting common types to and
+ from the database -- see DBGetContactSetting<type>
+
+ the contact handle (hContact) can be returned by FindContact/AddContact
+ }
+ MS_DB_CONTACT_GETSETTING = 'DB/Contact/GetSetting';
+
+ {
+ wParam : Handle for a contact to query a setting for
+ lParam : Pointer to a TDBCONTACTGETSETTING structure
+ affects: This service is almost the same as the one above, but it does
+ not return a dynamic copy (with malloc()) -- the caller
+ must do this for datatypes which require it, e.g. a string.
+
+ This means the TDBCONTACTGETSETTING.pValue *has* to exist and be
+ allocated by the caller (doesn't have to be allocated from the heap)
+ the DBVARIANT structure has to be initalised with the type wanted
+ and enough buffer space around to return the info, do not
+ expect this service to be as fast as the one above.
+
+ returns: 0 on success, non zero on failure.
+ }
+ MS_DB_CONTACT_GETSETTINGSTATIC = 'DB/Contact/GetSettingStatic';
+
+ {
+ wParam : 0
+ lParam : Pointer to a TDBVARIANT structure
+ affect : Free's the passed DBVARIANT's dynamic memory (if any) see notes
+ returns: 0 on success, non zero on failure
+ notes : use the helper function FreeVariant()
+ }
+ MS_DB_CONTACT_FREEVARIANT = 'DB/Contact/FreeVariant';
+
+ {
+ wParam : Handle to contact to write setting for
+ lParam : Pointer to TDBCONTACTWRITESETTING which must be initalised
+ affects: writes a setting under a contact -- TDBCONTACTWRITESETTING structure
+ must contain the module name writing -- the setting name, and the value
+ to write (which is NOT a pointer) .szModule, .szSetting, .Value, see notes
+ returns: 0 on success, non zero on failure
+ notes : this service triggers 'DB/Contact/SettingChanged' before it returns
+ as always, there is a helper function to use this service.
+ }
+ MS_DB_CONTACT_WRITESETTING = 'DB/Contact/WriteSetting';
+
+ {
+ wParam : hContact under which the setting should be deleted
+ lParam : Pointer to a TDBCONTACTGETSETTING structure
+ affects: Deletes the given setting for a contact, the TDBCONTACTGETSETTING.pValue
+ field is ignored -- only .szModule and .szSetting are needed, see notes
+ returns: 0 on success, non zero on failure
+ notes : triggers 'DB/Contact/SettingChanged' BEFORE it deletes the given
+ setting, when the service returns the TDBVARIANT structure .type_ is set
+ to 0 and no fields are valid, there is a helper function for this
+ service, see below.
+ }
+ MS_DB_CONTACT_DELETESETTING = 'DB/Contact/DeleteSetting';
+
+ {
+ wParam : Handle of a contact to enum settings for
+ lParam : Pointer to a TDBCONTACTENUMSETTINGS structure, must be initalised
+ affect : Enumerates all settings for a given contact under a module,
+ TDBCONTACTENUMSETTINGS must be filled with the function pointer to call
+ the TDBCONTACTENUMSETTINGS.lParam value to pass to it each time,
+ as well as the .szModule under which the contact is valid
+ returns: returns the value of the last call to the enum function, or -1
+ if no settings could be enumerated
+ notes : the szSetting argument passed to the enumeration function is only
+ valid for the duration of that enumeration call,
+ it must be allocated dynamically if it is required after that call frame
+ has returned.
+ Also, deleting settings as they are enumerated has unpredictable results!
+ but writing a new value for a setting is okay.
+ it is unclear how you stop the enumeration once it is started, maybe
+ possible to return -1 to stop it.
+ vesion : only valid for 0.1.0.1+
+ }
+
+type
+
+ TDBSETTINGENUMPROC = function(const szSetting: PChar; lParam: LPARAM): int; cdecl;
+
+ PDBCONTACTENUMSETTINGS = ^TDBCONTACTENUMSETTINGS;
+ TDBCONTACTENUMSETTINGS = record
+ { function pointer to call to start the enum via MS_DB_CONTACT_ENUMSETTINGS }
+ pfnEnumProc: TDBSETTINGENUMPROC;
+ { passed to the above function }
+ lParam: LPARAM;
+ { name of the module to get settings for }
+ szModule: PChar;
+ { not used by us }
+ ofsSettings: DWORD;
+ end;
+
+const
+
+ MS_DB_CONTACT_ENUMSETTINGS = 'DB/Contact/EnumSettings';
+
+ {
+ wParam : 0
+ lParam : 0
+ affect : none
+ returns: Returns the number of contacts in the database for the loaded profile
+ not including the profile user, see notes.
+ notes : the contacts in the database can be read with FindFirst/FindNext
+ }
+ MS_DB_CONTACT_GETCOUNT = 'DB/Contact/GetCount';
+
+ {
+ wParam : 0
+ lParam : 0
+ returns: Returns a handle to the first contact in the database,
+ this handle does not need to be closed, if there are no users
+ NULL(0) is returned.
+ }
+ MS_DB_CONTACT_FINDFIRST = 'DB/Contact/FindFirst';
+
+ {
+ wParam : Contact handle
+ lParam : 0
+ returns: Returns a handle to the next contact after the given contact in
+ wParam, this handle does not neeed to be closed -- may return NULL(0)
+ if the given contact in wParam was the last in the database, or the
+ given contact was invalid
+ }
+ MS_DB_CONTACT_FINDNEXT = 'DB/Contact/FindNext';
+
+ {
+ wParam : Handle of a contact to delete
+ lParam : 0
+ affect : the user by the given handle is deleted from the database, see notes
+ returns: Returns 0 on success or nonzero if the handle was invalid
+ notes : this triggers DB/Contact/Deleted BEFORE it actually deletes the contact
+ all events are also deleted -- other modules may end up with invalid
+ handles because of this, which they should be prepared for.
+ }
+ MS_DB_CONTACT_DELETE = 'DB/Contact/Delete';
+
+ {
+ wParam : 0
+ lParam : 0
+ affects: creates a new contact in the database, they have no settings,
+ settings must be added with MS_DB_CONTACT_WRITESETTING or
+ database helper functions for writing, see notes
+ returns: A handle to a new contact or NULL(0) on failure.
+ notes : triggers the ME_DB_CONTACT_ADDED event just before the service returns
+ }
+ MS_DB_CONTACT_ADD = 'DB/Contact/Add';
+
+
+ {
+ wParam : (HANDLE) hContact
+ lParam : 0
+ affects: Checks the given handle within the database for valid information, for
+ a proper internal header.
+ returns: Returns 1 if the contact handle is valid, 0 if it is not
+ notes : Due to the nature of multiple threading a contact handle can be deleted
+ soon after this service has returned a handle as valid, however it will never point
+ to another contact.
+ }
+ MS_DB_CONTACT_IS = 'DB/Contact/Is';
+
+
+ {
+ wParam : contact handle for events count is needed
+ lParam : 0
+ service: Gets the number of events in the chain belonging to a contact
+ in the databasee.
+ returns: the numbef of events owned by hContact or -1 if hContact
+ is invalid, they can be found with the event/find* servicees
+ }
+ MS_DB_EVENT_GETCOUNT = 'DB/Event/GetCount';
+
+ {
+ wParam : contact handle to add an event for
+ lParam : Pointer to TDBEVENTINFO initialised with data
+ affect : Add's an event to the contact's event list, the TDBEVENTINFO
+ structure should be filled with the event of message -- see notes
+ returns: a handle to a DB event (HDBEVENT), or NULL on error
+ notes : Triggers DB/Event/Added event just before it returns,
+ Events are sorted chronologically as they are entered,
+ so you cannot guarantee that the new hEvent is the last event in the chain,
+ however if a new event is added that has a timestamp less than
+ 90 seconds *before* the event that should be after it,
+ it will be added afterwards, to allow for protocols that only
+ store times to the nearest minute, and slight delays in transports.
+ There are a few predefined eventTypes below for easier compatibility, but
+ modules are free to define their own, beginning at 2000
+ DBEVENTINFO.timestamp is in GMT, as returned by time()
+ }
+
+ DBEF_FIRST = 1; // internally only, do not use
+ DBEF_SENT = 2; // if set, the event was sent by the user, otherwise it was received
+ DBEF_READ = 4; // event has been read by the user -- only needed for history
+
+ EVENTTYPE_MESSAGE = 0;
+ EVENTTYPE_URL = 1;
+ EVENTTYPE_CONTACTS = 2; // v0.1.2.2+
+ EVENTTYPE_ADDED = 1000; // v0.1.1.0+: these used to be module-
+ EVENTTYPE_AUTHREQUEST = 1001; // specific codes, hence the module-
+ EVENTTYPE_FILE = 1002; // specific limit has been raised to 2000
+
+type
+
+ PDBEVENTINFO = ^TDBEVENTINFO;
+ TDBEVENTINFO = record
+ { size of the structure }
+ cbSize: int;
+ { module that 'owns' this event and controls the data format }
+ szModule: PChar;
+ { timestamp in UNIX time }
+ timestamp: DWORD;
+ { the DBEF_* flags above }
+ flags: DWORD;
+ { event type, such as message, can be module defined }
+ eventType: WORD;
+ { size in bytes of pBlob^ }
+ cbBlob: DWORD;
+ { pointer to buffer containing the module defined event data }
+ pBlob: PByte;
+ end;
+
+const
+
+ MS_DB_EVENT_ADD = 'DB/Event/Add';
+
+
+
+ {
+ wParam : Handle to the contact
+ lParam : HDBEVENT handle to delete
+ affects: Removes a single event from the database for the given contact
+ returns: 0 on success, nonzero on failure
+ notes : Triggers DB/Event/Deleted just before the event *is* deleted
+ }
+ MS_DB_EVENT_DELETE = 'DB/Event/Delete';
+
+ {
+ wParam : Handle to DB event
+ lParam : 0
+ returns: Returns the space in bytes requried to store the blob in HDBEVENT
+ given by HDBEVENT(wParam) -- or -1 on error
+ }
+ MS_DB_EVENT_GETBLOBSIZE = 'DB/Event/GetBlobSize';
+
+ {
+ wParam : Handle to a DB event
+ lParam : Pointer to a TDBEVENTINFO structure which must be initialised
+ affects: Returns all the information about an DB event handle to a TDBEVENTINFO
+ structure which must be initalised, DBEI.cbSize, DBEI.pBlob and DBEI.cbSize
+ before calling this service, the size can be assertained with
+ GetBlobSize() service, see notes
+ returns: Returns 0 on success, non zero on failure
+ notes : The correct value dbe.cbBlob can be got using db/event/getblobsize
+ If successful, all the fields of dbe are filled. dbe.cbBlob is set to the
+ actual number of bytes retrieved and put in dbe.pBlob
+ If dbe.cbBlob is too small, dbe.pBlob is filled up to the size of dbe.cbBlob
+ and then dbe.cbBlob is set to the required size of data to go in dbe.pBlob
+ On return, dbe.szModule is a pointer to the database module's
+ own internal list of modules. Look but don't touch.
+ }
+ MS_DB_EVENT_GET = 'DB/Event/Get';
+
+ {
+ wParam : HCONTACT
+ lParam : HDBEVENT
+ affect : Changes the flag for an event to mark it as read
+ Returns: Returns the entire flag DWORD for the event after the change, or -1
+ if HDBEVENT is invalid, see notes
+ notes : This iss one of the database write operations that does not trigger
+ an event, modules should not save flagss states for any length of time.
+ }
+ MS_DB_EVENT_MARKREAD = 'DB/Event/MarkRead';
+
+ {
+ wParam : HDBEVENT
+ lParam : 0
+ Affect : Returns a handle to a contact that owns the HDBEVENT,
+ see notes
+ Returns: Returns a handle if successful or HDBEEVENT(-1) on failure
+ notes : This service is very slow, only use wheen you have no other choice
+ at all.
+ }
+ MS_DB_EVENT_GETCONTACT = 'DB/Event/GetContact';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Retrieves a handlee to the first event in the chain
+ for a HCONTACT
+ returns: Returns a handle, or NULL(0) if HCONTACT is invalid or has
+ no events, events in a chain are sorted chronologically automatically
+ }
+ MS_DB_EVENT_FINDFIRST = 'DB/Event/FindFirst';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Retrieves a handle to the first unreead event in a chain for a HCONTACT
+ see notes
+ Returns: Returns a HDBEVENT handle or NULL(0) if the HCONTACT is invalid
+ or all it's events have beeen read.
+ Notes : Events in a chain are sorted chronologically automatically,
+ but this does not necessarily mean that all events after
+ the first unread are unread too.
+ They should be checked individually with event/findnext and event/get
+ This service is designed for startup, reloading all the events that remained
+ unread from last time
+ }
+ MS_DB_EVENT_FINDFIRSTUNREAD = 'DB/Event/FindFirstUnread';
+
+ {
+ wParam : HCONTACT
+ lParam : 0;
+ Affects: Retrieves a handle to the lasts event in the chain for a HCONTACT
+ Returns: Returns a handle or NULL(0) if HCONTACT is invalid or has no events
+ }
+ MS_DB_EVENT_FINDLAST = 'DB/Event/FindLast';
+
+ {
+ wParam : HDBEVENT
+ lParam : 0
+ Affects: Retrieves a handle to the next event in a chain after HDBEVENT
+ Returns: A handle to the next DB event or NULL(0) if HDBEVENT is invalid
+ or the last event in the chain.
+ }
+ MS_DB_EVENT_FINDNEXT = 'DB/Event/FindNext';
+
+ {
+ wParam : HDBEVENT
+ lParam : 0
+ Affects: Retrieves a handle to the previous event in a chain before HDBEVENT
+ Returns: A handle to the previous HDBEVENT or NULL(0) if HDBEVENT is invalid
+ or is the first event in the chain
+ }
+ MS_DB_EVENT_FINDPREV = 'DB/Event/FindPrev';
+
+
+
+ {
+ wParam : size in bytes of string buffer (including null term)
+ lParam : pointer to string buffer
+ Affect : Scrambles the string buffer in place using a strange encryption algorithm,
+ see notes
+ Returns: Always returns 0
+ notes : this service may be changed at a later date such that it increasess
+ the length of the string
+ }
+ MS_DB_CRYPT_ENCODESTRING = 'DB/Crypt/EncodeString';
+
+ {
+ wParam : size in bytes of string buffer, including null term
+ lParam : pointer to string buffer
+ Affect : Descrambles pszString in-place using the strange encryption algorithm,
+ see notes.
+ Return : Always returns 0
+ notes : Reverses the operation done by MS_DB_CRYPT_ENCODINGSTRING
+ }
+ MS_DB_CRYPT_DECODESTRING = 'DB/Crypt/DecodeString';
+
+
+
+ {
+ wParam : timestamp (DWORD)
+ lParam : 0
+ Affect : Converts a GMT timestap into local time
+ Returns: Returns the converted value, see notes
+ Notes : Timestamps have a zereo at midnight 1/1/1970 GMT, this service
+ converts such a value to be based at midnight 1/1/1970 local time.
+ This service does not use a simple conversion based on the current offset
+ between GMT and local. Rather, it figures out whether daylight savings time
+ would have been in place at the time of the stamp and gives the local time as
+ it would have been at the time and date the stamp contains.
+ }
+ MS_DB_TIME_TIMESTAMPTOLOCAL = 'DB/Time/TimestampToLocal';
+
+ {
+ wParam : timestamp (DWORD)
+ lParam : pointer to initalised DBTIMETOSTRING structure
+ Affect : Converts a GMT timestamp to a customisable local time string
+ see notes
+ Returns: Always returns 0
+ notes : The string is formatted according to thhe current user's locale
+ language and preference --
+
+ .szFormat can have the following special chars :
+ t time without seconds, e.g. hh:mm
+ s time with seconds, e.g. hh:mm:ss
+ m time without minutes e.g. hh
+ d short date, e.g. dd/mm/yyyy
+ D long date, e.g. d mmmm yyyy
+
+ all other characters are copied as is.
+ }
+
+type
+
+ PDBTIMETOSTRING = ^TDBTIMETOSTRING;
+ TDBTIMETOSTRING = record
+ { format string, see above }
+ szFormat: PChar;
+ { pointer to dest buffer to store the result }
+ szDest: PChar;
+ { size of the buffer }
+ cbDest: int;
+ end;
+
+const
+
+ MS_DB_TIME_TIMESTAMPTOSTRING = 'DB/Time/TimestampToString';
+
+
+
+ {
+ wParam : newSetting (BOOLEAN)
+ lParam : 0
+ Affect : Miranda's database is normally protected against corruption by
+ aggressively flushing data to the disk on writes, if you're doing
+ alot of writes e.g. an import plugin, it can sometimes be desirable
+ to switch this feature off to speed up the process, if you do switch
+ it off, you must remember that crashes are far more likely to be
+ catastrophic, so switch it back on at the earliest possible opportunity.
+ if you're doing a lot of setting writes, the flush is already delayed
+ so you need not use this service for that purpose, see notes.
+ Returns: Always returns 0 (successful)
+ notes : This is set to true initally
+ }
+ MS_DB_SETSAFETYMODE = 'DB/SetSafetyMode';
+
+ {
+ wParam : (caller defined data) will be passed to lParam of the call back
+ lParam : function pointer to TDBMODULEENUMPROC
+ Affects: Enumerates the names of all modules that have stored or
+ requested information from the database,
+ the modules are returned in no real order --
+ Writing to the database while module names are being enumerated will cause
+ unpredictable results in the enumeration, but the write will work.
+
+ the enumeration will stop if the callback returns a non zero value.
+
+ Returns: the last return value from the enumeration call back.
+ Notes : This service is only useful for debugging or EnumSettings
+ version: The service registered to enumerate all modules that have touched
+ the database module uses wParam as the lParam cookie value and the lParam
+ value given here is the function pointer -- this is not safe
+ to use before v0.1.2.1 because I don't know if this was done in v0.1.2.1-
+
+ prior to v0.1.2.1 you can not pass a value to the enumeration because
+ of a bug -- which is fixed, but hey :) -- [sam]
+ }
+type
+ TDBMODULEENUMPROC = function(const szModule: PChar; ofsModuleName: DWORD; lParam: LPARAM): int; cdecl;
+const
+ MS_DB_MODULES_ENUM = 'DB/Modules/Enum';
+
+
+
+ {
+ wParam : HCONTACT
+ lParam : HDBCONTACT
+ Affect : Called when a new event has been added to the event chain
+ for a contact, HCONTACT contains the contact who added the event,
+ HDBCONTACT a handle to what was added.
+ see notes
+ notes : since events are sorted chronologically, you can not guarantee
+ that HDBEVEnT is in any particular position in the chain.
+
+ }
+ ME_DB_EVENT_ADDED = 'DB/Event/Added';
+
+ {
+ wParam : HANDLE (hContact)
+ lParam : @DBEVENTINFO
+ Affects: Hook is fired before any DBEVENTS are created within the database for
+ a contact (or a user, if hContact is NULL(0)) - It allows a module to
+ query/change DBEVENTINFO before it is created, see notes.
+ Returns: Hook should return 1 to stop event being added (will stop other hooks seeing the event too)
+ Or 0 to continue processing (passing the data on as well)
+ Notes : This hook is fired for all event types, and the BLOBS that the eventypes mark
+ Maybe changed, therefore be careful about using BLOB formats.
+ Because the memory pointing within the DBEVENTINFO CAN NOT BE OWNED or free()'d
+ it is recommended that the hook only be used to stop events.
+ Version: 0.3.3a+ (2003/12/03)
+ }
+ ME_DB_EVENT_FILTER_ADD = 'DB/Event/FilterAdd';
+
+ {
+ wParam : HCONTACT
+ lParam : HDBEVENT
+ Affect : Called when an event is about to be deleted from the event chain
+ for a contact, see notes
+ notes : Returning non zero from your hook will NOT stop the deletion,
+ but it will as usual stop other hooks being called
+ }
+ ME_DB_EVENT_DELETED = 'DB/Event/Deleted';
+
+
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Called when a new contact has been added to the database,
+ HCONTACT contains a handle to the new contact.
+ }
+ ME_DB_CONTACT_ADDED = 'DB/Contact/Added';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Called when a contact is about to be deleted
+ Returns: Returning nonzero from your hook will not stop the deletion
+ but it will stop the other hooks from being called
+ }
+ ME_DB_CONTACT_DELETED = 'DB/Contact/Deleted';
+
+ {
+ wParam : HCONTACT
+ lParam : Pointer to a TDBCONTACTWRITESETTING
+ Affect : Calleed when a contact has one of it's settings changed
+ hContact is a valid handle to the contact that has changed,
+ see notes.
+ notes : this event will be triggered many times rapidly when alot of values
+ are set.
+ Modules that hook this should be aware of this fact and quickly
+ return if they are not interested in the value that has changed.
+ Careful not to get into infinite loops with this event,
+
+ The TDBCONTACTWRITESETTING pointer is the same one as the
+ original service all, so don't change any of it's fields
+ }
+ ME_DB_CONTACT_SETTINGCHANGED = 'DB/Contact/SettingChanged';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_email.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_email.inc new file mode 100644 index 0000000000..71859ed208 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_email.inc @@ -0,0 +1,39 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_EMAIL}
+{$DEFINE M_EMAIL}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affects: Send an e-mail to the specified contact, see notes
+ Returns: Returns 0 on success or nonzero on failure
+ Notes : If an error occurs the service displays a message box
+ with the error text -- use this service to alter this
+ }
+ MS_EMAIL_SENDEMAIL = 'SREMail/SendCommand';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_file.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_file.inc new file mode 100644 index 0000000000..e1e388fcdc --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_file.inc @@ -0,0 +1,66 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_FILE}
+{$DEFINE M_FILE}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affects: Brings up the send file dialog for a contact, see notes
+ Returns: 0 on success [non zero] on failure
+ Notes : Returns immediately without waiting for the send
+ }
+ MS_FILE_SENDFILE = 'SRFile/SendCommand';
+
+ {
+ wParam : HCONTACT
+ lParam : pointer to an array of PChar's the first nil item
+ terminates the list -- see notes
+ Affects: Brings up the send file dialog with specifieed files already chosen
+ the user is not prevented from editing the list --
+ Returns: 0 on success [non zero] on failure -- returns immediately without
+ waiting for the send to finish
+ Notes : both directories and files can be given
+ Version: v0.1.2.1+
+ }
+ MS_FILE_SENDSPECIFICFILES = 'SRFile/SendSpecificFiles';
+
+ {
+ wParam : HCONTACT
+ lParam : Pointer to a buffer
+ Affects: returns the received files folder for a contact, the buffer
+ should be at least MAX_PATH long (defined with WinAPI),
+ the returned path may not exist -- see notes
+ Returns: Returns 0 on success [non zero] on failure
+ notes : If HCONTACT is NULL(0) the path returned is the path
+ without the postfix contact name.
+ Version: v0.1.2.2+
+ }
+ MS_FILE_GETRECEIVEDFILESFOLDER = 'SRFile/GetReceivedFilesFolder';
+
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_findadd.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_findadd.inc new file mode 100644 index 0000000000..9952a787c8 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_findadd.inc @@ -0,0 +1,38 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_FINDADD}
+{$DEFINE M_FINDADD}
+
+const
+
+ {
+ wParam : 0
+ lParam : 0
+ Affects: Openss the find/add users dialog box, or gives it focus if it's
+ already open.
+ Returns: Always returns 0
+ }
+ MS_FINDADDFINDADD = 'FindAdd/FindAddCommand';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_globaldefs.pas b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_globaldefs.pas new file mode 100644 index 0000000000..2eb47e8a90 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_globaldefs.pas @@ -0,0 +1,98 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFDEF FPC}
+ {$PACKRECORDS C}
+ {$MODE Delphi}
+{$ENDIF}
+
+unit m_globaldefs;
+
+interface
+
+uses
+
+{$ifdef FPC}
+ strings;
+{$else}
+ Windows;
+{$endif}
+
+type
+
+ PByte = ^Byte;
+ int = Integer;
+ pint = ^int;
+ WPARAM = Integer;
+ LPARAM = Integer;
+ DWORD = Integer;
+ THandle = Integer;
+
+ // strcpy()
+
+ {$ifdef FPC}
+ TStrCpy = function(Dst, Src: PChar): PChar;
+ {$else}
+ TStrCpy = function(Dst, Src: PChar): PChar; stdcall;
+ {$endif}
+
+ // strcat()
+
+ {$ifdef FPC}
+ TStrCat = function(Dst, Src: PChar): PChar;
+ {$else}
+ TStrCat = function(Dst, Src: PChar): PChar; stdcall;
+ {$endif}
+
+const
+
+ {$ifdef FPC}
+ strcpy: TStrCpy = strings.strcopy;
+ {$else}
+ strcpy: TStrCpy = lstrcpy;
+ {$endif}
+
+ {$ifdef FPC}
+ strcat: TStrCat = strings.strcat;
+ {$else}
+ strcat: TStrCat = lstrcat;
+ {$endif}
+
+ {$include newpluginapi.inc}
+
+var
+ { this is now a pointer to a record of function pointers to match the C API,
+ and to break old code and annoy you. }
+
+ PLUGINLINK: PPLUGINLINK;
+
+ { has to be returned via MirandaPluginInfo and has to be statically allocated,
+ this means only one module can return info, you shouldn't be merging them anyway! }
+
+ PLUGININFO: TPLUGININFO;
+ PLUGININFOEX: TPLUGININFOEX;
+
+implementation
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_helpers.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_helpers.inc new file mode 100644 index 0000000000..d09d66324e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_helpers.inc @@ -0,0 +1,622 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$ifdef M_API_UNIT}
+
+ function PLUGIN_MAKE_VERSION(a,b,c,d: Cardinal): int;
+ function PLUGIN_CMP_VERSION(verA: LongInt; verB: LongInt): int;
+
+{$else}
+
+ function PLUGIN_MAKE_VERSION(a,b,c,d: Cardinal): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := (a shl 24) or (b shl 16) or (c shl 8) or d;
+ end;
+
+ function PLUGIN_CMP_VERSION(verA: LongInt; verB: LongInt): int; {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := 0;
+ { could be used to compare for severity of age for positive values, if a<b
+ results are minus values, 0 for equal, positive if a is newer }
+ Inc(Result, (verA and $FF) - (verB and $FF));
+ Inc(Result, (verA and $FF00) - (verB and $FF00));
+ Inc(Result, (verA and $FF0000) - (verB and $FF0000));
+ Inc(Result, (verA and $FF000000) - (verB and $FF000000));
+ end;
+
+{$endif}
+
+{$ifdef M_SYSTEM}
+ {$ifdef M_API_UNIT}
+
+ function CallService(const szService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+
+ function HookEvent(const szHook: PChar; hook_proc: TMIRANDAHOOK): int;
+
+ function UnhookEvent(const hHook: THandle): int;
+
+ function CreateServiceFunction(const szName: PChar; const MirandaService: TMIRANDASERVICE): int;
+
+ {$else}
+
+ function CallService(const szService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(szService, wParam, lParam);
+ end;
+
+ function HookEvent(const szHook: PChar; hook_proc: TMIRANDAHOOK): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.HookEvent(szHook, @hook_proc);
+ end;
+
+ function UnhookEvent(const hHook: THandle): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.UnhookEvent(hHook);
+ end;
+
+ function CreateServiceFunction(const szName: PChar; const MirandaService: TMIRANDASERVICE): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CreateServiceFunction(szName, @MirandaService);
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_DATABASE}
+
+ {$ifdef M_API_UNIT}
+
+ function DBGetContactSettingByte(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+
+ function DBGetContactSettingWord(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+
+ function DBGetContactSettingDword(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+
+ function DBGetContactSetting(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; dbv: PDBVARIANT): Integer;
+
+ function DBFreeVariant(dbv: PDBVARIANT): Integer;
+
+ function DBDeleteContactSetting(hContact: THandle; const szModule: PChar; const szSetting: PChar): Integer;
+
+ function DBWriteContactSettingByte(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: Byte): Integer;
+
+ function DBWriteContactSettingWord(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: Word): Integer;
+
+ function DBWriteContactSettingDWord(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: LongInt): Integer;
+
+ function DBWriteContactSettingString(hContact: THandle; const szModule: PChar; const szSetting: PChar; const val: PChar): Integer;
+
+ {$else}
+
+ function DBGetContactSettingByte(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ dbv: TDBVARIANT;
+ cgs: TDBCONTACTGETSETTING;
+ begin
+
+ cgs.szModule := szModule;
+ cgs.szSetting := szSetting;
+ cgs.pValue := @dbv;
+
+ If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING, hContact, lParam(@cgs)) <> 0 then
+ Result := ErrorValue
+ else
+ Result := dbv.bVal;
+ end;
+
+ function DBGetContactSettingWord(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ dbv: TDBVARIANT;
+ cgs: TDBCONTACTGETSETTING;
+ begin
+ cgs.szModule := szModule;
+ cgs.szSetting := szSetting;
+ cgs.pValue := @dbv;
+ If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING, hContact, lParam(@cgs)) <> 0 then
+ Result := ErrorValue
+ else
+ Result := dbv.wVal;
+ end;
+
+ function DBGetContactSettingDword(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; errorValue: Integer): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ dbv: TDBVARIANT;
+ cgs: TDBCONTACTGETSETTING;
+ begin
+ cgs.szModule := szModule;
+ cgs.szSetting := szSetting;
+ cgs.pValue := @dbv;
+ If PluginLink^.CallService(MS_DB_CONTACT_GETSETTING, hContact, lParam(@cgs)) <> 0 then
+ Result := ErrorValue
+ else
+ Result := dbv.dVal;
+ end;
+
+ function DBGetContactSetting(hContact: THandle;
+ const szModule: PChar; const szSetting: PChar; dbv: PDBVARIANT): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cgs: TDBCONTACTGETSETTING;
+ begin
+ cgs.szModule := szModule;
+ cgs.szSetting := szSetting;
+ cgs.pValue := dbv;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_GETSETTING, hContact, lParam(@cgs));
+ end;
+
+ function DBFreeVariant(dbv: PDBVARIANT): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(MS_DB_CONTACT_FREEVARIANT, 0, lParam(dbv));
+ end;
+
+ function DBDeleteContactSetting(hContact: THandle; const szModule: PChar; const szSetting: PChar): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cgs: TDBCONTACTGETSETTING;
+ begin
+ cgs.szModule := szModule;
+ cgs.szSetting := szSetting;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_DELETESETTING, hContact, lParam(@cgs));
+ end;
+
+ function DBWriteContactSettingByte(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: Byte): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cws: TDBCONTACTWRITESETTING;
+ begin
+ cws.szModule := szModule;
+ cws.szSetting := szSetting;
+ cws.value.type_ := DBVT_BYTE;
+ cws.value.bVal := Val;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING, hContact, lParam(@cws));
+ end;
+
+ function DBWriteContactSettingWord(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: Word): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cws: TDBCONTACTWRITESETTING;
+ begin
+ cws.szModule := szModule;
+ cws.szSetting := szSetting;
+ cws.value.type_ := DBVT_WORD;
+ cws.value.wVal := Val;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING, hContact, lParam(@cws));
+ end;
+
+ function DBWriteContactSettingDWord(hContact: THandle; const szModule: PChar; const szSetting: PChar; val: LongInt): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cws: TDBCONTACTWRITESETTING;
+ begin
+ cws.szModule := szModule;
+ cws.szSetting := szSetting;
+ cws.value.type_ := DBVT_DWORD;
+ cws.value.dVal := Val;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING, hContact, lParam(@cws));
+ end;
+
+ function DBWriteContactSettingString(hContact: THandle; const szModule: PChar; const szSetting: PChar; const val: PChar): Integer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ cws: TDBCONTACTWRITESETTING;
+ begin
+ cws.szModule := szModule;
+ cws.szSetting := szSetting;
+ cws.value.type_ := DBVT_ASCIIZ;
+ cws.value.pszVal := Val;
+ Result := PluginLink^.CallService(MS_DB_CONTACT_WRITESETTING, hContact, lParam(@cws));
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_NETLIB}
+
+ {$ifdef M_API_UNIT}
+
+ function Netlib_CloseHandle(Handle: THandle): int;
+
+ function Netlib_GetBase64DecodedBufferSize(const cchEncoded: int): int;
+
+ function Netlib_GetBase64EncodedBufferSize(const cbDecoded: int): int;
+
+ function Netlib_Send(hConn: THandle; const buf: PChar; len: int; flags: int): int;
+
+ function Netlib_Recv(hConn: THandle; const buf: PChar; len: int; flags: int): int;
+
+ procedure Netlib_Log(hNetLib: THandle; const sz: PChar);
+
+ {$else}
+
+ function Netlib_CloseHandle(Handle: THandle): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(MS_NETLIB_CLOSEHANDLE, Handle, 0);
+ end;
+
+ function Netlib_GetBase64DecodedBufferSize(const cchEncoded: int): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := (cchEncoded shr 2) * 3;
+ end;
+
+ function Netlib_GetBase64EncodedBufferSize(const cbDecoded: int): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := (cbDecoded * 4+11) div 12*4+1;
+ end;
+
+ function Netlib_Send(hConn: THandle; const buf: PChar; len: int; flags: int): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ nlb: TNETLIBBUFFER;
+ begin
+ nlb.buf := buf;
+ nlb.len := len;
+ nlb.flags := flags;
+ Result := PluginLink^.CallService(MS_NETLIB_SEND, wParam(hConn), lParam(@nlb));
+ end;
+
+ function Netlib_Recv(hConn: THandle; const buf: PChar; len: int; flags: int): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ nlb: TNETLIBBUFFER;
+ begin
+ nlb.buf := buf;
+ nlb.len := len;
+ nlb.flags := flags;
+ Result := PluginLink^.CallService(MS_NETLIB_RECV, wParam(hConn), lParam(@nlb));
+ end;
+
+ procedure Netlib_Log(hNetLib: THandle; const sz: PChar);
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ PluginLink^.CallService(MS_NETLIB_LOG, hNetLib, lParam(sz));
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_UTILS}
+
+ {$ifdef M_API_UNIT}
+
+ function WindowList_Add(hList: THandle; hWnd: HWND; hContact: THandle): int;
+
+ function WindowList_Remove(hList: THandle; hWnd: THandle): int;
+
+ function WindowList_Find(hList: THandle; hContact: THandle): int;
+
+ function WindowList_Broadcast(hList: THandle; message: int; wParam: WPARAM; lParam: LPARAM): int;
+
+ function Utils_SaveWindowPosition(hWnd: THandle; hContact: THandle; const szModule, szNamePrefix: PChar): int;
+
+ function Utils_RestoreWindowPosition(hWnd: THandle; hContact: THandle; Flags: int; const szModule, szNamePrefix: PChar): int;
+
+ {$else}
+
+ function WindowList_Add(hList: THandle; hWnd: hWnd; hContact: THandle): int;
+ var
+ wle: TWINDOWLISTENTRY;
+ begin
+ wle.hList := hList;
+ wle.hWnd := hWnd;
+ wle.hContact := hContact;
+ Result := PluginLink^.CallService(MS_UTILS_ADDTOWINDOWLIST, 0, lParam(@wle));
+ end;
+
+ function WindowList_Remove(hList: THandle; hWnd: THandle): int;
+ begin
+ Result := PluginLink^.CallService(MS_UTILS_REMOVEFROMWINDOWLIST, hList, hWnd);
+ end;
+
+ function WindowList_Find(hList: THandle; hContact: THandle): int;
+ begin
+ Result := PluginLink^.CallService(MS_UTILS_FINDWINDOWINLIST, hList, hContact);
+ end;
+
+ function WindowList_Broadcast(hList: THandle; message: int; wParam: WPARAM; lParam: LPARAM): int;
+ var
+ msg: TMSG;
+ begin
+ msg.message := message;
+ msg.wParam := wParam;
+ msg.lParam := lParam;
+ Result := PluginLink^.CallService(MS_UTILS_BROADCASTTOWINDOWLIST, hList, Integer(@Msg));
+ end;
+
+ function Utils_SaveWindowPosition(hWnd: THandle; hContact: THandle; const szModule, szNamePrefix: PChar): int;
+ var
+ swp: TSAVEWINDOWPOS;
+ begin
+ swp.hWnd := hWnd;
+ swp.hContact := hContact;
+ swp.szModule := szModule;
+ swp.szNamePrefix := szNamePrefix;
+ Result := PluginLink^.CallService(MS_UTILS_SAVEWINDOWPOSITION, 0, lParam(@swp));
+ end;
+
+ function Utils_RestoreWindowPosition(hWnd: THandle; hContact: THandle; Flags: int; const szModule, szNamePrefix: PChar): int;
+ var
+ swp: TSAVEWINDOWPOS;
+ begin
+ swp.hWnd := hWnd;
+ swp.hContact := hContact;
+ swp.szModule := szModule;
+ swp.szNamePrefix := szNamePrefix;
+ Result := PluginLink^.CallService(MS_UTILS_RESTOREWINDOWPOSITION, Flags, lParam(@swp));
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_LANGPACK}
+
+ {$ifdef M_API_UNIT}
+
+ function Translate(sz: PChar): PChar;
+
+ function TranslateString(sz: string): string;
+
+ function TranslateDialogDefault(hwndDlg: THandle): int;
+
+ {$else}
+
+ function Translate(sz: PChar): PChar;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ { the return value maybe NULL(0) -- it's upto the caller to know if the allocated
+ string has to be removed from the DLL heap, this has little to do with Miranda,
+ but if a dynamic string is passed and a return string is used -- the dynamic
+ string is lost -- be careful, lazy? use TranslateString (note it's slower) }
+ Result := PChar(PluginLink^.CallService(MS_LANGPACK_TRANSLATESTRING, 0, lParam(sz)));
+ end;
+
+ function TranslateString(sz: string): string;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := string(PChar( PluginLink^.CallService(MS_LANGPACK_TRANSLATESTRING, 0, lParam(sz))));
+ end;
+
+ function TranslateDialogDefault(hwndDlg: THandle): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ lptd: TLANGPACKTRANSLATEDIALOG;
+ begin
+ lptd.cbSize := sizeof(lptd);
+ lptd.flags := 0;
+ lptd.hwndDlg := hwndDlg;
+ lptd.ignoreControls := nil;
+ Result := PluginLink^.CallService(MS_LANGPACK_TRANSLATEDIALOG, 0, lParam(@lptd));
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_PROTOCOLS}
+ {$ifdef M_API_UNIT}
+
+ function CallContactService(hContact: THandle; const szProtoService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+
+ function CallProtoService(const szModule, szService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+
+ {$else}
+
+ function CallContactService(hContact: THandle; const szProtoService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ css: TCCSDATA;
+ begin
+ css.hContact := hContact;
+ css.szProtoService := szProtoService;
+ css.wParam := wParam;
+ css.lParam := lParam;
+ Result := PluginLink^.CallService(MS_PROTO_CALLCONTACTSERVICE, 0, Integer(@css));
+ end;
+
+ function CallProtoService(const szModule, szService: PChar; wParam: WPARAM; lParam: LPARAM): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ szStr: array[0..MAXMODULELABELLENGTH] of Char;
+ begin
+ strcpy(szStr, szModule);
+ strcat(szStr, szService);
+ Result := PluginLink^.CallService(szStr, wParam, lParam);
+ end;
+
+ {$endif}
+{$endif}
+
+{$ifdef M_PROTOMOD}
+ {$ifdef M_API_UNIT}
+
+ function ProtoBroadcastAck(const szModule: PChar; hContact: THandle; type_: int; result_: int; hProcess: THandle; lParam: LPARAM): int;
+
+ function CreateProtoServiceFunction(const szModule, szService: PChar; serviceProc: TMIRANDASERVICE): int;
+
+ {$else}
+
+ function ProtoBroadcastAck(const szModule: PChar; hContact: THandle; type_: int; result_: int; hProcess: THandle; lParam: LPARAM): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ ack: TACKDATA;
+ begin
+ ack.cbSize := sizeof(TACKDATA);
+ ack.szModule := szModule;
+ ack.hContact := hContact;
+ ack.type_ := type_;
+ ack.result_ := result_;
+ ack.hProcess := hProcess;
+ ack.lParam := lParam;
+ Result := PluginLink^.CallService(MS_PROTO_BROADCASTACK, 0, Integer(@ack));
+ end;
+
+ function CreateProtoServiceFunction(const szModule, szService: PChar; serviceProc: TMIRANDASERVICE): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ szStr: array[0..MAXMODULELABELLENGTH] of Char;
+ begin
+ strcpy(szStr, szModule);
+ strcat(szStr, szService);
+ Result := PluginLink^.CreateServiceFunction(szStr, @serviceProc);
+ end;
+
+ {$endif}
+
+{$endif}
+
+{$ifdef M_SKIN}
+
+ {$ifdef M_API_UNIT}
+
+ function LoadSkinnedIcon(id: int): THandle;
+
+ function LoadSkinnedProtoIcon(const szProto: PChar; status: int): THandle;
+
+ function SkinAddNewSound(const name, description, defaultFile: PChar): int;
+
+ function SkinPlaySound (const name: PChar): int;
+
+ {$else}
+
+ function LoadSkinnedIcon(id: int): THandle;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(MS_SKIN_LOADICON, id, 0);
+ end;
+
+ function LoadSkinnedProtoIcon(const szProto: PChar; status: int): THandle;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(MS_SKIN_LOADPROTOICON, wParam(szProto), status);
+ end;
+
+ function SkinAddNewSound(const name, description, defaultFile: PChar): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ ssd: TSKINSOUNDDESC;
+ begin
+ ssd.cbSize := sizeof(ssd);
+ ssd.pszName := name;
+ ssd.pszDescription := description;
+ ssd.pszDefaultFile := defaultFile;
+ Result := PluginLink^.CallService(MS_SKIN_ADDNEWSOUND, 0, lParam(@ssd));
+ end;
+
+ function SkinPlaySound (const name: PChar): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := PluginLink^.CallService(MS_SKIN_PLAYSOUND, 0, lParam(name));
+ end;
+
+ {$endif}
+
+{$endif}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_history.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_history.inc new file mode 100644 index 0000000000..af019ee255 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_history.inc @@ -0,0 +1,37 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_HISTORY}
+{$DEFINE M_HISTORY}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affects: Show's the history dialog box for a contact, see notes
+ Notes : HCONTACT can be NULL(0) to show system messages
+ }
+ MS_HISTORY_SHOWCONTACTHISTORY = 'History/ShowContactHistory';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_icq.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_icq.inc new file mode 100644 index 0000000000..a498513f01 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_icq.inc @@ -0,0 +1,191 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_ICQ}
+{$DEFINE M_ICQ}
+
+const
+
+ // extra database event type
+ ICQEVENTTYPE_WEBPAGER = 2003;
+
+ // extra flags for PSS_MESSAGE
+ PIMF_ROUTE_DEFAULT = 0;
+ PIMF_ROUTE_DIRECT = $10000;
+ PIMF_ROUTE_THRUSERVER = $20000;
+ PIMF_ROUTE_BESTWAY = $30000;
+ PIMF_ROUTE_MASK = $30000;
+
+ // for SMS
+
+ ICQACKTYPE_SMS = 1001;
+ ICQEVENTTYPE_SMS = 2001; // database event type
+
+ // for e-mail express
+
+ {
+ BLOB:
+ text: ASCIIZ usually in the form "Subject: %s\r\n%s"
+ from-name: ASCIIZ
+ from-e-mail: ASCIIZ
+ }
+
+ ICQEVENTTYPE_EMAILEXPRESS = 2002;
+
+ // for server side lists, used internally only
+
+ // hProcess=dwSequence, lParam=server's error code, 0 for success
+ ICQACKTYPE_SERVERCLIST = 1003;
+
+{$ifndef m_protosvc}
+ {$include m_protosvc.inc}
+{$endif}
+
+type
+
+ PICQSEARCHRESULT = ^TICQSEARCHRESULT;
+ TICQSEARCHRESULT = record
+ hdr: TPROTOSEARCHRESULT;
+ uin: DWORD;
+ auth: Byte;
+ end;
+
+ PICQDETAILSSEARCH = ^TICQDETAILSSEARCH;
+ TICQDETAILSSEARCH = record
+ nick: PChar;
+ firstName: PChar;
+ lastNamee: PChar;
+ end;
+
+const
+
+ {
+ wParam : 0
+ lParam : null terminated string containing e-mail to search
+ affects: Start a search for all ICQ users by e-mail -- see notes
+ returns: Returnss a handle to the search on success, NULL(0) on failure
+ notes : uses the same scheme as PSS_BASICSEARCH,
+ *DEPRECATED* in favour of PS_SEARCHBYEMAIL
+ }
+ MS_ICQ_SEARCHBYEMAIL = 'ICQ/SearchByEmail';
+
+ {
+ wParam : 0
+ lParam : POinter to a TICQDETAILSSEARCH structure
+ Affect : Start a search of all ICQ users by details, see notes
+ Returns: A handle to the search on success, NULL(0) on failure
+ Notes : Results are returned in the same scheme as in PSS_BASICSEARCH,
+ Not recommended, use PS_SEARCHBYNAME
+ }
+ MS_ICQ_SEARCHBYDETAILS = 'ICQ/SearchByDetails';
+
+ {
+ wParam : Pointer to a null terminated string containing phone number
+ lParam : Pointer to a null terminated string containing the message
+ Affect : Send an SMS via the ICQ network, See notes
+ Returns: Handle to the send on success, NULL(0) on failure
+ Notes : the phone number should be the full number with internation code
+ and prefixed by + e.g. +44<numba>
+ }
+ MS_ICQ_SENDSMS = 'ICQ/SendSMS';
+
+ {
+ wParam : level
+ lParam : null terminated string containing logging message
+ Affect : a logging message was sent from ICQLib
+ }
+ ME_ICQ_LOG = 'ICQ/Log';
+
+{$ENDIF}
+
+ {$ifdef __}
+//Changing user info:
+//See documentation of PS_CHANGEINFO
+//The changing user info stuff built into the protocol is purposely extremely
+//thin, to the extent that your data is passed as-is to the server without
+//verification. Don't mess up.
+//Everything is byte-aligned
+//WORD: 2 bytes, little-endian (that's x86 order)
+//DWORD: 4 bytes, little-endian
+//LNTS: a WORD containing the length of the string, followed by the string
+// itself. No zero terminator.
+#define ICQCHANGEINFO_MAIN 0xEA03
+/* pInfoData points to:
+ WORD datalen
+ LNTS nick
+ LNTS first
+ LNTS last
+ LNTS email
+ LNTS city
+ LNTS state
+ LNTS phone
+ LNTS fax
+ LNTS street
+ LNTS cellular (if SMS-able string contains an ending ' SMS')
+ LNTS zip
+ WORD country
+ BYTE gmt
+ BYTE unknown, usually 0
+*/
+#define ICQCHANGEINFO_MORE 0xFD03
+/* pInfoData points to:
+ WORD datalen
+ BYTE age
+ BYTE 0
+ BYTE sex
+ LNTS homepage
+ WORD birth-year
+ BYTE birth-month
+ BYTE birth-day
+ BYTE lang1
+ BYTE lang2
+ BYTE lang3
+*/
+#define ICQCHANGEINFO_ABOUT 0x0604
+/* pInfoData points to:
+ WORD datalen
+ LNTS about
+*/
+#define ICQCHANGEINFO_WORK 0xF303
+/* pInfoData points to:
+ WORD datalen
+ LNTS city
+ LNTS state
+ DWORD 0
+ LNTS street
+ LNTS zip
+ WORD country
+ LNTS company-name
+ LNTS company-dept
+ LNTS company-position
+ WORD 0
+ LNTS company-web
+*/
+#define ICQCHANGEINFO_PASSWORD 0x2E04
+/* pInfoData points to:
+ WORD datalen
+ LNTS newpassword
+*/
+ {$endif}
+
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_ignore.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_ignore.inc new file mode 100644 index 0000000000..4dd83c4cee --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_ignore.inc @@ -0,0 +1,74 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_IGNORE}
+{$DEFINE M_IGNORE}
+
+ { this module only provides UI and storage for blocking only, protocol modules
+ are responsible for implementing the block }
+
+const
+
+ IGNOREEVENT_ALL = LPARAM(-1);
+ IGNOREEVENT_MESSAGE = 1;
+ IGNOREEVENT_URL = 2;
+ IGNOREEVENT_FILE = 3;
+ IGNOREEVENT_USERONLINE = 4;
+ IGNOREEVENT_AUTHORIZATION=5;
+ IGNOREEVENT_YOUWEREADDED=6; // 0.3.3a+
+
+ {
+ wParam : HCONTACT
+ lParam : IGNOREEVENT_*
+ Affects: Determines if a message type to a contact should be ignored, see notes
+ Returns: 0 if the message type MUST be shown [non zero] if it MUST be ignored
+ Notes : HCONTACT can be NULL(0) to see what to do with a contact
+ that isn't on the list (or is unknown in some way)
+ don't use the IGNOREEVENT_ALL type!
+ Version: v0.1.0.1+
+ }
+ MS_IGNORE_ISIGNORED = 'Ignore/IsIgnored';
+
+ {
+ wParam : HCONTACT
+ lParam : IGNOREEVENT_* constant
+ Affects: Ignore future messages from a contact, see notes
+ Returns: 0 on success, [nonzero] on failure
+ Notes : wParam: NULL(0) can be used to see if an unknown contact should be ignored
+ or not - you can't SET unknown contact's ignore types, this is to stop
+ a plugin allowing certain functions (I guess)
+ Version: v0.1.0.1+
+ }
+ MS_IGNORE_IGNORE = 'Ignore/Ignore';
+
+ {
+ wParam : HCONTACT
+ lParam : IGNOREEVENT_*
+ Affects: Receive future messages from a contact -- of the given type, see notes
+ Returns: 0 on success, non zero on failure
+ Notes : Use NULL(0) for HCONTACT to retrieve the setting for an unknown contact
+ Version: v0.1.0.1+
+ }
+ MS_IGNORE_UNIGNORE = 'Ignore/Unignore';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_langpack.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_langpack.inc new file mode 100644 index 0000000000..2c1f99478c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_langpack.inc @@ -0,0 +1,82 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_LANGPACK}
+{$DEFINE M_LANGPACK}
+
+const
+
+ {
+ wParam : 0
+ lParam : pointer to a null terminated string
+ Affects: Returns a pointer to a localised string, if there is no known
+ translation it will return lParam, the return value does *not*
+ have to be freed in anyway (if successful) -- see notes
+ Returns: a pointer to a null terminated string
+ Notes : No check is done to see if Miranda has the required version
+ Version: v0.1.1.0+
+ }
+ MS_LANGPACK_TRANSLATESTRING = 'LangPack/TranslateString';
+
+ {
+ wParam : 0
+ lParam : Pointer to a LANGPACKTRANSLATEDIALOG initialised structure, see notes
+ Affects: Translates a dialog into the user's local language
+ Returns: 0 on successs [non zero] on failure
+ Notes : this service only knows about the following window classes/elements:
+ Window titles, STATIC, EDIT, Hyperlink, BUTTON.
+ Version: v0.1.1.0+
+ }
+
+type
+
+ PLANGPACKTRANSLATEDIALOG = ^TLANGPACKTRANSLATEDIALOG;
+ TLANGPACKTRANSLATEDIALOG = record
+ cbSize: int;
+ flags: DWORD;
+ hwndDlg: THandle;
+ ignoreControls: ^Integer; // pointer to an array of integers? mebbe?
+ end;
+
+const
+
+ { translate all edit controls, by default non-read-only edit controls are not }
+ LPTDF_NOIGNOREEDIT = 1;
+ { don't translate the title of the dialog }
+ LPTDF_NOTITLE = 2;
+
+ MS_LANGPACK_TRANSLATEDIALOG = 'LangPack/TranslateDialog';
+
+ {
+ wParam : HMENU handle (WinAPI handle to a menu)
+ lParam : 0
+ Affects: Translates a menu into the user's local language -- see notes
+ Returns: 0 on success [non zero] on failure
+ Notes : This doesn't work with owner draw menus that store their
+ captions in a structure known by the owner -- something to be aware of ;)
+ version: v0.1.1.0+
+ }
+ MS_LANGPACK_TRANSLATEMENU = 'LangPack/TranslateMenu';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_message.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_message.inc new file mode 100644 index 0000000000..dec113bb53 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_message.inc @@ -0,0 +1,57 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_MESSAGE}
+{$DEFINE M_MESSAGE}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : Pointer to a null terminated string
+ Affects: brings up the send message dialog for a contact, see notes
+ Returns: 0 on success, non zero on failure
+ Notes : returns immediately, just after the send dialog is shown,
+ the lParam is entered into the editbox of the window,
+ but it's not sent.
+ Version: v0.1.2.0+ only supports a string, prior NULL(0) is expected
+ this service was defined as 'SRMsg/LaunchMessageWindow'
+ use both if compatibility use both, the correct one will work,
+ but don't rely on the message to be displayed
+
+ }
+ MS_MSG_SENDMESSAGE = 'SRMsg/SendCommand';
+ MS_MSG_SENDMESSAGE_OLD = 'SRMsg/LaunchMessageWindow';
+
+ {
+ wParam : 0
+ lParam : Pointer to a null termed string
+ Affects: displays the send message dialog with the 'multiple' option open
+ and no contacts selected
+ Returns: Returns 0 on success, nonzero on failure
+ Version: only present after v0.1.2.1+
+ }
+ MS_MSG_FORWARDMESSAGE = 'SRMsg/ForwardMessage';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_netlib.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_netlib.inc new file mode 100644 index 0000000000..8c5f37ef9c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_netlib.inc @@ -0,0 +1,713 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_NETLIB}
+{$DEFINE M_NETLIB}
+
+{>>/
+
+ NetLib :
+
+ Instead of you writing all the code for working with sockets and supporting
+ app level protocols such as SOCKS5, it's all done for you.
+
+ NetLib takes care of all that and you can even register a special abstract
+ nexus, e.g. ICQ direct, the user can configure all this from the options dialog
+ and you don't have to bother with any of it.
+
+ NetLib wraps up any Winsock calls but you can still get the socket handle
+ from your netlib handle and do stuff.
+
+ It gives all modules an abstract way of dealing with transport -- mainly sockets
+ and proxies, Now the but..
+
+ It's new (mmmm) thus unsupported by any older version of Miranda, and if you
+ want to be lazy and not write any "wrapper" mini netlib then you'll have
+ the kudos of "only works with nightly build version of Miranda" :)
+
+/<<}
+
+ {$ifndef M_SYSTEM}
+ {$include m_system.inc}
+ {$endif}
+
+const
+
+ // for TNETLIBUSER.flags
+
+ { bind incoming ports }
+ NUF_INCOMING = $01;
+ { makes outgoing plain connections }
+ NUF_OUTGOING = $02;
+ { can use HTTP gateway for plain sockets. ???HttpGateway* are valid,
+ enables the HTTP proxy option, displayed in options }
+ NUF_HTTPGATEWAY = $04;
+ { don't show this as an entry for custom settings to be defined for,
+ TNETLIB.szDescriptiveName is ignored }
+ NUF_NOOPTIONS = $08;
+ { some connections are made for HTTP communication,
+ enables the HTTP proxy option, displayed in options }
+ NUF_HTTPCONNS = $10;
+ { Disables the HTTPS proxy option in options, Use this if all communication
+ is HTTP }
+ NUF_NOHTTPSOPTION = $20;
+
+ // for TNETLIBUSERSETTINGS.proxyType
+
+ { SOCKS4 -- No DNS or multi addressing mode (proxy side) -- optional username can
+ be given, no password }
+ PROXYTYPE_SOCKS4 = 1;
+ { SOCKS5 -- DNS names can be given as addresses to connect to, optional
+ plain text username/password scheme (which may cause failure due to denied access)
+ IP address maybe returned for DNS addresses -- thus server side DNS }
+ PROXYTYPE_SOCKS5 = 2;
+ PROXYTYPE_HTTP = 3;
+ PROXYTYPE_HTTPS = 4;
+
+ // for TNETLIBOPENCONNECTION.flags
+
+ { this connection will be useed for HTTP communications,
+ if configured for an HTTP(S) proxy the connection is opened as if there
+ was no proxy }
+
+ NLOCF_HTTP = $0001;
+
+ // for TNETLIBHTTPPROXYINFO.flags
+
+ { append sequence numbers to GET requests }
+ NLHPIF_USEGETSEQUENCE = $0001;
+ { append sequence numbers to POST requests }
+ NLHPIF_USEPOSTSEQUENCE = $0002;
+ { GET and POST use the same sequence }
+ NLHPIF_GETPOSTSAMESEQUENCE = $0004;
+
+ // for TNETLIBHTTPREQUEST.flags, .requestType
+
+ { used by MS_NETLIB_RECVHTTPHEADERS returned structure }
+
+ REQUEST_RESPONSE = 0;
+ REQUEST_GET = 1;
+ REQUEST_POST = 2;
+ REQUEST_CONNECT = 3;
+
+ { auto generate a 'host' header from .szUrl }
+ NLHRF_GENERATEHOST = $00000001;
+ { remove any host and/or protocol portion of szUrl before sending it }
+ NLHRF_REMOVEHOST = $00000002;
+ { removes host and/or protocol from szUrl unless the connection was
+ opened through an HTTP or HTTPS proxy. }
+ NLHRF_SMARTREMOVEHOST = $00000004;
+ { if the connection was opened through an HTTP or HTTPS proxy then
+ send a Proxy-Authorization header if required. }
+ NLHRF_SMARTAUTHHEADER = $00000008;
+ { never dump this to the log }
+ NLHRF_NODUMP = $00010000;
+ { don't dump http headers (only useful for POSTs and MS_NETLIB_HTTPTRANSACTION }
+ NLHRF_NODUMPHEADERS = $00020000;
+ { this transaction is a proxy communication. For dump filtering only. }
+ NLHRF_DUMPPROXY = $00040000;
+ { dump posted and reply data as text. Headers are always dumped as text. }
+ NLHRF_DUMPASTEXT = $00080000;
+
+ // for TNETLIBBUFFER.flags
+
+ { don't wrap outgoing packet using TNETLIBUSER.pfnHttpGatewayWrapSend }
+ MSG_NOHTTPGATEWAYWRAP = $010000;
+ { don't dump this packet to the log }
+ MSG_NODUMP = $020000;
+ { this iss proxy communication, for dump filtering only }
+ MSG_DUMPPROXY = $040000;
+ { don't dump as hex, it's text }
+ MSG_DUMPASTEXT = $080000;
+ { send as raw, bybpass HTTP proxy stuff }
+ MSG_RAW = $100000;
+
+
+ // all record types structures are declared in their own block because the C header
+ // file used forward declaration (to get typed parameters for certain function pointers)
+ // This sort of define-type-pointer-before-type can only be done in the same type block
+ // in D2 (don't know about later versions)
+
+type
+
+ { forward typed pointers to records }
+
+ PNETLIBOPENCONNECTION = ^TNETLIBOPENCONNECTION;
+ PNETLIBHTTPREQUEST = ^TNETLIBHTTPREQUEST;
+
+ { This function pointer is to the CRT realloc() used by Miranda -- it allows reallocation of memory passed
+ to us (not that we could EVER share the same CRT) but to allow DLLs in general to reallocate memory }
+ TNetlibRealloc = function(Mem: Pointer; size_t: int): Pointer; cdecl;
+ TNetlibHTTPGatewayInitProc = function(hConn: THandle; nloc: PNETLIBOPENCONNECTION; nlhr: PNETLIBHTTPREQUEST): int; cdecl;
+ TNetlibHTTPGatewayBeginProc = function(hConn: THandle; nloc: PNETLIBOPENCONNECTION): int; cdecl;
+ TNetlibHTTPGatewayWrapSendProc = function(hConn: THandle; buf: PByte; len: int; flags: int; pfnNetLibSend: TMIRANDASERVICE): int; cdecl;
+ TNetlibHTTPGatewayUnwrapRecvProc = function(nlhr: PNETLIBHTTPREQUEST; buf: PByte; len: int; outBufLen: pInt; NetlibRealloc: TNetlibRealloc): PByte; cdecl;
+
+ PNETLIBUSER = ^TNETLIBUSER;
+ TNETLIBUSER = record
+ cbSize: int;
+ { used for DB settings and log, 'NL' stuff }
+ szSettingsModule: PChar;
+ { shows a descriptive name for which different proxy settings can be defined }
+ szDescriptiveName: PChar;
+ { see NUF_* constants above }
+ flags: DWORD;
+ szHttpGatewayHello: PChar;
+ { can be NULL(0) to send no User-Agent: also used by HTTPS proxies }
+ szHttpGatewayUserAgent: PChar;
+ pfnHttpGatewayInit: TNetlibHTTPGatewayInitProc;
+ { can be NULL(0) if no begin is required }
+ pfnHttpGatewayBegin: TNetlibHTTPGatewayBeginProc;
+ { can be NULL(0) if no wrapping is required }
+ pfnHttpGatewayWrapSend: TNetlibHTTPGatewayWrapSendProc;
+ { can be NULL(0) " " }
+ pfnHttpGatewayUnwrapRecv: TNetlibHTTPGatewayUnwrapRecvProc;
+ { only if NUF_INCOMING, will be used for validation of user input }
+ minIncomingPorts: int;
+ end;
+
+ PNETLIBUSERSETTINGS = ^TNETLIBUSERSETTINGS;
+ TNETLIBUSERSETTINGS = record
+ { filled before calling }
+ cbSize: int;
+ { 1 or 0 }
+ useProxy: int;
+ { PROXYTYPE_* constant, see above }
+ proxyType: int;
+ { can be NULL(0) }
+ szProxyServer: PChar;
+ { in host byte order }
+ wProxyPort: int;
+ { 1 or 0, always 0 for SOCKS4 (doesn't have auth) }
+ useProxyAuth: int;
+ { can be NULL(0), always used by SOCKS4 }
+ szProxyAuthUser: PChar;
+ { can be NULL(0) }
+ szProxyAuthPassword: PChar;
+ { 1 or 0, only used by HTTP, HTTPS }
+ useProxyAuthNtlm: int;
+ { 1 or 0 }
+ dnsThroughProxy: int;
+ { 1 or 0 }
+ specifyIncomingPorts: int;
+ { can be NULL(0), form '1024-1050,1060-1070,2000' }
+ szIncomingPorts: PChar;
+ end;
+
+ TNetlibNewConnectionProc = procedure(hNewConnection: THandle; dwRemoveIP: DWORD); cdecl;
+
+ PNETLIBBIND = ^TNETLIBBIND;
+ TNETLIBBIND = record
+ cbSize: int;
+ { function to call when there's a new connection, dwRemoteIP is in host byte
+ order -- the handle is to the new connection }
+ pfnNewConnection: TNetlibNewConnectionProc;
+ { set on return, host byte order }
+ dwInternalIP: DWORD;
+ { set on return, host byte order }
+ wPort: WORD;
+ end;
+
+ { Pointered type is above }
+ TNETLIBOPENCONNECTION = record
+ cbSize: int;
+ szHost: PChar; // can be an IP in string form
+ wPort: Word;
+ flags: DWORD; // see NLOCF_* flags
+ end;
+
+ PNETLIBHTTPPROXYINFO = ^TNETLIBHTTPPROXYINFO;
+ TNETLIBHTTPPROXYINFO = record
+ cbSize: int;
+ { see NLHPIF_* above }
+ flags: DWORD;
+ szHttpPostUrl: PChar;
+ szHttpGetUrl: PChar;
+ firstGetSequence: int;
+ firstPostSequence: int;
+ end;
+
+ PNETLIBBASE64 = ^TNETLIBBASE64;
+ TNETLIBBASE64 = record
+ pszEncoded: PChar;
+ cchEncoded: int;
+ pbDecoded: PByte;
+ cbDecoded: int;
+ end;
+
+ PNETLIBHTTPHEADER = ^TNETLIBHTTPHEADER;
+ TNETLIBHTTPHEADER = record
+ szName: PChar;
+ szValue: PChar;
+ end;
+
+ { PNETLIBHTTPREQUEST = ^TNETLIBHTTPREQUEST, defined above because this is
+ forward referenced from there }
+ TNETLIBHTTPREQUEST = record
+ cbSize: int;
+ requestType: int; // REQUEST_* constant
+ flags: DWORD;
+ szUrl: PChar;
+ { doesn't contain Content-Length, it'll be added automatically }
+ headers: PNETLIBHTTPHEADER; // pointer to an array of em?
+ headersCount: int; // yes they do
+ pData: PChar; // data to be sent on POST request
+ dataLength: int; // must be 0 for REQUEST_GET/REQUEST_CONNECT
+ resultCode: int;
+ szResultDescr: PChar;
+ end;
+
+ PNETLIBBUFFER = ^TNETLIBBUFFER;
+ TNETLIBBUFFER = record
+ buf: PChar;
+ len: int;
+ { see MSG_* constants above }
+ flags: int;
+ end;
+
+ PNETLIBSELECT = ^TNETLIBSELECT;
+ TNETLIBSELECT = record
+ cbSize: int;
+ dwTimeout: DWORD; // in milliseconds, INFINITE is acceptable
+ hReadConns: array[0..64+1] of THandle;
+ hWriteConns: array[0..64+1] of THandle;
+ hExceptConns: array[0..64+1] of THandle;
+ end;
+
+ PNETLIBPACKETRECVER = ^TNETLIBPACKETRECVER;
+ TNETLIBPACKETRECVER = record
+ cbSize: int;
+ { infinite is allowed -- initialise before use }
+ dwTimeout: DWORD;
+ { this many bytes are removed from the start of the buffer,
+ set to 0 on return -- initialise before use }
+ bytesUsed: int;
+ { equal the returnd value by service, unless the return value is 0 (connection closed) }
+ bytesAvailable: int;
+ { same as the parameter given to MS_NETLIB_CREATEPACKETRECVER: wParam }
+ bufferSize: int;
+ { contains the read data }
+ buffer: PByte;
+ end;
+
+const
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised TNETLIBUSER structure
+ Affects: Initialises the netlib for a set of connections, see notes
+ Returns: Returns a handle for future netlib calls, NULL on failure.
+ Notes : Netlib is loaded AFTER all plugins, thus a call to this service
+ in Load() will fail, hook ME_SYSTEM_MODULESLOADED and call it
+ from there.
+ -
+ Netlib will save settings under .szSettings module, all settings
+ (being?) begin with 'NL'.
+ -
+ Defacto settings are the same as <All connections> combobox entry option
+ as seen in Miranda->Options->Network
+ Version: v0.1.2.2+
+ Errors : ERROR_INVALID_PARAMETER, ERROR_OUTOFMEMORY, ERROR_DUP_NAME
+ }
+ MS_NETLIB_REGISTERUSER = 'Netlib/RegisterUser';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to a initalised TNETLIBUSERSETTINGS structure
+ Affects: Gets the user configured settings for a Netlib user, see notes
+ Returns: [non zero] on SUCCESS, NULL(0) on failure
+ Notes : .cbSize must be filled with sizeof() before calling --
+ the returned null terminated strings (in the structure) are valid
+ as long as HANDLE remains open or proxy options are changed
+ again, do not rely on them being around forever.
+ Version: v0.1.2.2+
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_GETUSERSETTINGS = 'Netlib/GetUserSettings';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to a initalised NETLIBUSERSETTINGS structure
+ Affect : Changes the configurable settings for a Netlib user -- see notes
+ Returns: [non zero] on success, NULL(0) on failure
+ Notes : This service is only really useful for people that specify NUF_NOOPTIONS
+ when registering and want to create their own options.
+ Settings will be stored even if the option to enable it, is it not enabled,
+ e.g. useProxyAuth is 0, szProxyAuthPassword will still be saved
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_SETUSERSETTINGS = 'Netlib/SetUserSettings';
+
+ {
+ wParam : HANDLE / SOCKET
+ lParam : 0
+ Affects: Closes a handle, see notes
+ Returns: Returns [non zero] on success, NULL(0) on failure
+ Notes : All netlib handles should be closed once they're finished with,
+ If a SOCKET type is passed instead of netlib handle type, it is closed
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_CLOSEHANDLE = 'Netlib/CloseHandle';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to a initialised TNETLIBBIND
+ Affects: Open a port and wait for connections on it -- see notes
+ Returns: Returns a handle on success, NULL(0) on failure
+ Notes : this function does the equivalent of socket(), bind(), getsockname(),
+ listen(), accept() -- internally this function creates a new thread
+ which waits around in accept() for new connections.
+ When one is received, TNETLIBBIND.pfnNewConnection is called,
+ from the context of the NEW thread and then it
+ returns to waiting for connections.
+ -
+ Close the returned handle to end the thread and close the port.
+ -
+ Errors : ERROR_INVALID_PARAMETER, any returned by socket(), bind(), listen()
+ getsockname()
+ }
+ MS_NETLIB_BINDPORT = 'Netlib/BindPort';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to an initalised TNETLIBOPENCONNECTION structure
+ Affects: Opens a connection -- see notes
+ Returns: Returns a Handle to a new connection on success, NULL(0) on failure
+ Notes : internally this service is the equivalent of socket(), gethostbyname(),
+ connect()
+ -
+ If NLOCF_HTTP is set and HANDLE is configured for HTTP(S) proxy
+ then this function will connect() to that proxy server ONLY,
+ without performing any initialisation conversation.
+ -
+ If HANDLE is configured for an HTTP proxy and does not support
+ HTTP gateways and you try to open a connection without NLOCF_HTTP
+ then this service will first attempt to open an HTTPS connection,
+ if that fails, it will try a direct connection, if *that* fails
+ then it will return failure with the error
+ from connect() during the connection attempt
+ Errors : ERROR_INVALID_PARAMETER, any returned by socket(), gethostbyname(),
+ connect(), MS_NETLIB_SEND, MS_NETLIB_RECV, select()
+ -
+ ERROR_TIMEOUT (during proxy communication)
+ ERROR_BAD_FORMAT (very invalid proxy reply)
+ ERROR_ACCESS_DENIED (by proxy)
+ ERROR_CONNECTION_UNAVAIL (socks proxy can't connect to identd)
+ ERROR_INVALID_ACCESS (proxy refused identd auth)
+ ERROR_INVALID_DATA (proxy returned invalid code)
+ ERROR_INVALID_ID_AUTHORITY (proxy requires use of auth method that's not supported)
+ ERROR_GEN_FAILURE (socks5/https general failure)
+ ERROR_CALL_NOT_IMPLEMENTED (socks5 command not supported)
+ ERROR_INVALID_ADDRESS (socks5 address type not supported)
+ -
+ HTTP: anything from TNETLIBUSER.pfnHttpGatewayInit, TNETLIBUSER.pfnHttpGatewayBegin,
+ MS_NETLIB_SENDHTTPREQUEST or MS_NETLIB_RECVHTTPHEADERS
+ }
+ MS_NETLIB_OPENCONNECTION = 'Netlib/OpenConnection';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to an initialised NETLIBHTTPPROXYINFO structure
+ Affects: Sets the required information for an HTTP proxy connection -- see notes
+ Returns: [non zero] on success, NULL(0) on failure
+ Notes : This service is designed to be called from
+ within TNETLIBUSER.pfnHttpGatewayInit (see notes in C header under
+ MS_NETLIB_REGISTERUSER)
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_SETHTTPPROXYINFO = 'Netlib/SetHttpProxyInfo';
+
+ {
+ wParam : HANDLE
+ lParam : 0
+ Affects: Get's the SOCKET associated with a handle -- see notes
+ Returns: the SOCKET on success, INVALID_SOCKET on failure
+ Notes : The Netlib handle passed to this service should only be passed
+ if they were returned with MS_NETLIB_OPENCONNECTION or MS_NETLIB_BINDPORT
+ -
+ Be careful how you use this socket because you might be connected via an
+ HTTP proxy, in which case calling send/recv() will break things
+ -
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_GETSOCKET = 'Netlib/GetSocket';
+
+ {
+ wParam : 0
+ lParam : Pointer to a null terminated string
+ Affects: URL-encodes a string for x-www-form-urlencoded (and other uses) -- see notes
+ Returns: A pointer to a null terminated string, NULL(0) on failure
+ Notes : The returned string must be freed after it's no longer needed,
+ to do this Miranda's process heap must be used (under the WINAPI), e.g.
+ HeapFree(GetProcessHeap(), 0, the_returned_string)
+ Errors : ERROR_INVALID_PARAMETER, ERROR_OUTOFMEMORY
+ }
+ MS_NETLIB_URLENCODE = 'Netlib/UrlEncode';
+
+ {
+ wParam : 0
+ lParam : Pointer to a TNETLIBBASE64 initialised structure
+ Affects: Decodes a Base64 null terminated string, see notes
+ Returns: [non zero] on success, NULL(0) on failure
+ Notes : TNETLIBBASE64.pszEncoded and cchEncoded must contain a pointer to
+ a buffer to use as input, and it's length, the length
+ should not include space taken for null termination --
+ -
+ Output is placed in ..pbDecoded and ..cbDecoded for buffer and
+ length of buffer -- the maxiumum output for a given input can
+ be worked out with Netlib_GetBase64DecodedBufferSize() function
+ see below.
+ -
+ For more information on Base64 see rfc-1421.
+ Errors : ERROR_INVALID_PARAMETER, ERROR_INVALID_DATA, ERROR_BUFFER_OVERFLOW
+ }
+ MS_NETLIB_BASE64DECODE = 'Netlib/Base64Decode';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initialised TNETLIBBASE64 structure
+ Affect : Base64 encode a string, see notes
+ Returns: [non zero] on success, NULL(0) on failure
+ Notes : TNETLIBBASE64.pbDecode and TNETLIBBASE64.cbDecoded contain
+ the input buffer and it's length --
+ TNETLIBBASE64.pszEncoded and TNETLIBBASE64.cchEncoded contain the
+ buffer in which to put the output and it's length.
+ -
+ The maximum output size for a given input can be worked
+ out with the function Netlib_GetBase64EncodedBufferSize() below
+ .pszEncoded is null terminated, on return TNETLIBBASE64.cchEncoded
+ is set to the actual length excluding 0.
+ Errors : ERROR_INVALID_PARAMETER, ERROR_BUFFER_OVERFLOW
+ }
+ MS_NETLIB_BASE64ENCODE = 'Netlib/Base64Encode';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to a initialised TNETLIBHTTPREQUEST structure
+ Affect : Send an HTTP request over a connection, see notes
+ Returns: The number of bytes on success, SOCKET_ERROR on failure
+ Notes : HANDLE must of been returned by MS_NETLIB_OPENCONNECTION,,
+ If you use NLHRF_SMARTAUTHHEADER and NTLM auth is in use then
+ full NTLM auth transcation occurs, comprising sending the
+ domain, getting the challenge, sending the response.
+ NETLIBHTTPREQUEST.resultCode and NETLIBHTTPREQUEST.szResultDescr are
+ ignored by this service.
+ Errors : ERROR_INVALID_PARAMETER, MS_NETLIB_SEND (return codes)
+ }
+ MS_NETLIB_SENDHTTPREQUEST = 'Netlib/SendHttpRequest';
+
+ {
+ wParam : HANDLE
+ lParam : 0
+ Affect : Receive HTTP headers, see notes
+ Returns: A pointer to a TNETLIBHTTPREQUEST structure on success, NULL(0) on failure
+ Notes : The returned pointer must be freed after it's done with
+ use MS_NETLIB_FREEHTTPREQUESTSTRUCT.
+ -
+ HANDLE must be returned by MS_NETLIB_OPENCONNECTION
+ -
+ Return^.pData=NIL and Return^.dataLength=0 always
+ -
+ The returned data should be retrieved using MS_NETLIB_RECV once
+ the headers have been parsed.
+ If headers haven't finished within 60 seconds the function returns
+ NULL(0) and ERROR_TIMEOUT
+ Errors : ERROR_INVALID_PARAMETER, any MS_NETLIB_RECV or select()
+ ERROR_HANDLE_EOF (connection closed bfore headers complete)
+ ERROR_TIMEOUT (headers still not complete after 60 seconds)
+ ERROR_BAD_FORMAT (invalid character or line ending in headers, or first line is blank)
+ ERROR_BUFFER_OVERFLOW (each header line must be less than 4096 chars long)
+ ERROR_INVALID_DATA (first header line is malformed ("http/[01].[0-9] [0-9]+ .*", or no colon in subsequent line)
+
+ }
+ MS_NETLIB_RECVHTTPHEADERS = 'Netlib/RecvHttpHeaders';
+
+ {
+ wParam : 0
+ lParam : Pointer returned by MS_NETLIB_RECVHTTPHEADERS to free
+ Affect : Free the memory used by a TNETLIBHTTPREQUEST structure, see notes
+ Returns: [non zero] on success, NULL(0) on failure
+ Notes : This service should only be used with memory pointers returned
+ by either MS_NETLIB_RECVHTTPHEADERS or MS_NETLIB_HTTPTRANSACTION!.
+ Errors : ERROR_INVALID_PARAMETER
+
+ }
+ MS_NETLIB_FREEHTTPREQUESTSTRUCT = 'Netlib/FreeHttpRequestStruct';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to a TNETLIBHTTPREQUEST structure
+ Affect : Carry out an entire HTTP transaction, see notes
+ Returns: another pointer to a TNETLIBHTTPREQUEST structure or NULL(0)
+ on failure
+ Notes : The returned pointer must be freed at some point
+ with MS_NETLIB_FREEHTTPREQUESTSTRUCT,
+ -
+ TNETLIBHTTPREQUEST.szUrl should have a full HTTP URL, if it
+ does not start with http://, that will be assumed, but do not
+ take this assumption to stay assumed (heh..) in the future
+ -
+ this service equivalent of open(), sendhttp(), getheaders()
+ netlib_recv(), netlib_closehandle()
+ -
+ TNETLIBHTTPREQUEST.headers will be added to with the following
+ headers if they're not already present :
+ "Host" (even if it is requested in .flags)
+ "User-Agent" (in form : 'Miranda/d.d.d.d <(status of release)>')
+ "Content-Length" (for POSTs only, set to TNETLIBHTTPREQUEST.dataLength)
+
+ If you don't want to send any of these headers --
+ set TNETLIBHTTPREQUEST.headers to NULL(0)
+ -
+ In the returned pointer, pData[dataLen] is always 0 for 'safety'
+ also : headers, headersCount, pData, dataLength, resultCode and
+ szResultDescr are all valid
+ -
+ Also take care not to assume that a returned pointer means that
+ at the HTTP level it all worked out -- refer to the resultCode for
+ 2xx before doing anything else
+ -
+ Errors : ERROR_INVALID_PARAMETER, ERROR_OUTOFMEMORY
+ Errors returned by the aforementioned internally used functions
+ }
+ MS_NETLIB_HTTPTRANSACTION = 'Netlib/HttpTransaction';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to an initialised TNETLIBBUFFER structure
+ Affect : Send data over an open connection see notes
+ Returns: The number of bytes sent on success, SOCKET_ERROR on failure
+ Notes : see Netlib_Send() helper function
+ Errors : ERROR_INVALID_PARAMETER,
+ anything from socket(), connect()
+ send(), TNETLIBUSER.pfnHttpGatewayWrapSend(),
+ (HTTP proxy): ERROR_GEN_FAILURE (http result code wasn't 2xx)
+ MS_NETLIB_SENDHTTPREQUEST, MS_NETLIB_RECVHTTPHEADERS
+ }
+ MS_NETLIB_SEND = 'Netlib/Send';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to an initialised TNETLIBBUFFER structure
+ Affect : Receive data over a connection, see notes
+ Returns: The number of bytes read on success, SOCKET_ERROR on failure
+ Notes :
+ This service uses some of the same flags as MS_NETLIB_SEND :
+ MSG_PEEK,
+ MSG_NODUMP,
+ MSG_DUMPPROXY,
+ MSG_NOHTTPGATEWAYWRAP,
+ MSG_DUMPASTEXT,
+ MSG_RAW
+ -
+ On using MSG_NOHTTPGATEWAYWRAP: Because packets through an HTTP proxy are
+ batched and cached and stuff, using this flag is not a guarantee that it
+ will be obeyed, and if it is it may even be propogated to future calls
+ even if you don't specify it then. Because of this, the flag should be
+ considered an all-or-nothing thing: either use it for the entire duration
+ of a connection, or not at all.
+ Errors : ERROR_INVALID_PARAMETER, anything from recv()
+ (HTTP proxy):
+ ERROR_GEN_FAILURE (http result code wasn't 2xx)
+ ERROR_INVALID_DATA (no Content-Length header in reply)
+ ERROR_NOT_ENOUGH_MEMORY (Content-Length very large)
+ ERROR_HANDLE_EOF (connection closed before Content-Length bytes recved)
+ anything from select(),
+ MS_NETLIB_RECVHTTPHEADERS, nlu.pfnHttpGatewayUnwrapRecv, socket(),
+ connect(), MS_NETLIB_SENDHTTPREQUEST
+
+ }
+ MS_NETLIB_RECV = 'Netlib/Recv';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initialised TNETLIBSELECT structure
+ Affect : Determine the status of one or more connections, see notes
+ Returns: The numbe of ready connections, SOCKET_ERROR on failure
+ Notes : All handles passed to this service must have been returned
+ either by MS_NETLIB_OPENCONNECTION or MS_NETLIB_BINDPORT,
+ the last handle in each list must be followed by either NULL
+ or INVALID_HANDLE_VALUE.
+ Errors : ERROR_INVALID_HANDLE, ERROR_INVALID_DATA, anything from select()
+ }
+ MS_NETLIB_SELECT = 'Netlib/Select';
+
+ {
+ wParam : HANDLE
+ lParam : maxPacketSize
+ Affect : Create a packet receiver, see notes
+ Returns: A handle on success, NULL(0) on failure
+ Notes : The packet receiver implements the common situation where
+ you have a variable length of packets coming thru over a connection
+ and you want them split up in order to handle them.
+ -
+ The major limiation is, that the buffer is created in memory,
+ so you can't have arbitrarily large packets
+ Errors : ERROR_INVALID_PARAMETER, ERROR_OUTOFMEMORY
+ }
+ MS_NETLIB_CREATEPACKETRECVER = 'Netlib/CreatePacketRecver';
+
+ {
+ wParam : Handle returned by MS_NETLIB_CREATEPACKETRECVER
+ lParam : Pointer to an initialised TNETLIBPACKETRECVER
+ Returns: The total number of bytes available in the buffer, NULL(0)
+ if the connection was closed or SOCKET_ERROR.
+ -
+ If TNETLIBPACKETRECVER.bytesUsed is set to zero and the
+ buffer is already full up to the maxPacketSize, it is assumed
+ that a too large packet has been received, All data in
+ the buffer is discarded and receiving has started anew.
+ -
+ This will probably cause alignment problem so if you think
+ that tis iss likely to happen, then you should deal with it
+ yourself.
+ -
+ Closing the packet receiver will not close the associated
+ connection but will discard any bytes still in the buffer,
+ so if you intend to carry on reading from that connection,
+ make sure you have processed the buffer first.
+ -
+ This service is equivalent of memmove() to remove
+ the first bytesUsed from the buffer, select(), if dwTimeOut
+ is not INFINITE, then MS_NETLIB_RECV
+ Errors : ERROR_INVALID_PARAMETER, ERROR_TIMEOUT, anything from select(),
+ MS_NETLIB_RECV
+ }
+ MS_NETLIB_GETMOREPACKETS = 'Netlib/GetMorePackets';
+
+ {
+ wParam : HANDLE
+ lParam : Pointer to null terminated string to uh, log.
+ Affect : Add a message to the log (if it's running) see notes
+ Returns: non zeror on success, NULL(0) on failure
+ Notes : Don't include \r\n or #13#10 it's not needed,
+ -
+ Doesn't support formatting like the given C code for
+ Netlib_Logf, just use FmtStr() and then call this service
+ if you want that.
+ Errors : ERROR_INVALID_PARAMETER
+ }
+ MS_NETLIB_LOG = 'Netlib/Log';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_options.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_options.inc new file mode 100644 index 0000000000..23d891a81c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_options.inc @@ -0,0 +1,109 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_OPTIONS}
+{$DEFINE M_OPTIONS}
+
+const
+
+ {
+ wParam : addinfo
+ lParam : 0
+ Affects: The user opened the options dialog, see notes
+ Notes : Modules should do whatever initalisation they need and call
+ MS_OPT_ADDPAGE with the wParam -- MS_OPT_ADDPAGE
+ can be called one or more times
+ if more than one page wants to be displayed.
+ }
+ ME_OPT_INITIALISE = 'Opt/Initialise';
+
+ {
+ wParam : wParam from ME_OPT_INITIALISE
+ lParam : Pointer to an initialised TOPTIONSDIALOGPAGE
+ Affects: Adds a page to the options dialog, see notes
+ Notes : Strings in the structure can be released as soon as the
+ service returns -- but icons must be kept around, this iss
+ not a problem if you're loading theem from a resource.
+ -
+ This service should only be called within the ME_OPT_INITIALISE
+ event hook.
+ -
+ Pages in the options dialog operate just like pages in property
+ sheets, See the WinAPI documentation for details on how they operate.
+ Version: Prior to v0.1.2.1 the options dialog would resize
+ to fit the largest page, but since then it's a fixed size
+ The largest page that fits neatly is 314x240 DLU's
+ -
+ Some of OPTIONSDIALOGPAGE's fields are version dependant.
+ }
+ MS_OPT_ADDPAGE = 'Opt/AddPage';
+
+ { defacto size }
+
+ OPTIONSDIALOGPAGE_V0100_SIZE = $18;
+ OPTIONSDIALOGPAGE_V0120_SIZE = $28;
+
+ { page is only shown when in 'simple' mode }
+ ODPF_SIMPLEONLY = 1;
+ { page is only shown when in 'expert' mode }
+ ODPF_EXPERTONLY = 2;
+ { give group box titles a bold font }
+ ODPF_BOLDGROUPS = 4;
+
+type
+
+ POPTIONSDIALOGPAGE = ^TOPTIONSDIALOGPAGE;
+ TOPTIONSDIALOGPAGE = record
+ cbSize: int;
+ position: int; // position number, lower numbers are top most
+ pszTitle: PChar;
+ pfnDlgProc: Pointer; // DLGPROC prototype
+ pszTemplate: PChar;
+ hInstance: THandle;
+ hIcon: THandle; // v0.1.0.1+
+ pszGroup: PChar; // v0.1.0.1+
+ groupPosition: int; // v0.1.0.1+
+ hGroupIcon: THandle; // v0.1.0.1+
+ flags: DWORD; // v0.1.2.1+
+ { if in simple mode the dialog will be cut off AFTER this control ID, 0
+ for disable }
+ nIDBottomSimpleControl: int; // v0.1.2.1+
+ { if in simple mode the dialog will cut off AFTER this control ID, 0 to disable }
+ nIDRightSimpleControl: int; // v0.1.2.1+
+ { these controls will be hidden in simple mode, pointer to an array of ID's
+ must remain valid for the duration of the dialog }
+ expertOnlyControls: ^int;
+ nExpertOnlyControls: int; // v0.1.2.1+
+ end;
+
+const
+
+ { sent to pages via WM_NOTIFY when the expert checkbox is clicked, lParam = new state }
+ PSN_EXPERTCHANGED = 2;
+ { returns true/false }
+ PSM_ISEXPERT = ($0400 + 101);
+ { returns HFONT used for group box titles }
+ PSM_GETBOLDFONT = ($0400 + 102);
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_plugins.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_plugins.inc new file mode 100644 index 0000000000..689b7a39e7 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_plugins.inc @@ -0,0 +1,70 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_PLUGINS}
+{$DEFINE M_PLUGINS}
+
+const
+
+ DEFMOD_PROTOCOLICQ = 1; // removed from v0.3.0.0 alpha
+ DEFMOD_PROTOCOLMSN = 2; // removed from v0.1.2.0+
+ DEFMOD_UIFINDADD = 3;
+ DEFMOD_UIUSERINFO = 4;
+ DEFMOD_SRMESSAGE = 5;
+ DEFMOD_SRURL = 6;
+ DEFMOD_SREMAIL = 7;
+ DEFMOD_SRAUTH = 8;
+ DEFMOD_SRFILE = 9;
+ DEFMOD_UIHELP = 10;
+ DEFMOD_UIHISTORY = 11;
+ DEFMOD_RNDCHECKUPD = 12;
+ DEFMOD_RNDICQIMPORT = 13; // not built in to v0.1.0.1+
+ DEFMOD_RNDAUTOAWAY = 14;
+ DEFMOD_RNDUSERONLINE = 15;
+ DEFMOD_RNDCRYPT = 16; // v0.1.0.1-v0.1.2.0
+ DEFMOD_SRAWAY = 17; // v0.1.0.1+
+ DEFMOD_RNDIGNORE = 18; // v0.1.0.1+
+ DEFMOD_UIVISIBILITY = 19; // v0.1.1.0+, options page only
+ DEFMOD_UICLUI = 20; // v0.1.1.0+
+ DEFMOD_UIPLUGINOPTS = 21; // v0.1.2.1+
+ DEFMOD_PROTOCOLNETLIB = 22; // v0.1.2.2+
+
+ DEFMOD_HIGHEST = 22;
+
+
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Gets an array of modules that the plugins report they want to replace
+ Returns: Returns a pointer to an array of ints, with elements 1 or 0,
+ indexed by the DEFMOD_* constants, 1 is to mark that the default
+ module shouldn't be loaded, see notes
+ Notes : this is primarily for use by the core's module initialiser,
+ but could also be used by modules that are doing
+ naughty things that are very feature-dependent.
+ }
+ MS_PLUGINS_GETDISABLEDEFAULTARRAY = 'Plugins/GetDisableDefaultArray';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_popup.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_popup.inc new file mode 100644 index 0000000000..f8d2ea9df9 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_popup.inc @@ -0,0 +1,222 @@ +(*
+===============================================================================
+ PopUp plugin
+Plugin Name: PopUp
+Plugin author: hrk, Luca Santarelli, hrk@users.sourceforge.net
+This file has been created by egodust, Sam, egodust@users.sourceforge.net
+===============================================================================
+
+The purpose of this plugin is to give developers a common "platform/interface" to show PopUps. It is born from the source code of NewStatusNotify, another plugin I've made.
+
+Remember that users *must* have this plugin enabled, or they won't get any popup. Write this in the requirements, do whatever you wish ;-)... but tell them!
+===============================================================================
+
+-- To use this file you need Windows.pas, m_globaldefs.pas (get it from the CVS under the 'inc' module)
+-- To include this in the source, use {$include m_popup.h}
+
+*)
+
+{$ifndef M_POPUP_H}
+{$define M_POPUP_H}
+
+{$ifdef FPC}
+ {$PACKRECORDS C}
+ {$MODE Delphi}
+{$endif}
+
+const
+
+ MAX_CONTACTNAME = 2048;
+ MAX_SECONDLINE = 2048;
+
+ SM_WARNING = $01; //Triangle icon.
+ SM_NOTIFY = $02; //Exclamation mark icon.
+
+type
+
+ // for info on what this stuff is, see m_popup.h
+
+ PPOPUPDATA = ^TPOPUPDATA;
+ TPOPUPDATA = record
+ lchContact: HCONTACT;
+ lchIcon: THandle;
+ lpszContactName: array[0..MAX_CONTACTNAME-1] of Char;
+ lpszText: array[0..MAX_SECONDLINE-1] of Char;
+ colorBack: COLORREF;
+ colorForeText: COLORREF;
+ PluginWindowProc: Pointer; // must be a window procedure using stdcall
+ PluginData: Pointer;
+ end;
+
+type
+
+ // for info on what this stuff is, see m_popup.h
+
+ PPOPUPDATAEX = ^TPOPUPDATAEX;
+ TPOPUPDATAEX = record
+ lchContact: HCONTACT;
+ lchIcon: THandle;
+ lpszContactName: array[0..MAX_CONTACTNAME-1] of Char;
+ lpszText: array[0..MAX_SECONDLINE-1] of Char;
+ colorBack: COLORREF;
+ colorForeText: COLORREF;
+ PluginWindowProc: Pointer; // must be a window procedure using stdcall
+ PluginData: Pointer;
+ iSeconds: int; //Custom delay time in seconds. -1 means "forever", 0 means "default time".
+ cZero: array[0..15] of Char; //16 unused bytes which may come useful in the future.
+ end;
+
+const
+
+(*
+ Creates, adds and shows a popup, given a (valid) POPUPDATA structure pointer.
+ wParam = (WPARAM)(*POPUPDATA)PopUpDataAddress
+ lParam = 0
+ Returns: > 0 on success, 0 if creation went bad, -1 if the PopUpData contained unacceptable values.
+ NOTE: it returns -1 if the PopUpData was not valid, if there were already too many popups, if the module was disabled.
+ Otherwise, it can return anything else...
+*)
+
+ MS_POPUP_ADDPOPUP = 'PopUp/AddPopUp';
+
+(*
+ The same, but with a POPUPDATAEX structure pointer.
+ wParam = (WPARAM)(*POPUPDATAEX)PopUpDataExAddress
+ lParam = 0
+*)
+
+ MS_POPUP_ADDPOPUPEX = 'PopUp/AddPopUpEx';
+
+(*
+ Returns the handle to the contact associated to the specified PopUpWindow.
+ You will probably need to know this handle inside your WNDPROC. Exampole: you want to open the MessageWindow. :-)
+ Call MS_POPUP_GETCONTACT on the hWnd you were given in the WNDPROC.
+ wParam = (WPARAM)(HWND)hPopUpWindow
+ lParam = 0;
+ Returns: the HANDLE of the contact. Can return NULL, meaning it's the main contact. -1 means failure.
+*)
+
+ MS_POPUP_GETCONTACT = 'PopUp/GetContact';
+
+(*
+ wParam = hPopUpWindow
+ lParam = PluginDataAddress;
+ Returns: the address of the PLUGINDATA structure. Can return NULL, meaning nothing was given. -1 means failure.
+ IMPORTANT NOTE: it doesn't seem to work if you do:
+ CallService(..., (LPARAM)aPointerToAStruct);
+ and then use that struct.
+ Do this, instead:
+ aPointerToStruct = CallService(..., (LPARAM)aPointerToAStruct);
+ and it will work. Just look at the example I've written above (PopUpDlgProc).
+*)
+ MS_POPUP_GETPLUGINDATA = 'PopUp/GetPluginData';
+
+(*
+ wParam = 0
+ lParam = 0
+ Returns: 0 if the user has chosen not to have the second line, 1 if he choose to have the second line.
+*)
+ MS_POPUP_ISSECONDLINESHOWN = 'PopUp/IsSecondLineShown';
+
+(*
+ UM_FREEPLUGINDATA
+ wParam = lParam = 0. Process this message if you have allocated your own memory. (i.e.: POPUPDATA.PluginData != NULL)
+*)
+ UM_FREEPLUGINDATA = ((*WM_USER*)$400 + $200);
+
+(*
+ UM_DESTROYPOPUP
+ wParam = lParam = 0. Send this message when you want to destroy the popup, or use the function below.
+*)
+ UM_DESTROYPOPUP = ((*WM_USER*)$400 + $201);
+
+(*
+ UM_INITPOPUP
+ wParam = (WPARAM)(HWND)hPopUpWindow (but this is useless, since I'll directly send it to your hPopUpWindow
+ lParam = 0.
+ This message is sent to the PopUp when its creation has been finished, so POPUPDATA (and thus your PluginData) is reachable.
+ Catch it if you needed to catch WM_CREATE or WM_INITDIALOG, which you'll never ever get in your entire popup-life.
+ Return value: if you process this message, return 0. If you don't process it, return 0. Do whatever you like ;-)
+*)
+ UM_INITPOPUP = ($400(*WM_USER*) + $202);
+
+(*
+ wParam = hPopUpWindow
+ lParam = lpzNewText
+ returns: > 0 for success, -1 for failure, 0 if the failure is due to second line not being shown. (but you could call PUIsSecondLineShown() before changing the text...)
+ Changes the text displayed in the second line of the popup.
+*)
+ MS_POPUP_CHANGETEXT = 'PopUp/Changetext';
+
+(*
+ This is mainly for developers.
+ Shows a warning message in a PopUp. It's useful if you need a "MessageBox" like function, but you don't want a modal window (which will interfere with a DialogProcedure. MessageBox steals focus and control, this one not.
+ wParam = lpzMessage
+ lParam = 0; Returns: 0 if the popup was shown, -1 in case of failure.
+*)
+ MS_POPUP_SHOWMESSAGE = 'PopUp/ShowMessage';
+
+
+ (* helper functions, will be inlined on FPC if you have the swithces enabled *)
+
+ function PUAddPopup(ppdp: PPOPUPDATA): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := CallService(MS_POPUP_ADDPOPUP, WPARAM(ppdp), 0);
+ end;
+
+ function PUGetContact(hPopUpWindow: THandle): THandle;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := CallService(MS_POPUP_GETCONTACT, WPARAM(hPopUpWindow), 0);
+ end;
+
+ function PUGetPluginData(hPopUpWindow: THandle): Pointer;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ var
+ dummy: pointer;
+ begin
+ dummy := nil;
+ Int(Result) := CallService(MS_POPUP_GETPLUGINDATA, WPARAM(hPopUpWindow), LPARAM(dummy));
+ end;
+
+ function PUIsSecondLineShown: BOOL;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Int(Result) := CallService(MS_POPUP_ISSECONDLINESHOWN, 0, 0);
+ end;
+
+ function PUDeletePopUp(hWndPopUp: THandle): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := SendMessage(hWndPopUp, UM_DESTROYPOPUP, 0, 0);
+ end;
+
+ function PUChangeText(hWndPopUp: THandle; lpzNewText: PChar): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := CallService(MS_POPUP_CHANGETEXT, WPARAM(hWndPopUp), LPARAM(lpzNewText));
+ end;
+
+ function PUShowMessage(lpzText: PChar; kind: Byte): int;
+ {$ifdef FPC}
+ inline;
+ {$endif}
+ begin
+ Result := CallService(MS_POPUP_SHOWMESSAGE, WPARAM(lpzText), LPARAM(kind));
+ end;
+
+{$endif}
+
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protocols.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protocols.inc new file mode 100644 index 0000000000..f198d40a8b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protocols.inc @@ -0,0 +1,180 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_PROTOCOLS}
+{$DEFINE M_PROTOCOLS}
+
+const
+
+ ACKTYPE_MESSAGE = 0;
+ ACKTYPE_URL = 1;
+ ACKTYPE_FILE = 2;
+ ACKTYPE_CHAT = 3;
+ ACKTYPE_AWAYMSG = 4;
+ ACKTYPE_AUTHREQ = 5;
+ ACKTYPE_ADDED = 6;
+ ACKTYPE_GETINFO = 7;
+ ACKTYPE_SETINFO = 8;
+ ACKTYPE_LOGIN = 9;
+ ACKTYPE_SEARCH = 10;
+ ACKTYPE_NEWUSER = 11;
+ ACKTYPE_STATUS = 12;
+ ACKTYPE_CONTACTS = 13; //send/recv of contacts
+
+ ACKRESULT_SUCCESS = 0;
+ ACKRESULT_FAILED = 1;
+ //'in progress' result codes:
+ ACKRESULT_CONNECTING = 100;
+ ACKRESULT_CONNECTED = 101;
+ ACKRESULT_INITIALISING = 102;
+ ACKRESULT_SENTREQUEST = 103; // waiting for reply...
+ ACKRESULT_DATA = 104; // blob of file data sent/recved, or search result
+ ACKRESULT_NEXTFILE = 105; // file transfer went to next file
+ ACKRESULT_FILERESUME = 106; // a file is about to be received, see PS_FILERESUME
+ ACKRESULT_DENIED = 107; // a file send has been denied (0.3a + only)
+
+ // for PROTOCOLDESCRIPTOR.type
+
+ PROTOTYPE_PROTOCOL = 1000;
+ PROTOTYPE_ENCRYPTION = 2000;
+ PROTOTYPE_FILTER = 3000;
+ PROTOTYPE_TRANSLATION = 4000;
+ PROTOTYPE_OTHER = 10000;//avoid using this if at all possible
+
+type
+
+ PCCSDATA = ^TCCSDATA;
+ TCCSDATA = record
+ hContact: THandle;
+ szProtoService: PChar; // a PS_* constant
+ wParam: WPARAM;
+ lParam: LPARAM;
+ end;
+
+ PACKDATA = ^TACKDATA;
+ TACKDATA = record
+ cbSize: int;
+ szModule: PChar; // the name of the protocol module which initiated this ack
+ hContact: THandle;
+ type_: int; // an ACKTYPE_* constant
+ result_: int; // an ACKRESULT_* constant
+ hProcess: THandle; // caller defined seq, I mean process code
+ lParam: LPARAM; // caller defined data
+ end;
+
+ // when type=ACKTYPE_FILE and (result=ACKRESULT_DATA or result=ACKRESULT_FILERESUME)
+
+ PPROTOFILETRANSFERSTATUS = ^TPROTOFILETRANSFERSTATUS;
+ TPROTOFILETRANSFERSTATUS = record
+ cbSize: int;
+ hContact: THandle;
+ sending: int; // true if sending, false if receiving
+ files: PChar; // pointer to an array of pchar's
+ totalFiles: int;
+ currentFileNumber: int;
+ totalBytes: LongInt;
+ totalProgress: LongInt;
+ workingDir: PChar;
+ currentFile: PChar;
+ currentFileSize: LongInt;
+ currentFileProgress: LongInt;
+ currentFileTime: LongInt; // UNIX time
+ end;
+
+ // for registering a protocol, enumeration
+
+ PPROTOCOLDESCRIPTOR = ^TPROTOCOLDESCRIPTOR;
+ TPROTOCOLDESCRIPTOR = record
+ cbSize: int;
+ szName: PChar; // unique name of module
+ type_: int; // a PROTOTYPE_* constant
+ end;
+
+const
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised CSSDATA structure
+ Affect : Send a general request thru the protocol chain for a contact
+ Return : the return value documented in the PS_* def (m_protosvc.inc)
+ }
+ MS_PROTO_CALLCONTACTSERVICE = 'Proto/CallContactService';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised TACKDATA structure
+ Affect : a general 'ack', see notes
+ Notes : Just because defs are here doesn't mean they will be sent
+ read the docs for the function you are calling to see what
+ replies you will get.
+ }
+ ME_PROTO_ACK = 'Proto/Ack';
+
+ {
+ wParam : pointer to an int to store number of protocols
+ lParam : Pointer to an an array of PPROTOCOLDESCRIPTOR pointers
+ Affect : Enumerate the currently running protocols, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : Neither wParam/lParam maybe NULL(0), the list returned by
+ this service is the protocol modules currently installed
+ and running, it is not a complete list of protocols that have
+ ever been installed.
+ -
+ A protocol module does not have to be a protocol running thru
+ the internet, it can be a vast number of things
+ }
+ MS_PROTO_ENUMPROTOCOLS = 'Proto/EnumProtocols';
+
+ {
+ wParam : 0
+ lParam : Pointer to null terminated string containing protocol name
+ Affect : Determines if a protocol is running or not.
+ Returns: A pointer to the PPROTOCOLDESCRIPTOR if the protocol is loaded
+ or NULL(0) if it isn't
+ }
+ MS_PROTO_ISPROTOCOLLOADED = 'Proto/IsProtocolLoaded';
+
+ {
+ wParam : HCONTACT
+ lParam : Pointer to a null terminated string containing a name
+ Affect : Determine whether the given contact has the given protocol
+ in it's chain.
+ Returns : 0 if the protocol isn't in the chain, [non zero] if it is
+ }
+ MS_PROTO_ISPROTOONCONTACT = 'Proto/IsProtoOnContact';
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affect : Gets the network-level protocol associated with a contact
+ Returns: a PChar pointing to the ASCIIZ name of the protocol or NULL(0)
+ if the contact has no protocol, There's no need to dispsose
+ the returned string.
+ -
+ This is the name of the module that actually accesses the network
+ for that contact.
+ }
+ MS_PROTO_GETCONTACTBASEPROTO = 'Proto/GetContactBaseProto';
+
+{$ENDIF}
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protomod.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protomod.inc new file mode 100644 index 0000000000..312e0de687 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protomod.inc @@ -0,0 +1,105 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_PROTOMOD}
+{$DEFINE M_PROTOMOD}
+
+ {$ifndef M_PROTOCOLS}
+ {$include m_protocols.inc}
+ {$endif}
+
+const
+
+ {
+ wParam : 0
+ lParam : Pointer to a initalised TPROTOCOLDESCRIPTOR structure
+ Affect : Register a protocol module, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : This service MUST be called from your module's Load() function
+ TPROTOCOLDESCRIPTOR.type can be a value other than PROTOTYPE_*
+ which are used to provide a more precise positioning information
+ for the contact protocol lists.
+ -
+ Relative values to the constants can be given, but this MUST NOT
+ be done for PROTOTYPE_PROTOCOL.
+ }
+ MS_PROTO_REGISTERMODULE = 'Proto/RegisterModule';
+
+ {
+ wParam : HCONTACT
+ lParam : protocol_name_string
+ Affect : Add the given protocol module to the chain for a contact, see notes
+ Returns: 0 success, [non zero] on failure
+ Notes : The module is added to the correct positioning according to it's
+ registered type.
+ }
+ MS_PROTO_ADDTOCONTACT = 'Proto/AddToContact';
+
+ {
+ wParam : HCONTACT
+ lParam : protocol_name_string
+ Affect : Remove the given protocol name from the chain for the given contact
+ Returns: 0 on success, [non zero] on failure
+ }
+ MS_PROTO_REMOVEFROMCONTACT = 'Proto/RemoveFromContact';
+
+ { see m_helpers.inc for CreateProtoServiceFunction }
+
+ {
+ wParam : wParam [arg]
+ lParam : lParam [arg]
+ Affect : Call the next service in the chain for the send operation, see notes
+ Return : Return value should be returned by CallService(MS_PROTO_CHAINSEND,wParam,lParam)
+ Notes : wParam MUST remain untouched, lParam is a pointer to a CCSDATA structure
+ and can be modified or copid if needed.
+ wParam and lParam should be the values passed to your service,
+ typically your service should return ASAP.
+ }
+ MS_PROTO_CHAINSEND = 'Proto/ChainSend';
+
+ {
+ wParam : wParam [arg]
+ lParam : lParam [arg]
+ Affect : Call the next service in the chain in this receive operation, see notes
+ Return : Return value should be returned by CallService(MS_PROTO_CHAINRECV,wParam,lParam)
+ Notes : wParam MUST remain untouched, lParam is a pointer to a CCSDATA structure
+ and can be modified or copied if needed.
+ wParam and lParam should be the values passed to your service,
+ typically your service should return ASAP.
+ -
+ MS_PROTO_CHAINRECV is thread safe since 0.1.2.0 -- calls
+ are translated to the main thread and passed from there.
+ }
+ MS_PROTO_CHAINRECV = 'Proto/ChainRecv';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised ACKDATA
+ Affect : Broadcast a ME_PROTO_ACK event, see notes
+ Returns: The return value of the NotifyEventHooks() call
+ Notes : ME_PROTO_ACK is completely thread safe since 01.2.0
+ see notes in core/modules.h under NotifyEventHooks()
+ }
+ MS_PROTO_BROADCASTACK = 'Proto/BroadcastAck';
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protosvc.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protosvc.inc new file mode 100644 index 0000000000..0b52f04600 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_protosvc.inc @@ -0,0 +1,753 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_PROTOSVC}
+{$DEFINE M_PROTOSVC}
+
+{<</
+ none of these services should be used on there own (i.e. using CallService(), etc)
+ hence the PS_ prefix, instead use the services exposed in m_protocols.inc
+
+ these should be called with CallProtoService which prefixes the protocol module
+ name before calling.
+ -
+ Deleting contacts from protocols that store the contact list on the server:
+ If a contact is deleted while the protocol is online, it is expected that the
+ protocol will have hooked me_db_contact_deleted and take the appropriate
+ action by itself.
+ If a contact is deleted while the protocol is offline, the contact list will
+ display a message to the user about the problem, and set the byte setting
+ "CList"/"Delete" to 1. Each time such a protocol changes status from offline
+ or connecting to online the contact list will check for contacts with this
+ flag set and delete them at that time. Your hook for me_db_contact_deleted
+ will pick this up and everything will be good.
+/>>}
+
+const
+
+ PFLAGNUM_1 = $1;
+ PF1_IMSEND = $00000001; // supports IM sending
+ PF1_IMRECV = $00000002; // supports IM receiving
+ PF1_IM = (PF1_IMSEND or PF1_IMRECV);
+ PF1_URLSEND = $00000004; // supports separate URL sending
+ PF1_URLRECV = $00000008; // supports separate URL receiving
+ PF1_URL = (PF1_URLSEND or PF1_URLRECV);
+ PF1_FILESEND = $00000010; // supports file sending
+ PF1_FILERECV = $00000020; // supports file receiving
+ PF1_FILE = (PF1_FILESEND or PF1_FILERECV);
+ PF1_MODEMSGSEND = $00000040; // supports broadcasting away messages
+ PF1_MODEMSGRECV = $00000080; // supports reading others' away messages
+ PF1_MODEMSG = (PF1_MODEMSGSEND or PF1_MODEMSGRECV);
+ PF1_SERVERCLIST = $00000100; // contact lists are stored on the server, not locally. See notes below
+ PF1_AUTHREQ = $00000200; // will get authorisation requests for some or all contacts
+ PF1_ADDED = $00000400; // will get 'you were added' notifications
+ PF1_VISLIST = $00000800; // has an invisible list
+ PF1_INVISLIST = $00001000; // has a visible list for when in invisible mode
+ PF1_INDIVSTATUS = $00002000; // supports setting different status modes to each contact
+ PF1_EXTENSIBLE = $00004000; // the protocol is extensible and supports plugin-defined messages
+ PF1_PEER2PEER = $00008000; // supports direct (not server mediated) communication between clients
+ PF1_NEWUSER = $00010000; // supports creation of new user IDs
+ PF1_CHAT = $00020000; // has a realtime chat capability
+ PF1_INDIVMODEMSG = $00040000; // supports replying to a mode message request with different text depending on the contact requesting
+ PF1_BASICSEARCH = $00080000; // supports a basic user searching facility
+ PF1_EXTSEARCH = $00100000; // supports one or more protocol-specific extended search schemes
+ PF1_CANRENAMEFILE = $00200000; // supports renaming of incoming files as they are transferred
+ PF1_FILERESUME = $00400000; // can resume broken file transfers, see PS_FILERESUME below
+ PF1_ADDSEARCHRES = $00800000; // can add search results to the contact list
+ PF1_CONTACTSEND = $01000000; // can send contacts to other users
+ PF1_CONTACTRECV = $02000000; // can receive contacts from other users
+ PF1_CONTACT = (PF1_CONTACTSEND or PF1_CONTACTRECV);
+ PF1_CHANGEINFO = $04000000; // can change our user information stored on server
+ PF1_SEARCHBYEMAIL = $08000000; // supports a search by e-mail feature
+ PF1_USERIDISEMAIL = $10000000; // set if the uniquely identifying field of the network is the e-mail address
+ PF1_SEARCHBYNAME = $20000000; // supports searching by nick/first/last names
+ PF1_EXTSEARCHUI = $40000000; // has a dialog box to allow searching all the possible fields
+ PF1_NUMERICUSERID = $80000000; // the unique user IDs for this protocol are numeric
+
+ PFLAGNUM_2 = 2; // the status modes that the protocol supports
+ PF2_ONLINE = $00000001; // an unadorned online mode
+ PF2_INVISIBLE = $00000002;
+ PF2_SHORTAWAY = $00000004; // Away on ICQ, BRB on MSN
+ PF2_LONGAWAY = $00000008; // NA on ICQ, Away on MSN
+ PF2_LIGHTDND = $00000010; // Occupied on ICQ, Busy on MSN
+ PF2_HEAVYDND = $00000020; // DND on ICQ
+ PF2_FREECHAT = $00000040;
+ PF2_OUTTOLUNCH = $00000080;
+ PF2_ONTHEPHONE = $00000100;
+
+ PFLAGNUM_3 = 3; //the status modes that the protocol supports
+ //away-style messages for. Uses the PF2_ flags.
+ PFLAG_UNIQUEIDTEXT = 100; //returns a static buffer of text describing the unique field by which this protocol identifies users (already translated), or NULL
+
+ PFLAG_MAXCONTACTSPERPACKET = 200; //v0.1.2.2+: returns the maximum number of contacts which can be sent in a single PSS_CONTACTS.
+
+ PFLAGNUM_4 = 4; // v0.3+: flag asking a protocol plugin how auths are handled
+ PF4_FORCEAUTH = $00000001; // protocol has to send auth's for things to work
+ PF4_FORCEADDED = $00000002; // protocol has to tell people that they were added (otherwise things don't work)
+ PF4_NOCUSTOMAUTH = $00000004; // protocol can't send a custom message while asking others for auth
+
+ PFLAG_UNIQUEIDSETTING = 300; // v0.3+: returns the DB setting name (e.g. szProto=ICQ, szSetting=UIN) that has the ID which makes this user unique on that system (0.3a ONLY), the string is statically allocated so no need to free()
+
+ // for PS_SETSTATUS
+
+ LOGINERR_WRONGPASSWORD = 1;
+ LOGINERR_NONETWORK = 2;
+ LOGINERR_PROXYFAILURE = 3;
+ LOGINERR_BADUSERID = 4;
+ LOGINERR_NOSERVER = 5;
+ LOGINERR_TIMEOUT = 6;
+ LOGINERR_WRONGPROTOCOL = 7;
+
+ // flag for PS_ADDTOLIST
+
+ PALF_TEMPORARY = 1; // add the contact temporarily and invisibly, just to get user info or something
+
+ // flags for PS_GETINFO
+
+ SGIF_MINIMAL = 1; // get only the most basic information. This should
+ // contain at least a Nick and e-mail.
+
+ // for PSR_MESSAGE
+
+ PREF_CREATEREAD = 1; // create the database event with the 'read' flag set
+
+ // for PS_FILERESUME
+
+ FILERESUME_OVERWRITE= 1;
+ FILERESUME_RESUME = 2;
+ FILERESUME_RENAME = 3;
+ FILERESUME_SKIP = 4;
+
+type
+
+ PPROTOSEARCHRESULT = ^TPROTOSEARCHRESULT;
+ TPROTOSEARCHRESULT = record
+ cbSize: int;
+ nick: PChar;
+ firstName: PChar;
+ lastName: PChar;
+ email: PChar;
+ reserved: array [0..15] of Byte;
+ // Protocols may extend this structure with extra members at will and supply
+ // a larger cbSize to reflect the new information, but they must not change
+ // any elements above this comment
+ // The 'reserved' field is part of the basic structure, not space to
+ // overwrite with protocol-specific information.
+ // If modules do this, they should take steps to ensure that information
+ // they put there will be retained by anyone trying to save this structure.
+ end;
+
+ PPROTOSEARCHBYNAME = ^TPROTOSEARCHBYNAME;
+ TPROTOSEARCHBYNAME = record
+ pszNick: PChar;
+ pszFirstName: PChar;
+ pszLastName: PChar;
+ end;
+
+ PPROTORECVEVENT = ^TPROTORECVEVENT;
+ TPROTORECVEVENT = record
+ flags: DWORD;
+ timestamp: DWORD;
+ szMessage: PChar;
+ lParam: LPARAM;
+ end;
+
+ PPROTORECVFILE = ^TPROTORECVFILE;
+ TPROTORECVFILE = record
+ flags: DWORD;
+ timestamp: DWORD; // unix time
+ szDescription: PChar;
+ pFiles: PChar; // pointer to an array of pchar's
+ lParam: LPARAM;
+ end;
+
+ PPROTOFILERESUME = ^TPROTOFILERESUME;
+ TPROTOFILERESUME = record
+ action: int; // FILERESUME_* flag
+ szFilename: PChar; // full path, only valid if action=FILERESUME_RENAME
+ end;
+
+const
+
+ {
+ wParam : PFLAGNUM_* (see above)
+ lParam : 0
+ Affects: Returns a bitfield for settings corresponding to flag number, see notes
+ Returns: a bitfield of supported features -- or 0 if flag_num is not supported
+ Notes : this checks what sort of things are actively supported by a protocol
+ module
+ }
+ PS_GETCAPS = '/GetCaps';
+
+ {
+ wParam : cchName
+ lParam : Pointer to a buffer to fill with human-readable name
+ Affect : Get a human-readable name for the protocol, see notes
+ Result : 0 on success, [non zero] on failure
+ Notes : Should be translated before being returned, cchName
+ has the size of the buffer, example strings: "ICQ", "AIM"
+ }
+ PS_GETNAME = '/GetName';
+
+ {
+ wParam : whichIcon
+ lParam : 0
+ Affect : Loads one of the protocol-sspecific icons
+ Returns: the HICON or NULL on failure, the returned icon
+ must be DestroyIcon()ed, the UI should overlay
+ the online icon with further UI-specified icon to
+ repressent the exact status mode.
+ }
+ PLI_PROTOCOL = $1; // An icon representing the protocol (eg the multicoloured flower for ICQ)
+ PLI_ONLINE = $2; // Online state icon for that protocol (eg green flower for ICQ)
+ PLI_OFFLINE = $3; // Offline state icon for that protocol (eg red flower for ICQ)
+ PLIF_LARGE = $0; // Or with one of the above to get the large (32x32 by default) icon
+ PLIF_SMALL = $10000; // Or with one of the above to get the small (16x16 by default) icon
+
+ PS_LOADICON = '/LoadIcon';
+
+ {
+ wParam : status_mode
+ lParam : Pointer to a null terminated string containing message
+ Affect : Sets the status mode specific message for the user, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : This service is not available unless PF1_MODEMSGSEND is set,
+ and PF1_INDIVMODEMSG is *not* set.
+ If PF1_INDIVMODEMSG is set, then see PSS_AWAYMSSG for details
+ of operations of away messages.
+ -
+ Protocol modules smust support lParam=NULL, it may eithere mean
+ to use an empty message or (preferably) not to reply at all to
+ any requests.
+ }
+ PS_SETAWAYMSG = '/SetAwayMsg';
+
+ {
+ wParam : newMode from statusmodes.inc
+ lParam : 0
+ Affect : Change the protocol's status mode, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : Will send an ack with :
+ type=ACKTYPE_SUCCESS, result=ACKRESULT_SUCCESS, hProcess=previousMode, lParam=newMode
+ -
+ when the change completes. This ack is sent for all changes, not
+ just ones caused by calling this function.
+ -
+ NewMode can be ID_STATUS_CONNECTING<=newMode<ID_STATUS_CONNECTING+
+ MAX_CONNECT_RETRIES to signify that it's connecting and it's the nth retry.
+ -
+ Protocols are initially always in offline mode, if a protocol
+ doesn't support a specific status mode, it should pick the closest
+ ones that it does support, and change to that.
+
+ If a protocol has to switch from offline mode to online (or a substate
+ of online, like away) then it should report any errors in the
+ form of an additional ack :
+
+ type=ACKTYPE_LOGIN, result=ACKRESULT_FAILURE, hProcess=NULL, lParam=LOGINERR_*
+
+ SetStatus() is called when a protocol module is first loaded
+ with newMode=ID_STATUS_ONLINE.
+ -
+ Protocols can define their own LOGINERR_* starting at $1000, see
+ LOGINERR_* above
+ }
+ PS_SETSTATUS = '/SetStatus';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Get the status mode that a protocol is currently in, see notes
+ Returns: The current status mode
+ Notes : Only protocol modules need to implement this, non network level
+ protocol modules do not need to (but if you register as a protocol
+ you need to, Miranda will GPF otherwise)
+ }
+ PS_GETSTATUS = '/GetStatus';
+
+ {
+ wParam : HDBEVENT
+ lParam : 0
+ Affect : allow 'somebody' to add the user to their contact list, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : Auth request come in the form of an event added to the database
+ for the NULL(0) user, the form is:
+ -
+ protocolSpecific: DWORD;
+ nick, firstname, lastName, e-mail, requestReason: ASCIIZ;
+ -
+ HDBEVENT musts be the handle of such an event, one or more
+ fields may be empty if the protocol doesn't support them
+ }
+ PS_AUTHALLOW = '/Authorize';
+
+ {
+ wParam : HDBEVENT
+ lParam : Pointer to a null terminated string containing the reason, see notes
+ Affect : Deny an authorisation request
+ Returns: 0 on success, [non zero] on failure
+ Notes : Protocol modules must be able to cope with lParam=NULL(0)
+ }
+ PS_AUTHDENY = '/AuthDeny';
+
+ {
+ wParam : 0
+ lParam : Pointer to a null terminated string containing an ID to search for
+ Affect : Send a basic search request, see notes
+ Returns: A handle to the search request or NULL(0) on failure
+ Notes : All protocols identify users uniquely by a single field
+ this service will search by that field.
+ -
+ All search replies (even protocol-spec extended searches)
+ are replied by a series of ack's,-
+ -
+ Result acks are a series of:
+ type=ACKTYPE_SEARCH, result=ACKRESULT_DATA, lParam=Pointer to a TPROTOSEARCHRESULT structure
+ -
+ ending ack:
+ type=ACKTYPE_SEARCH, result=ACKRESULT_SUCCESS, lParam=0
+ -
+ The pointers in the structure are not guaranteed to be
+ valid after the ack is complete.
+ -
+ The structure to reply with search results can be extended
+ per protocol basis (see below)
+
+ }
+ PS_BASICSEARCH = '/BasicSearch';
+
+ {
+ wParam : 0
+ lParam : Pointer to a NULL terminated string containing the e-mail to search for
+ Affect : Search for user(s) by e-mail address, see notes
+ Returns: A HANDLE to the search, or NULL(0) on failure
+ Notes : Results are returned as for PS_BASICSEARCH, this service
+ is only available if the PF1_USERIDISEMAIL flag is set for caps --
+ -
+ This service with the above service should be mapped to the same
+ function if the aforementioned flag is set.
+ Version: v0.1.2.1+
+ }
+ PS_SEARCHBYEMAIL = '/SearchByEmail';
+
+ {
+ wParam : 0
+ lParam : Pointer to a TPROTOSEARCHBYNAME structure
+ Affect : Search for users by name, see notes
+ Returns: Handle to the search, NULL(0) on failure
+ Notes : this service is only available, if PF1_SEARCHBYNAME capability is set.
+ Results are returned in the same manner as PS_BASICSEEARCH
+ Version: v0.1.2.1+
+ }
+ PS_SEARCHBYNAME = '/SearchByName';
+
+ {
+ wParam : 0
+ lParam : Handle to window owner
+ Affect : Create the advanced search dialog box, see notes
+ Returns: A window handle, or NULL(0) on failure
+ Notes : this service is only available if PF1_EXTSEARCHUI capability is
+ set, advanced search is very protocol-spec'd so it is left to
+ the protocol itself to supply a dialog containing the options,
+ this dialog should not have a titlebar and contain only search
+ fields. the rest of the UI is supplied by Miranda.
+ -
+ The dialog should be created with CreateDialog() or it's kin
+ and still be hidden when this function returns,
+ -
+ The dialog will be destroyed when the find/add dialog is closed
+ Version: v0.1.2.1+
+ }
+ PS_CREATEADVSEARCHUI= '/CreateAdvSearchUI';
+
+ {
+ wParam : 0
+ lParam : Handle to advanced search window handle
+ Affect : Search using the advanced search dialog, see notes
+ Returns: A handle or NULL(0) on failure
+ Notes : Results are returned in the same manner as PS_BASICSEARCH,
+ this service is only available if PF1_EXTSEARCHUI capability is set
+ Version: v0.1.2.1+
+ }
+ PS_SEARCHBYADVANCED = '/SearchByAdvanced';
+
+ {
+ wParam : flags
+ lParam : Pointer to a TPROTOSEARCHRESULT structure
+ Affect : Adds a search result to the contact list, see notes
+ Returns: A handle to the new contact (HCONTACT) or NULL(0) on failure
+ Notes : The pointer MUST be a result returned by a search function
+ since there maybe extra protocol-spec data required by the protocol.
+ -
+ the protocol module should not allow duplicate contains to be added,
+ but if such a request *is* received it should return a HCONTACT
+ to the original user,
+ -
+ If flags is PALF_TEMPORARY set, the contact should be added
+ temorarily and invisiblely, just to get the user info (??)
+ -
+ }
+ PS_ADDTOLIST = '/AddToList';
+
+ {
+ wParam : MAKEWPARAM(flags, iContact)
+ lParam : HDBEVENT
+ Affects: Add a contact to the contact list given an auth/added/contacts events, see notes
+ Returns: A HCONTACT or NULL(0) on failure
+ Notes : HDBEVENT must be either EVENTTYPE_AUTHREQ or EVENTTYPE_ADDED
+ flags are the same as PS_ADDTOLIST,
+ -
+ iContacts is only used for contacts vents, it is 0-based index
+ of the contacts in the event to add, there's no way to add two or more
+ contacts at once, you should just call this as many times as needed.
+ }
+ PS_ADDTOLISTBYEVENT = '/AddToListByEvent';
+
+ {
+ wParam : InfoType
+ lParam : Pointer to InfoData
+ Affect : Changes user details as stored on the server, see notes
+ Returns: A Handle to the change request or NULL(0) on failure
+ Notes : the details stored on the server are very protocol spec'd
+ so this service just supplies an outline for protocols to use.
+ See protocol-specific documentation for what infoTypes are available
+ and what InfoData should be for each infoTypes.
+ -
+ Sends an ack type=ACKTYPE_SETINFO, result=ACKRESULT_SUCCESS/FAILURE, lParam=0
+ -
+ This description just leaves me cold.
+ Version: v0.1.2.0+
+ }
+ PS_CHANGEINFO = '/ChangeInfo';
+
+ {
+ wParam : HFILETRANSFER
+ lParam : Pointer to a initalised TPROTOFILERESUME
+ Affect : Informs the protocol of the user's chosen resume behaviour, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : If the protocol supports file resume (caps: PF1_FILERESUME) then before
+ each file receive begins it will broadcast an ack with :
+
+ type=ACKTYPE_FILE, result=ACKRESULT_RESUME, hProcess=hFileTransfer,
+ lParam = TPROTOFILETRANSFERSTATUS.
+
+ If the UI processes this ack it must return a [non zero] valuee from it's
+ hook, it all the hooks complete without returning [non zero] then the
+ protocol will assume that no resume UI was available and will continue
+ to receive the file with a default behaviour (default: overwrite)
+ -
+ If a hook does return [non zero] then that UI MUST call this service,
+ PS_FILERESUME at some point.
+ When the protocol module receives this call it will proceed wit the
+ file recieve usingg the given information.
+ -
+ Having sasid that, PS_FILERESUME MUST be called, it is also
+ acceptable to completely abort the transfer instead, i.e. the file
+ exists locally and the user doesn't want to overwrite or resume or
+ reget.
+ Version: v0.1.2.2+
+ }
+ PS_FILERESUME = '/FileResume';
+
+ // these should be called with CallContactService()
+
+ {<</
+ !IMPORTANT!
+ wParam, lParam data expected declarations should be treated with
+ one level of indirection, where it says (CCSDATA: Yes)
+ should be :
+
+ What you *actually* get in the service:
+
+ wParam = 0
+ lParam = pCCSDATA
+
+ CCSDATA contains the ..wParam, ..lParam, hContact data declared with each service,
+ so the wParam, lParam passed does not contain the data itself, but lParam
+ contains a pointer to a structure which contains the data.
+
+ />>}
+
+ {
+ CCSDATA: Yes
+ wParam : flags
+ Param : 0
+
+ Affect : Updates a contact's details from the server, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes :
+
+ flags which may have SGIF_MINIMAL set to only get
+ "basic" information, such as nickname, email address.
+
+ PCCSDATA(lParam)^.hContact has the HCONTACT handle to get user
+ information for.
+
+ Will update all the information in the database and then
+ send acks with :
+
+ type=ACKTYPE_GETINFO, result=ACKRESULT_SUCCESS, hProcess=nReplies, lParam=thisReply
+ -
+ Since some protocol do not allow the module to tell when it has
+ got all the information so it can send a final ack, one
+ ack will be sent after each chunk of data has been received,
+ -
+ nReplies contains the number of distinct acks
+ that will be sent to get all the information, 'thisReply'
+ is the zero based index of this ack.
+ When thisReply=0 the minimal information has just been received,
+ all other numbering is arbitrary.
+
+ }
+ PSS_GETINFO = '/GetInfo';
+
+ {
+ CCSDATA: Yes
+ wParam : flags
+ lParam : Pointer to a null terminated string
+ Affect : Send an instant message
+ Returns: an hProcess corresponding to an ACK which will be sent after
+ the hProcess.
+ Notes: type=ACKTYPE_MESSAGE, result=ACKRESULT_SUCCESS/FAILURE, lParam = 0
+ -
+ here's the deal, you must return a 'seq' from this service
+ which you have to ack when the message actually get's sent,
+ or send a fake ack sometime soon if you can't find out if the message
+ was successfully received with the protocol that you're using.
+ -
+ this event is NOT added to the database automatically.
+ }
+ PSS_MESSAGE = '/SendMsg';
+
+ {
+ CCSDATA: Yes
+ wParam : flags
+ lParam : null terminated string to the URL, see notes
+ Affect : Send a URL message, see notes
+ Returns: A hProcess which will be ack'd later
+ Notes : lParam may contain TWO strings, the first for URL, the second for
+ description, in the format :
+ <url>#0<desc>#0 or <url>#0#0
+ Will send an ack for hProcess when the URL actually gets sent
+ type=ACKTYPE_URL, result=ACKRESULT_SUCCESS/FAILURE, lParam=0
+ -
+ protocol modules are free to define flags starting at $10000
+ -
+ The event will *not* be added to the database automatically
+ }
+ PSS_URL = '/SendUrl';
+
+ {
+ CCSDATA: Yes
+ wParam : MAKEWPARAM(flags)
+ lParam : Pointer to hContactsList
+ Affect : Send a set of contacts, see notes
+ Returns: A hProcess which will be ack, NULL(0) on failure
+ Notes : hContactsList is an array of nContacts handles to contacts,
+ if this array includes one or more contains that can not be transferred
+ using this protocol the function will fail.
+ -
+ Will send an ack when the contacts actually get sent:
+
+ type=ACKTYPE_CONTACTS, result=ACKRESULT_SUCCESS/FAILURE, lParam=0
+ -
+ No flags have ben defined yet,
+ -
+ The event will *not* be added to the database automatically
+ }
+ PSS_CONTACTS = '/SendContacts';
+
+ {
+ CCSDATA: Yes
+ wParam : 0
+ lParam : 0
+ Affect : Send a request to retrieve HCONTACT's mode message, see notes
+ Returns: a hProcess which will be ack'd later, NULL(0) on failure
+ Notes : the reply will come in a form of an ack :
+
+ type=ACKTYPE_AWAYMSG, result=ACKRESULT_SUCCESS/FAILURE,
+ lParam=pointer to a null terminated string the containing message
+ }
+ PSS_GETAWAYMSG = '/GetAwayMsg';
+
+ {
+ CCSDATA: Yes
+ wParam : hProcess
+ lParam : pointer to a buffer to fill with away message to reply with
+ Affect : Sends an away message reply to a user, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : This service must only be called is caps has PF1_MODEMSGSEND set
+ as well as PF1_INDIVMODEMSG otherwise PS_SETAWAYMESSAGE should
+ be used.
+ -
+ Reply will be sent in the form of an ack :
+
+ type=ACKTYPE_AWAYMSG, result=ACKRESULT_SENTREQUEST, lParam=0
+ }
+ PSS_AWAYMSG = '/SendAwayMsg';
+
+ {
+ CCSDATA: Yes
+ wParam : status_mode
+ lParam : Pointer to a TPROTORECVEVENT structure
+ Affect : An away message reply has been received
+ }
+ PSR_AWAYMSG = '/RecvAwayMsg';
+
+ {
+ CCSDATA: Yes
+ wParam : status_mode
+ lParam : 0
+ Affect : Set the status mode the user will appear in to a user, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : If status_mode = 0 then revert to normal state for the user,
+ ID_STATUS_ONLINE is possible if PF1_VISLIST
+ ID_STATUS_ONLINE is possible if PF1_INDIVSTATUS
+ }
+ PSS_SETAPPARENTMODE = '/SetApparentMode';
+
+ // only valid if caps support IM xfers
+
+ {
+ CCSDATA: Yes
+ wParam : HTRANSFER
+ lParam : null terminated string containing the path
+ Affect : Allow a file transfer to begin, see notes
+ Returns: A handle to the transfer to be used from now on.
+ Notes : If the path does not point to a directory then:
+ if a single file is being transfered and the protocol supports
+ file renaming (PF1_CANRENAMEFILE) then the file is given
+ this name, othewise the file is removed and file(s) are placed
+ into the resulting directory.
+ -
+ File transfers are marked by a EVENTTYPE_FILE added to the database.
+ The format is :
+ hTransfer: DWORD
+ filename(s), description: ASCIIZ
+ }
+ PSS_FILEALLOW = '/FileAllow';
+
+ {
+ CCSDATA: Yes
+ wParam : HTRANSFER
+ lparam : Pointer to a buffer to be filled with reason
+ Affect : Refuses a file transfer request
+ Returns: 0 on success, [non zero] on failure
+ }
+ PSS_FILEDENY = '/FileDeny';
+
+ {
+ CCSDATA: Yes
+ wParam : HTRANSFER
+ lParam : 0
+ Affect : Cancel an in-progress file transfer
+ Returns: 0 on success, [non zero] on failure
+ }
+ PSS_FILECANCEL = '/FileCancel';
+
+ {
+ CCSDATA: Yes
+ wParam : null terminated string containing description
+ lParam : pointer to an array of pchar's containing file paths/directories
+ Affect : Start a file(s) send, see notes
+ Returns: A HTRANSFER handle on success, NULL(0) on failur
+ Notes : All notifications are done thru acks :
+ -
+ type=ACKTYPE_FILE, if result=ACKRESULT_FAILED then
+ lParam=null terminated string containing reason
+ }
+ PSS_FILE = '/SendFile';
+
+ // Receiving Services
+ {>>/
+ Receiving Services:
+ Before a message is sent to /RecvMessage it goes through a MS_PROTO_CHAINRECV
+ which allows any other module to change data (for decryption, etc),
+ this then reaches /RecvMessage.
+
+ This does not have to be the same structure/memory contained within that
+ structure that started the chain call.
+
+ /RecvMessage adds the event to the database, any other modules who
+ are interested in what message the user will see should hook at this point.
+ />>}
+
+ {
+ CCSDATA: Yes
+ wParam : 0
+ lParam : Pointer to a TPROTORECVEVENT
+ Affect : An instant message has beeen received, see notes
+ Returns: 0
+ Notes : lParam^.lParam^.szMessage has the message, see structure above
+ stored as DB event EVENTTYPE_MESSAGE, blob contains message
+ string without null termination.
+ }
+ PSR_MESSAGE = '/RecvMessage';
+
+ {
+ CCSDATA: Yes
+ wParam : 0
+ lParam : Pointer to a TPROTORECVEVENT, see notes
+ Affect : A URL has been received
+ Notes : szMessage is encoded the same as PSS_URL
+ -
+ Stored in the database : EVENTTYPE_URL, blob contains message
+ without null termination
+ }
+ PSR_URL = '/RecvUrl';
+
+ {
+ CCSDATA: Yes
+ wParam : 0
+ lParam : Pointer to a TPROTORECVEVENT
+ Affect : Contacts have been received, see notes
+ Notes : pre.szMessage is actually a PROTOSEARCHRESULT list
+ pre.lParam is the number of contains in that list.
+ -
+ PS_ADDTOLIST can be used to add contacts to the list
+ -
+ repeat [
+ ASCIIZ userNick
+ ASCIIZ userId
+ ]
+ userNick should be a human-readable description of the user. It need not
+ be the nick, or even confined to displaying just one type of
+ information.
+ userId should be a machine-readable representation of the unique
+ protocol identifying field of the user. Because of the need to be
+ zero-terminated, binary data should be converted to text.
+ Use PS_ADDTOLISTBYEVENT to add the contacts from one of these to the list.
+ }
+ PSR_CONTACTS = '/RecvContacts';
+
+ {
+ CCSDATA: Yes
+ wParam : 0
+ lParam : Pointer to a TPROTORECVFILE
+ Affect : File(s) have been received
+ }
+ PSR_FILE = '/RecvFile';
+
+{$ENDIF}
+
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_skin.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_skin.inc new file mode 100644 index 0000000000..dabbd00960 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_skin.inc @@ -0,0 +1,120 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_SKIN}
+{$DEFINE M_SKIN}
+
+const
+
+ // event icons
+
+ SKINICON_EVENT_MESSAGE = 100;
+ SKINICON_EVENT_URL = 101;
+ SKINICON_EVENT_FILE = 102;
+
+ // other icons
+ SKINICON_OTHER_MIRANDA = 200;
+ SKINICON_OTHER_EXIT = 201;
+ SKINICON_OTHER_SHOWHIDE = 202;
+ SKINICON_OTHER_GROUPOPEN = 203; // v0.1.1.0+
+ SKINICON_OTHER_GROUPSHUT = 205; // v0.1.1.0+
+ SKINICON_OTHER_USERONLINE = 204; // v0.1.0.1+
+
+ // menu icons are owned by the module that uses them so are not and should not
+ // be skinnable. Except exit and show/hide
+
+ // status mode icons. NOTE: These are deprecated in favour of LoadSkinnedProtoIcon()
+ SKINICON_STATUS_OFFLINE = 0;
+ SKINICON_STATUS_ONLINE = 1;
+ SKINICON_STATUS_AWAY = 2;
+ SKINICON_STATUS_NA = 3;
+ SKINICON_STATUS_OCCUPIED = 4;
+ SKINICON_STATUS_DND = 5;
+ SKINICON_STATUS_FREE4CHAT = 6;
+ SKINICON_STATUS_INVISIBLE = 7;
+ SKINICON_STATUS_ONTHEPHONE = 8;
+ SKINICON_STATUS_OUTTOLUNCH = 9;
+
+type
+
+ PSKINSOUNDDESC = ^TSKINSOUNDDESC;
+ TSKINSOUNDDESC = record
+ cbSize: int;
+ { name to refer to sound when playing and in DB }
+ pszName: PChar;
+ { description to use for it in options dialog }
+ pszDescription: PChar;
+ { the default sound file to use, WITHOUT path }
+ pszDefaultFile: PChar;
+ end;
+
+const
+
+ {
+ wParam : ICON_ID
+ lParam : 0
+ Affect : Load an icon from the user's custom skin lib, or from the exe
+ if there isn't one loaded, see notes
+ Return : HICON for the new icon, do *not* DestroyIcon() the return value
+ returns NULL(0) if ICON_ID is invalid, but always success for a valid
+ ID.
+ }
+ MS_SKIN_LOADICON = 'Skin/Icons/Load';
+
+ {
+ wParam : null terminated string containing the protocol name
+ lParam : status_wanted
+ Affect : Load an icon representing the status_wanted for a particular protocol, see notes
+ Returns: an HICON for the new icon, do NOT DestroyIcon() the return value
+ returns NULL(0) on failure.
+ Notes : If wParam is NULL(0) the service will load the user's selected
+ 'all protocols' status icon
+ }
+ MS_SKIN_LOADPROTOICON = 'Skin/Icons/LoadProto';
+
+ {
+ wParam : 0
+ lParam : Pointer to a initialised SKINSOUNDDESC
+ Affect : Add a new sound so it has a default and can be changed in the options dialog
+ Returns: 0 on success, [non zero] on failure
+ }
+ MS_SKIN_ADDNEWSOUND = 'Skin/Sounds/AddNew';
+
+ {
+ wParam : 0
+ lParam : Pointer to a null terminated string containing the name of the sound to play
+ Affect : play a named sound event, play name should of been added
+ with MS_SKIN_ADDNEWSOUND, see notes
+ Notes : function will not fail, it will play the Windows
+ }
+ MS_SKIN_PLAYSOUND = 'Skin/Sounds/Play';
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Sent when the icons DLL has been changed in the options dialog
+ and everyone should remake their image lists.
+ }
+ ME_SKIN_ICONSCHANGED = 'Skin/IconsChanged';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_system.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_system.inc new file mode 100644 index 0000000000..dff5909c86 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_system.inc @@ -0,0 +1,170 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF M_SYSTEM}
+{$DEFINE M_SYSTEM}
+
+type
+
+ TMM_INTERFACE = record
+ cbSize: int;
+ _malloc: function(cbSize: Integer): Pointer; cdecl;
+ _realloc: function (pb: Pointer; cbSize: Integer): Pointer; cdecl;
+ _free: procedure(pb: Pointer); cdecl;
+ end;
+
+const
+
+ MIRANDANAME = 'Miranda';
+
+ {
+ wParam : 0
+ lParam : 0
+ affect : called after all modules have been successfully initialised
+ used to resolve double-dependencies in the module load order, see notes
+ return : 0
+ notes : Can be used to call services, etc that have not yet loaded
+ when your module has.
+ }
+ ME_SYSTEM_MODULESLOADED = 'Miranda/System/ModulesLoaded';
+
+ {
+ wParam : 0
+ lParam : 0
+ affect : called just before Miranda terminates, the database is still running
+ during this hook
+ return : 0
+ }
+ ME_SYSTEM_SHUTDOWN = 'Miranda/System/Shutdown';
+
+ {
+ wParam : 0
+ lParam : 0
+ affect : called before Miranda actually shuts down -- everyone has to agree
+ or it is not shut down.
+ return : non zero to stop the shutdown
+ }
+ ME_SYSTEM_OKTOEXIT = 'Miranda/System/OkToExitEvent';
+
+ {
+ wParam : 0
+ lParam : 0
+ affect : service which sends everyone the ME_SYSTEM_OKTOEXIT event
+ return : true if everyone is okay to exit, otherwise false
+ }
+ MS_SYSTEM_OKTOEXIT = 'Miranda/System/OkToExit';
+
+ {
+ wParam : 0
+ lParam : 0
+ return : returns the version number -- each byte set with version index,
+ e.g. 1.2.3.4 $01020304
+ }
+ MS_SYSTEM_GETVERSION = 'Miranda/System/GetVersion';
+
+ {
+ wParam : size in bytes of the buffer to be filled
+ lParam : pointer to the buffer to be filled
+ affect : returns Miranda's version as text with build type such as '1.2.3.4 alpha'
+ return : 0 on success -- non zero on failure
+ }
+ MS_SYSTEM_GETVERSIONTEXT = 'Miranda/System/GetVersionText';
+
+ {
+ wParam : Handle of a wait object to be used
+ lParam : pointer to service name
+ affect : causes the service name to be called whenever the wait object
+ is signalled with CallService(Service, wParam=hWaitObjeect, lParam=0)
+ return : 0 on success, non zero on failure, will always fail if
+ more than 64 event objects are already being waited on because
+ of the limit imposed by Windows.
+ version: implemented after v0.1.2.0+
+ other : QueueUserAPC() can be used instead of this service to wait
+ for notifications, BUT *only* after v0.1.2.2+ since that deals
+ with APC's
+ }
+ MS_SYSTEM_WAITONHANDLE = 'Miranda/System/WaitOnHandle';
+
+ {
+ wParam : hWaitObject to be removed
+ lParam : 0
+ affect : removes the wait object from the list, see above.
+ returns: 0 on success, nonzero on failure
+ version: implemented after v0.1.2.0+
+ }
+ MS_SYSTEM_REMOVEWAIT = 'Miranda/System/RemoveWait';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initialised TMM_INTERFACE
+ affect : Get function pointers to, malloc(), free() and realloc() used by Miranda
+ note : this should only be used carefully, make sure .cbSize is initialised with sizeof(TMM_INTERFACE)
+ version: 0.1.2.2+
+ }
+ MS_SYSTEM_GET_MMI = 'Miranda/System/GetMMI';
+
+ {
+ wParam=0
+ lParam=0
+
+ Add a thread to the unwind wait stack that Miranda will poll on
+ when it is tearing down modules.
+
+ This must be called in the context of the thread that is to be pushed
+ i.e. there are no args, it works out what thread is being called
+ and gets itself a handle to the calling thread.
+ }
+ MS_SYSTEM_THREAD_PUSH = 'Miranda/Thread/Push';
+
+ {
+ wParam=0
+ lParam=0
+
+ Remove a thread from the unwind wait stack -- it is expected
+ that the call be made in the context of the thread to be removed.
+
+ Miranda will begin to tear down modules and plugins if/when the
+ last thread from the unwind stack is removed.
+ }
+ MS_SYSTEM_THREAD_POP = 'Miranda/Thread/Pop';
+
+ {
+ wParam=0
+ lParam=0
+
+ This hook is fired just before the thread unwind stack is used,
+ it allows MT plugins to shutdown threads if they have any special
+ processing to do, etc.
+ }
+ ME_SYSTEM_PRESHUTDOWN = 'Miranda/System/PShutdown';
+
+ {
+ wParam=0
+ lParam=0
+
+ Returns TRUE when Miranda has got WM_QUIT and is in the process
+ of shutting down
+ }
+ MS_SYSTEM_TERMINATED = 'Miranda/SysTerm';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_url.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_url.inc new file mode 100644 index 0000000000..c991d2a68c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_url.inc @@ -0,0 +1,39 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_URL}
+{$DEFINE M_URL}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affects: bring up the send URL dialogbox for a user
+ Returns: 0 on success, nonzero on failure, see notes
+ Notes : service returns before the URL is sent.
+ }
+ MS_URL_SENDURL = 'SRUrl/SendCommand';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_userinfo.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_userinfo.inc new file mode 100644 index 0000000000..4ea8a90563 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_userinfo.inc @@ -0,0 +1,84 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_USERINFO}
+{$DEFINE M_USERINFO}
+
+const
+
+ {
+ wParam : HCONTACT
+ lParam : 0
+ Affects: Show the user details dialog box for a contact, see notes
+ Notes : I think this can be used to display "My User Details"... if NULL(0) is used
+ }
+ MS_USERINFO_SHOWDIALOG = 'UserInfo/ShowDialog';
+
+ {
+ wParam : 0
+ lParam : HCONTACT
+ Affects: The details dialog box was opened for a contact maybe NULL(0)
+ showing the user details -- see notes
+ Notes : The module should do whatever initialisation they need and
+ call MS_USERINFO_ADDPAGE one or more times if they want
+ pages displayed in the options dialog -- wParam should be passed
+ straight as the wParam of MS_USERINFO_ADDPAGE.
+ -
+ The builtin userinfo module is not loaded til after all plugins
+ have loaded -- therefore a HookEvent() for this event will fail,
+ use ME_SYSTEM_MODULESLOADED event to know when everything has
+ loaded and it's okay to hook this event.
+ Version: v0.1.2.0+
+ }
+ ME_USERINFO_INITIALISE = 'UserInfo/Initialise';
+
+ {
+ wParam : wParam from ME_USERINFO_INITIALISE
+ lParam : pointer to an initialised OPTIONSDIALOGPAGE (see m_options.inc)
+ Affects: Adds a page to the details dialog, see notes
+ Notes : this service should only be called within the ME_USERINFO_INITIALISE
+ event -- when the pages get (WM_INITDIALOG lParam=HCONTACT) strings
+ in the passed dialog structure can be freed soon as the service returns
+ icons must be kept around (not a problem if you're loading from resource).
+ -
+ The group elements within the OPTIONSDIALOGPAGE are ignored,
+ details dialog page should be 222x132 DLU's -- the details dialog
+ box currently has no cancel button, pages will be sent PSN_INFOCHANGED
+ thru WM_NOTIFY (idFrom=0) when a protocol ACK is broadcast for
+ the correct contact with the type ACKTYPE_GETINFO.
+ -
+ PSN_INFOCHANGED will also be sent just after the page is created
+ to help you out.
+ -
+ All PSN_* WM_NOTIFY messages have PSHNOTIFY.lParam=(LPARAM)hContact
+ Version: v0.1.2.0+
+ }
+
+ PSN_INFOCHANGED = 1;
+ { force-send a PSN_INFOCHANGED to all pages }
+ PSM_FORCECHANGED = ($0400 + 100);
+
+ MS_USERINFO_ADDPAGE = 'UserInfo/AddPage';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_utils.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_utils.inc new file mode 100644 index 0000000000..b0cabfff44 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/m_utils.inc @@ -0,0 +1,279 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF M_UTILS}
+{$DEFINE M_UTILS}
+
+const
+
+ RD_ANCHORX_CUSTOM = 0; // function did everything required to the x axis, do no more processing
+ RD_ANCHORX_LEFT = 0; // move the control to keep it constant distance from the left edge of the dialog
+ RD_ANCHORX_RIGHT = 1; // move the control to keep it constant distance from the right edge of the dialog
+ RD_ANCHORX_WIDTH = 2; // size the control to keep it constant distance from both edges of the dialog
+ RD_ANCHORX_CENTRE = 4; // move the control to keep it constant distance from the centre of the dialog
+ RD_ANCHORY_CUSTOM = 0;
+ RD_ANCHORY_TOP = 0;
+ RD_ANCHORY_BOTTOM = 8;
+ RD_ANCHORY_HEIGHT = 16;
+ RD_ANCHORY_CENTRE = 32;
+
+ // for MS_UTILS_RESTOREWINDOWPOSITION
+
+ RWPF_NOSIZE = 1; // don't use stored size info: leave dialog same size
+ RWPF_NOMOVE = 2; // don't use stored position
+
+ // for WNDCLASS_COLOURPICKER
+
+ CPM_SETCOLOUR = $1000;// lParam=new colour
+ CPM_GETCOLOUR = $1001;// returns colour
+ CPM_SETDEFAULTCOLOUR = $1002;// lParam=default, used as first custom colour
+ CPM_GETDEFAULTCOLOUR = $1003;// returns colour
+ CPN_COLOURCHANGED = 1; // sent through WM_COMMAND
+
+type
+
+ PUTILRESIZECONTROL = ^TUTILRESIZECONTROL;
+ TUTILRESIZECONTROL = record
+ cbSize: int;
+ wId: int; // control ID
+ rcItem: TRect; // original control rectangle, relative to dialog
+ // modify in-placee to specify the new position
+ dlgOriginalSize: TSize; // size of dialog client area in template
+ dlgNewSize: TSize; // current size of dialog client area
+ end;
+
+ TDIALOGRESIZERPROC = function(hwndDlg: THandle; lParam: LPARAM; urc: PUTILRESIZECONTROL): int; cdecl;
+
+ PUTILRESIZEDIALOG = ^TUTILRESIZEDIALOG;
+ TUTILRESIZEDIALOG = record
+ cbSize: int;
+ hwndDlg: THandle;
+ hInstance: THandle;
+ lpTemplate: PChar;
+ lParam: LPARAM;
+ pfnResizer: TDIALOGRESIZERPROC;
+ end;
+
+ PCountryListEntry = ^TCountryListEntry;
+ TCountryListEntry = record
+ id: int;
+ szName: PChar;
+ end;
+
+ PWINDOWLISTENTRY = ^TWINDOWLISTENTRY;
+ TWINDOWLISTENTRY = record
+ hList: THandle;
+ hWnd: THandle;
+ hContact: THandle;
+ end;
+
+ PSAVEWINDOWPOS = ^TSAVEWINDOWPOS;
+ TSAVEWINDOWPOS = record
+ hWnd: THandle;
+ hContact: THandle;
+ szModule: PChar; // module name eto store the settings in
+ szNamePrefix: PChar; // text to prefix on 'x', 'width', etc
+ end;
+
+const
+
+ {
+ wParam : bOpenInNewWindow
+ lParam : Pointer to a null terminated string containing Url
+ Affect : Open a URRL in the user's default web browser, see notes
+ Returns: 0 on success, [non zero on failure]
+ Notes : bOpenInWindow should be zero to open the URL in the browoser window
+ the user last used, or nonzero to open in a new browser window,
+ if there's no browser running, it will be started to show the URL
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_OPENURL = 'Utils/OpenURL';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised TUTILRESIZEDIALOG structure
+ Affect : Resize a dialog by calling a custom routine to move each control, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : Does not support DIALOGTEMPLATEEX dialogboxes, and will return
+ failure if you try to resize one.-
+ the dialog iteself should have been resized prior to calling this
+ service, .pfnResizer is called once for each control in the dialog
+ .pfnResizer should return a combination of one RD_ANCHORx_ and one RD_ANCHORy constant
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_RESIZEDIALOG = 'Utils/ResizeDialog';
+
+ {
+ wParam : countryID
+ lParam : 0
+ Affect : Get the name of a country given it's number, e.g. 44 = UK
+ Returns: Returns a pointer to a string containing the country name on success
+ NULL(0) on failure
+ Version: v0.1.2.0+
+ }
+ MS_UTILS_GETCOUNTRYBYNUMBER = 'Utils/GetCountryByNumber';
+
+ {
+ wParam : Pointer to an int to be filled with count -- !TODO! test.
+ lParam : Pointer to an PCountryListEntry, see notes
+ Affect : Get the full list of country IDs, see notes
+ Returns: 0 always
+ Notes : the list is sorted alphabetically by name, on the assumption
+ it's quicker to search numbers that are out of outer, than strings
+ that are out of order. a NULL(0) entry terminates
+ -
+ Neither wParam or lParam can be NULL(0)
+ -
+ lParam is filled with the first entry, it can be accessed as a pointer,
+ to get the next entry, increment the pointer by sizeof(Pointer) NOT
+ sizeof(TCountryList), only increment the pointer as many times as
+ given by iCount.
+ -
+ this data can NOT be copied if an array of TCountryListEntry's is passed
+ so don't try it.
+ Version: v0.1.2.0+
+ }
+ MS_UTILS_GETCOUNTRYLIST = 'Utils/GetCountryList';
+
+ // see WindowList_* functions below
+
+ {
+ wParam : 0
+ lParam : 0
+ Affect : Allocate a window list
+ Returns: A handle to the new window list
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_ALLOCWINDOWLIST = 'Utils/AllocWindowList';
+
+ {
+ wParam : 0
+ lParam : Pointer to an initalised TWINDOWLISTENTRY structure
+ Affect : Add a window to a given window list handle
+ Returns: 0 on success, [non zero] on failure
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_ADDTOWINDOWLIST = 'Utils/AddToWindowList';
+
+ {
+ wParam : Handle to window list to remove from
+ lParam : Window handle to remove
+ Affect : Remove a window from the specified window list
+ Returns: 0 on success, [non zero] on failure
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_REMOVEFROMWINDOWLIST = 'Utils/RemoveFromWindowList';
+
+ {
+ wParam : Handle to the window list to look in
+ lParam : Handle to a HCONTACT to find in the window list
+ Affect : Find a window handle given the hContact
+ Returns: The found window handle or NULL(0) on failure
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_FINDWINDOWINLIST = 'Utils/FindWindowInList';
+
+ {
+ wParam : Handle to window list
+ lParam : Pointer to TMSG (initalised with what to broadcast)
+ Affect : Broadcast a message to all windows in a list, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : only TMSG.Message, .wParam, .lParam are used
+ Version: v0.1.0.1+
+ }
+ MS_UTILS_BROADCASTTOWINDOWLIST = 'Utils/BroadcastToWindowList';
+
+ {
+ There aren't any services here, there's no need for them, the control class
+ will obey the SS_LEFT (0), SS_CENTER (1), SS_RIGHT(2) styles
+ the control will send STN_CLICKED via WM_COMMAND when the link itself is clicked
+ -
+ These are defined by STATIC controls and STN_CLICKED is sent to standard
+ STATIC classes when they're clicked -- look at WINAPI docs for more info
+ }
+ WNDCLASS_HYPERLINK = 'Hyperlink';
+
+ {
+ wParam : 0
+ lParam : Pointer to a initialised TSAVEWINDOWPOS structure
+ Affect :
+ Returns: 0 on success, [non zero] on failure
+ Notes :
+ Version: v0.1.1.0+
+ }
+ MS_UTILS_SAVEWINDOWPOSITION = 'Utils/SaveWindowPos';
+
+ {
+ wParam : see RWPF_* flags
+ lParam : Pointer to a initalised TSAVEWINDOWPOS
+ Affect : Restores the position of a window from the database, see notes
+ Returns: 0 on success, [non zero] on failure
+ Notes : If no position info was found, the service will return 1.
+ The NoSize version won't use stored information size, the window
+ is left the same size
+ -
+ See Utils_RestoreWindowPosition() Helper function, this function is
+ a bit different from the C function (which can be inlined too! dammit)
+ that there's only one function and not three (which just passed different flags)
+ Version: v0.1.1.0+
+ }
+ MS_UTILS_RESTOREWINDOWPOSITION = 'Utils/RestoreWindowPos';
+
+ {
+ Colour picker control, see CPM_* and CPN_* constants above
+ }
+ WNDCLASS_COLOURPICKER = 'ColourPicker';
+
+ {
+ wParam : 0
+ lParam : Pointer to a null terminated string containing filename
+ Affect : Loads a bitmap (or other graphic type, see Notes
+ Returns: HBITMAP on success, NULL(0) on failure
+ Notes : This function also supports JPEG, GIF (and maybe PNG too)
+ For speed, if the file extention is .bmp or .rle it will use LoadImage()
+ and not load OLE for the extra image support
+ -
+ Remember to delete the returned handle with DeleteObject (see GDI documentation for WINAPI)
+ Version: v0.1.2.1+
+ }
+ MS_UTILS_LOADBITMAP = 'Utils/LoadBitmap';
+
+ {
+ wParam : byte length of buffer (not to be confused with byte range)
+ lParam : Pointer to buffer
+ Affect : Get the filter strings for use in the open file dialog, see notes
+ Returns: 0 on success [non zero] on failure
+ Notes : See the WINAPI under OPENFILENAME.lpStrFiler for formatting,
+ an 'All bitmaps' item is alway first, and 'All files' is always last
+ -
+ The returned string is always formatted
+ -
+ To build this filter, the filter string consists of
+ filter followed by a descriptive text
+ followed by more filters and their descriptive texts -- end with double NULL(0)
+ e.g. *.bmp' #0 'All bitmaps' #0 '*.*' #0 'All Files' #0 #0
+ }
+ MS_UTILS_GETBITMAPFILTERSTRINGS = 'Utils/GetBitmapFilterStrings';
+
+{$endif}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.h b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.h new file mode 100644 index 0000000000..bd937757f8 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.h @@ -0,0 +1,282 @@ +/*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2008 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*/
+
+#ifndef M_NEWPLUGINAPI_H__
+#define M_NEWPLUGINAPI_H__
+
+#include "m_plugins.h"
+
+#define PLUGIN_MAKE_VERSION(a,b,c,d) (((((DWORD)(a))&0xFF)<<24)|((((DWORD)(b))&0xFF)<<16)|((((DWORD)(c))&0xFF)<<8)|(((DWORD)(d))&0xFF))
+#define MAXMODULELABELLENGTH 64
+
+#if defined( _UNICODE )
+ #define UNICODE_AWARE 1
+#else
+ #define UNICODE_AWARE 0
+#endif
+
+typedef struct {
+ int cbSize;
+ char *shortName;
+ DWORD version;
+ char *description; // [TRANSLATED-BY-CORE]
+ char *author;
+ char *authorEmail;
+ char *copyright;
+ char *homepage;
+ BYTE flags; // right now the only flag, UNICODE_AWARE, is recognized here
+ int replacesDefaultModule; //one of the DEFMOD_ constants in m_plugins.h or zero
+ //if non-zero, this will supress the loading of the specified built-in module
+ //with the implication that this plugin provides back-end-compatible features
+} PLUGININFO;
+
+/* 0.7+
+ New plugin loader implementation
+*/
+/* The UUID structure below is used to for plugin UUID's and module type definitions */
+typedef struct _MUUID {
+ unsigned long a;
+ unsigned short b;
+ unsigned short c;
+ unsigned char d[8];
+} MUUID;
+
+
+/* Used to define the end of the MirandaPluginInterface list */
+#define MIID_LAST {0, 0, 0, {0, 0, 0, 0, 0, 0, 0, 0}}
+
+/* Replaceable internal modules interface ids */
+#define MIID_HISTORY {0x5ca0cbc1, 0x999a, 0x4ea2, {0x8b, 0x44, 0xf8, 0xf6, 0x7d, 0x7f, 0x8e, 0xbe}}
+#define MIID_UIFINDADD {0xb22c528d, 0x6852, 0x48eb, {0xa2, 0x94, 0xe, 0x26, 0xa9, 0x16, 0x12, 0x13}}
+#define MIID_UIUSERINFO {0x570b931c, 0x9af8, 0x48f1, {0xad, 0x9f, 0xc4, 0x49, 0x8c, 0x61, 0x8a, 0x77}}
+#define MIID_SRURL {0x5192445c, 0xf5e8, 0x46c0, {0x8f, 0x9e, 0x2b, 0x6d, 0x43, 0xe5, 0xc7, 0x53}}
+#define MIID_SRAUTH {0x377780b9, 0x2b3b, 0x405b, {0x9f, 0x36, 0xb3, 0xc4, 0x87, 0x8e, 0x6f, 0x33)}
+#define MIID_SRAWAY {0x5ab54c76, 0x1b4c, 0x4a00, {0xb4, 0x4, 0x48, 0xcb, 0xea, 0x5f, 0xef, 0xe7}}
+#define MIID_SREMAIL {0xd005b5a6, 0x1b66, 0x445a, {0xb6, 0x3, 0x74, 0xd4, 0xd4, 0x55, 0x2d, 0xe2}}
+#define MIID_SRFILE {0x989d104d, 0xacb7, 0x4ee0, {0xb9, 0x6d, 0x67, 0xce, 0x46, 0x53, 0xb6, 0x95}}
+#define MIID_UIHELP {0xf2d35c3c, 0x861a, 0x4cc3, {0xa7, 0x8f, 0xd1, 0xf7, 0x85, 0x4, 0x41, 0xcb}}
+#define MIID_UIHISTORY {0x7f7e3d98, 0xce1f, 0x4962, {0x82, 0x84, 0x96, 0x85, 0x50, 0xf1, 0xd3, 0xd9}}
+#define MIID_AUTOAWAY {0x9c87f7dc, 0x3bd7, 0x4983, {0xb7, 0xfb, 0xb8, 0x48, 0xfd, 0xbc, 0x91, 0xf0}}
+#define MIID_USERONLINE {0x130829e0, 0x2463, 0x4ff8, {0xbb, 0xc8, 0xce, 0x73, 0xc0, 0x18, 0x84, 0x42}}
+#define MIID_IDLE {0x296f9f3b, 0x5b6f, 0x40e5, {0x8f, 0xb0, 0xa6, 0x49, 0x6c, 0x18, 0xbf, 0xa}}
+#define MIID_FONTSERVICE {0x56f39112, 0xe37f, 0x4234, {0xa9, 0xe6, 0x7a, 0x81, 0x17, 0x45, 0xc1, 0x75)}
+#define MIID_UPDATENOTIFY {0x4e68b12a, 0x6b54, 0x44de, {0x86, 0x37, 0xf1, 0x12, 0xd, 0xb6, 0x81, 0x40}}
+
+/* Common plugin interfaces (core plugins) */
+#define MIID_DATABASE {0xae77fd33, 0xe484, 0x4dc7, {0x8c, 0xbc, 0x9, 0x9f, 0xed, 0xcc, 0xcf, 0xdd}}
+#define MIID_CLIST {0x9d8da8bf, 0x665b, 0x4908, {0x9e, 0x61, 0x9f, 0x75, 0x98, 0xae, 0x33, 0xe}}
+#define MIID_CHAT {0x23576a43, 0x3a26, 0x4357, {0x9b, 0x1b, 0x4a, 0x71, 0x9e, 0x42, 0x5d, 0x48}}
+#define MIID_SRMM {0x58c7eea6, 0xf9db, 0x4dd9, {0x80, 0x36, 0xae, 0x80, 0x2b, 0xc0, 0x41, 0x4c}}
+#define MIID_IMPORT {0x5f3bcad4, 0x75f8, 0x476e, {0xb3, 0x6b, 0x2b, 0x30, 0x70, 0x32, 0x49, 0xc}}
+#define MIID_IMGSERVICES {0xf3974915, 0xc9d5, 0x4c87, {0x85, 0x64, 0xa0, 0xeb, 0xf9, 0xd2, 0x5a, 0xa0}}
+#define MIID_TESTPLUGIN {0x53b974f4, 0x3c74, 0x4dba, {0x8f, 0xc2, 0x6f, 0x92, 0xfe, 0x1, 0x3b, 0x8c}}
+
+/* Common plugin interfaces (non-core plugins) */
+#define MIID_VERSIONINFO {0xcfeb6325, 0x334e, 0x4052, {0xa6, 0x45, 0x56, 0x21, 0x93, 0xdf, 0xcc, 0x77}}
+#define MIID_FOLDERS {0xcfebec29, 0x39ef, 0x4b62, {0xad, 0x38, 0x9a, 0x65, 0x2c, 0xa3, 0x24, 0xed}}
+#define MIID_BIRTHDAYNOTIFY {0xcfba5784, 0x3701, 0x4d83, {0x81, 0x6a, 0x19, 0x9c, 0x00, 0xd4, 0xa6, 0x7a}}
+#define MIID_BONSAI {0xcfaae811, 0x30e1, 0x4a4f, {0x87, 0x84, 0x15, 0x3c, 0xcc, 0xb0, 0x03, 0x7a}}
+#define MIID_EXCHANGE {0xcfd79a89, 0x9959, 0x4e65, {0xb0, 0x76, 0x41, 0x3f, 0x98, 0xfe, 0x0d, 0x15}}
+#define MIID_MIRPY {0xcff91a5c, 0x1786, 0x41c1, {0x88, 0x86, 0x09, 0x4b, 0x14, 0x28, 0x1f, 0x15}}
+#define MIID_SERVICESLIST {0xcf4bdf02, 0x5d27, 0x4241, {0x99, 0xe5, 0x19, 0x51, 0xaa, 0xb0, 0xc4, 0x54}}
+#define MIID_TRANSLATOR {0xcfb637b0, 0x7217, 0x4c1e, {0xb2, 0x2a, 0xd9, 0x22, 0x32, 0x3a, 0x5d, 0x0b}}
+#define MIID_TOOLTIPS {0xbcbda043, 0x2716, 0x4404, {0xb0, 0xfa, 0x3d, 0x2d, 0x93, 0x81, 0x9e, 0x3}}
+#define MIID_POPUPS {0x33299069, 0x1919, 0x4ff8, {0xb1, 0x31, 0x1d, 0x7, 0x21, 0x78, 0xa7, 0x66}}
+#define MIID_LOGWINDOW {0xc53afb90, 0xfa44, 0x4304, {0xbc, 0x9d, 0x6a, 0x84, 0x1c, 0x39, 0x05, 0xf5}}
+#define MIID_EVENTNOTIFY {0xF3D7EC5A, 0xF7EF, 0x45DD, {0x8C, 0xA5, 0xB0, 0xF6, 0xBA, 0x18, 0x64, 0x7B}}
+#define MIID_SRCONTACTS {0x7CA6050E, 0xBAF7, 0x42D2, {0xB9, 0x36, 0x0D, 0xB9, 0xDF, 0x57, 0x2B, 0x95}}
+#define MIID_HISTORYEXPORT {0x18fa2ade, 0xe31b, 0x4b5d, {0x95, 0x3d, 0xa, 0xb2, 0x57, 0x81, 0xc6, 0x4}}
+
+/* Special exception interface for protocols.
+ This interface allows more than one plugin to implement it at the same time
+*/
+#define MIID_PROTOCOL {0x2a3c815e, 0xa7d9, 0x424b, {0xba, 0x30, 0x2, 0xd0, 0x83, 0x22, 0x90, 0x85}}
+
+#define MIID_SERVICEMODE {0x8a92c026, 0x953a, 0x4f5f, { 0x99, 0x21, 0xf2, 0xc2, 0xdc, 0x19, 0x5e, 0xc5}}
+
+/* Each service mode plugin must implement MS_SERVICEMODE_LAUNCH */
+#define MS_SERVICEMODE_LAUNCH "ServiceMode/Launch"
+
+typedef struct {
+ int cbSize;
+ char *shortName;
+ DWORD version;
+ char *description;
+ char *author;
+ char *authorEmail;
+ char *copyright;
+ char *homepage;
+ BYTE flags; // right now the only flag, UNICODE_AWARE, is recognized here
+ int replacesDefaultModule; //one of the DEFMOD_ constants in m_plugins.h or zero
+ //if non-zero, this will supress the loading of the specified built-in module
+ //with the implication that this plugin provides back-end-compatible features
+ /*********** WILL BE DEPRECATED in 0.8 * *************/
+ MUUID uuid; // Not required until 0.8.
+} PLUGININFOEX;
+
+#ifndef MODULES_H_
+ typedef int (*MIRANDAHOOK)(WPARAM,LPARAM);
+ typedef int (*MIRANDAHOOKPARAM)(WPARAM,LPARAM,LPARAM);
+ typedef int (*MIRANDAHOOKOBJ)(void*,WPARAM,LPARAM);
+ typedef int (*MIRANDAHOOKOBJPARAM)(void*,WPARAM,LPARAM,LPARAM);
+
+ typedef int (*MIRANDASERVICE)(WPARAM,LPARAM);
+ typedef int (*MIRANDASERVICEPARAM)(WPARAM,LPARAM,LPARAM);
+ typedef int (*MIRANDASERVICEOBJ)(void*,LPARAM,LPARAM);
+ typedef int (*MIRANDASERVICEOBJPARAM)(void*,WPARAM,LPARAM,LPARAM);
+
+ #define CALLSERVICE_NOTFOUND ((int)0x80000000)
+#endif
+
+//see modules.h for what all this stuff is
+typedef struct {
+ HANDLE (*CreateHookableEvent)(const char *);
+ int (*DestroyHookableEvent)(HANDLE);
+ int (*NotifyEventHooks)(HANDLE,WPARAM,LPARAM);
+ HANDLE (*HookEvent)(const char *,MIRANDAHOOK);
+ HANDLE (*HookEventMessage)(const char *,HWND,UINT);
+ int (*UnhookEvent)(HANDLE);
+ HANDLE (*CreateServiceFunction)(const char *,MIRANDASERVICE);
+ HANDLE (*CreateTransientServiceFunction)(const char *,MIRANDASERVICE);
+ int (*DestroyServiceFunction)(HANDLE);
+ int (*CallService)(const char *,WPARAM,LPARAM);
+ int (*ServiceExists)(const char *); //v0.1.0.1+
+ int (*CallServiceSync)(const char *,WPARAM,LPARAM); //v0.3.3+
+ int (*CallFunctionAsync) (void (__stdcall *)(void *), void *); //v0.3.4+
+ int (*SetHookDefaultForHookableEvent) (HANDLE, MIRANDAHOOK); // v0.3.4 (2004/09/15)
+ HANDLE (*CreateServiceFunctionParam)(const char *,MIRANDASERVICEPARAM,LPARAM); // v0.7+ (2007/04/24)
+ int (*NotifyEventHooksDirect)(HANDLE,WPARAM,LPARAM); // v0.7+
+ #if MIRANDA_VER >= 0x800
+ int (*CallProtoService)(const char *, const char *, WPARAM, LPARAM );
+ int (*CallContactService)( HANDLE, const char *, WPARAM, LPARAM );
+ HANDLE (*HookEventParam)(const char *,MIRANDAHOOKPARAM,LPARAM);
+ HANDLE (*HookEventObj)(const char *,MIRANDAHOOKOBJ, void* );
+ HANDLE (*HookEventObjParam)(const char *, MIRANDAHOOKOBJPARAM, void*, LPARAM);
+ HANDLE (*CreateServiceFunctionObj)(const char *,MIRANDASERVICEOBJ,void*);
+ HANDLE (*CreateServiceFunctionObjParam)(const char *,MIRANDASERVICEOBJPARAM,void*,LPARAM);
+ #endif
+} PLUGINLINK;
+
+#ifndef MODULES_H_
+ #ifndef NODEFINEDLINKFUNCTIONS
+ //relies on a global variable 'pluginLink' in the plugins
+ extern PLUGINLINK *pluginLink;
+ #define CreateHookableEvent(a) pluginLink->CreateHookableEvent(a)
+ #define DestroyHookableEvent(a) pluginLink->DestroyHookableEvent(a)
+ #define NotifyEventHooks(a,b,c) pluginLink->NotifyEventHooks(a,b,c)
+ #define HookEventMessage(a,b,c) pluginLink->HookEventMessage(a,b,c)
+ #define HookEvent(a,b) pluginLink->HookEvent(a,b)
+ #define UnhookEvent(a) pluginLink->UnhookEvent(a)
+ #define CreateServiceFunction(a,b) pluginLink->CreateServiceFunction(a,b)
+ #define CreateTransientServiceFunction(a,b) pluginLink->CreateTransientServiceFunction(a,b)
+ #define DestroyServiceFunction(a) pluginLink->DestroyServiceFunction(a)
+ #define CallService(a,b,c) pluginLink->CallService(a,b,c)
+ #define ServiceExists(a) pluginLink->ServiceExists(a)
+ #define CallServiceSync(a,b,c) pluginLink->CallServiceSync(a,b,c)
+ #define CallFunctionAsync(a,b) pluginLink->CallFunctionAsync(a,b)
+ #define SetHookDefaultForHookableEvent(a,b) pluginLink->SetHookDefaultForHookableEvent(a,b)
+ #define CreateServiceFunctionParam(a,b,c) pluginLink->CreateServiceFunctionParam(a,b,c)
+ #define NotifyEventHooksDirect(a,b,c) pluginLink->NotifyEventHooksDirect(a,b,c)
+ #if MIRANDA_VER >= 0x800
+ #define CallProtoService(a,b,c,d) pluginLink->CallProtoService(a,b,c,d)
+ #define CallContactService(a,b,c,d) pluginLink->CallContactService(a,b,c,d)
+ #define HookEventParam(a,b,c) pluginLink->HookEventParam(a,b,c)
+ #define HookEventObj(a,b,c) pluginLink->HookEventObj(a,b,c)
+ #define HookEventObjParam(a,b,c,d) pluginLink->HookEventObjParam(a,b,c,d)
+ #define CreateServiceFunctionObj(a,b,c) pluginLink->CreateServiceFunctionObj(a,b,c)
+ #define CreateServiceFunctionObjParam(a,b,c,d) pluginLink->CreateServiceFunctionObjParam(a,b,c,d)
+ #endif
+ #endif
+#endif
+
+/*
+ Database plugin stuff
+*/
+
+// grokHeader() error codes
+#define EGROKPRF_NOERROR 0
+#define EGROKPRF_CANTREAD 1 // can't open the profile for reading
+#define EGROKPRF_UNKHEADER 2 // header not supported, not a supported profile
+#define EGROKPRF_VERNEWER 3 // header correct, version in profile newer than reader/writer
+#define EGROKPRF_DAMAGED 4 // header/version fine, other internal data missing, damaged.
+
+// makeDatabase() error codes
+#define EMKPRF_CREATEFAILED 1 // for some reason CreateFile() didnt like something
+
+typedef struct {
+ int cbSize;
+
+ /*
+ returns what the driver can do given the flag
+ */
+ int (*getCapability) ( int flag );
+
+ /*
+ buf: pointer to a string buffer
+ cch: length of buffer
+ shortName: if true, the driver should return a short but descriptive name, e.g. "3.xx profile"
+ Affect: The database plugin must return a "friendly name" into buf and not exceed cch bytes,
+ e.g. "Database driver for 3.xx profiles"
+ Returns: 0 on success, non zero on failure
+ */
+ int (*getFriendlyName) ( char * buf, size_t cch, int shortName );
+
+ /*
+ profile: pointer to a string which contains full path + name
+ Affect: The database plugin should create the profile, the filepath will not exist at
+ the time of this call, profile will be C:\..\<name>.dat
+ Note: Do not prompt the user in anyway about this operation.
+ Note: Do not initialise internal data structures at this point!
+ Returns: 0 on success, non zero on failure - error contains extended error information, see EMKPRF_*
+ */
+ int (*makeDatabase) ( char * profile, int * error );
+
+ /*
+ profile: [in] a null terminated string to file path of selected profile
+ error: [in/out] pointer to an int to set with error if any
+ Affect: Ask the database plugin if it supports the given profile, if it does it will
+ return 0, if it doesnt return 1, with the error set in error -- EGROKPRF_* can be valid error
+ condition, most common error would be [EGROKPRF_UNKHEADER]
+ Note: Just because 1 is returned, doesnt mean the profile is not supported, the profile might be damaged
+ etc.
+ Returns: 0 on success, non zero on failure
+ */
+ int (*grokHeader) ( char * profile, int * error );
+
+ /*
+ Affect: Tell the database to create all services/hooks that a 3.xx legecy database might support into link,
+ which is a PLUGINLINK structure
+ Returns: 0 on success, nonzero on failure
+ */
+ int (*Load) ( char * profile, void * link );
+
+ /*
+ Affect: The database plugin should shutdown, unloading things from the core and freeing internal structures
+ Returns: 0 on success, nonzero on failure
+ Note: Unload() might be called even if Load() was never called, wasLoaded is set to 1 if Load() was ever called.
+ */
+ int (*Unload) ( int wasLoaded );
+
+} DATABASELINK;
+
+#endif // M_NEWPLUGINAPI_H__
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.inc new file mode 100644 index 0000000000..44a4a9ef51 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/newpluginapi.inc @@ -0,0 +1,209 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+{$IFNDEF NEWPLUGINAPI}
+{$DEFINE NEWPLUGINAPI}
+
+const
+
+ MAXMODULELABELLENGTH = 64;
+
+type
+
+ PPLUGININFO = ^TPLUGININFO;
+ TPLUGININFO = record
+ cbSize: int;
+ shortName: PChar;
+ version: DWORD;
+ description: PChar;
+ author: PChar;
+ authorEmail: PChar;
+ copyright: PChar;
+ homepage: PChar;
+ isTransient: Byte; // leave zero for now
+ { one of the DEFMOD_* consts in m_plugin or zero, if non zero, this will
+ suppress loading of the specified builtin module }
+ replacesDefaultModule: int;
+ end;
+
+ PPLUGININFOEX = ^TPLUGININFOEX;
+ TPLUGININFOEX = record
+ cbSize: int;
+ shortName: PChar;
+ version: DWORD;
+ description: PChar;
+ author: PChar;
+ authorEmail: PChar;
+ copyright: PChar;
+ homepage: PChar;
+ isTransient: Byte; // leave zero for now
+ { one of the DEFMOD_* consts in m_plugin or zero, if non zero, this will
+ suppress loading of the specified builtin module }
+ replacesDefaultModule: int;
+ uuid: TGUID;
+ end;
+
+ { modules.h is never defined -- no check needed }
+
+ TMIRANDAHOOK = function(wParam: WPARAM; lParam: LPARAM): int; cdecl;
+ TMIRANDASERVICE = function(wParam: WPARAM; lParam: LPARAM): int; cdecl;
+
+ {**************************hook functions****************************}
+ (* TCreateHookableEvent
+ Adds an named event to the list and returns a handle referring to it, or NIL
+ on failure. Will be automatically destroyed on exit, or can be removed from the
+ list earlier using TDestroyHookableEvent()
+ Will fail if the given name has already been used
+ *)
+ TCreateHookableEvent = function(const char: PChar): THandle; cdecl;
+
+ (* TDestroyHookableEvent
+ Removes the event Handle from the list of events. All modules hooked to it are
+ automatically unhooked. TNotifyEventHooks() will fail if called with this hEvent
+ again. Handle must have been returned by CreateHookableEvent()
+ Returns 0 on success, or nonzero if Handle is invalid
+ *)
+ TDestroyHookableEvent = function(Handle: THandle): int; cdecl;
+
+ (* TNotifyEventHooks
+ Calls every module in turn that has hooked Handle, using the parameters wParam
+ and lParam. Handle must have been returned by TCreateHookableEvent()
+ Returns 0 on success, -1 if Handle is invalid
+ If one of the hooks returned nonzero to indicate abort, returns that abort
+ value immediately, without calling the rest of the hooks in the chain
+ Notes on calling TNotifyEventHooks() from a thread other than that which owns
+ the main Miranda window:
+ It works. The call is routed to the main thread and all hook subcribers are
+ called in the context of the main thread. The thread which called
+ TNotifyHookEvents() is paused until all the processing is complete at which
+ point it returns with the correct return value.
+ This procedure requires more than one wait object so naturally there are
+ possibilities for deadlocks, but not many.
+ Calling TNotifyEventHooks() from other than the main thread will be
+ considerably slower than from the main thread, but will consume only slightly
+ more actual CPU time, the rest will mostly be spent waiting for the main thread
+ to return to the message loop so it can be interrupted neatly.
+ *)
+ TNotifyEventHooks = function(Handle: THandle; wParam: WPARAM; lParam: LPARAM): int; cdecl;
+ (* THookEvent
+ Adds a new hook to the chain 'char', to be called when the hook owner calls
+ TNotifyEventHooks(). Returns NIL if name is not a valid event or a handle
+ referring to the hook otherwise. Note that debug builds will warn with a
+ MessageBoxA if a hook is attempted on an unknown event. All hooks will be
+ automatically destroyed when their parent event is destroyed or the programme
+ ends, but can be unhooked earlier using TUnhookEvent(). MIRANDAHOOK is defined as
+ function(wParam: WPARAM; lParam: LPARAM): int; cdecl;
+ where you can substitute your own name for function. wParam and lParam are
+ defined by the creator of the event when TNotifyEventHooks() is called.
+ The return value is 0 to continue processing the other hooks, or nonzero
+ to stop immediately. This abort value is returned to the caller of
+ TNotifyEventHooks() and should not be -1 since that is a special return code
+ for TNotifyEventHooks() (see above)
+ *)
+ THookEvent = function(const char: PChar; MIRANDAHOOK: TMIRANDAHOOK): THandle; cdecl;
+
+ (* THookEventMessage
+ Works as for THookEvent(), except that when the notifier is called a message is
+ sent to a window, rather than a function being called.
+ Note that SendMessage() is a decidedly slow function so please limit use of
+ this function to events that are not called frequently, or to hooks that are
+ only installed briefly
+ The window procedure is called with the message 'message' and the wParam and
+ lParam given to TNotifyEventHooks(). The return value of SendMessage() is used
+ in the same way as the return value in HookEvent().
+ *)
+ THookEventMessage = function(const char: PChar; Wnd: THandle; wMsg: Integer): THandle; cdecl;
+
+ (* TUnhookEvent
+ Removes a hook from its event chain. It will no longer receive any events.
+ Handle must have been returned by THookEvent() or THookEventMessage().
+ Returns 0 on success or nonzero if hHook is invalid.
+ *)
+ TUnhookEvent = function(Handle: THandle): int; cdecl;
+
+ {*************************service functions**************************}
+ (* TCreateServiceFunction
+ Adds a new service function called 'char' to the global list and returns a
+ handle referring to it. Service function handles are destroyed automatically
+ on exit, but can be removed from the list earlier using
+ TDestroyServiceFunction()
+ Returns NIL if name has already been used. MIRANDASERVICE is defined by the
+ caller as
+ function(wParam: WPARAM; lParam: LPARAM): int; cdecl;
+ where the creator publishes the meanings of wParam, lParam and the return value
+ Service functions must not return CALLSERVICE_NOTFOUND since that would confuse
+ callers of TCallService().
+ *)
+ TCreateServiceFunction = function(const char: PChar; MIRANDASERVICE: TMIRANDASERVICE): THandle; cdecl;
+
+ (* DestroyServiceFunction
+ Removes the function associated with MIRANDASERVICE from the global service function
+ list. Modules calling TCallService() will fail if they try to call this
+ service's name. MIRANDASERVICE must have been returned by TCreateServiceFunction().
+ Returns 0 on success or non-zero if MIRANDASERVICE is invalid.
+ *)
+ TCreateTransientServiceFunction = function(const char: PChar; MIRANDASERVICE: TMIRANDASERVICE): THandle; cdecl;
+
+ TDestroyServiceFunction = function(Handle: THandle): int; cdecl;
+
+ (* TCallService
+ Finds and calls the service function 'char' using the parameters wParam and
+ lParam.
+ Returns CALLSERVICE_NOTFOUND if no service function called 'char' has been
+ created, or the value the service function returned otherwise.
+ *)
+ TCallService = function(const char: PChar; wParam: WPARAM; lParam: LPARAM): int; cdecl;
+
+ (* TServiceExists
+ Finds if a service with the given name exists
+ Returns nonzero if the service was found, and zero if it was not
+ *)
+ TServiceExists = function(const char: PChar): int; cdecl;
+
+ PPLUGINLINK = ^TPLUGINLINK;
+ TPLUGINLINK = record
+ CreateHookableEvent: TCreateHookableEvent;
+ DestroyHookableEvent: TDestroyHookableEvent;
+ NotifyEventHooks: TNotifyEventHooks;
+ HookEvent: THookEvent;
+ HookEventMessage: THookEventMessage;
+ UnhookEvent: TUnhookEvent;
+ CreateServiceFunction: TCreateServiceFunction;
+ CreateTransientServiceFunction: TCreateTransientServiceFunction;
+ DestroyServiceFunction: TDestroyServiceFunction;
+ CallService: TCallService;
+ ServiceExists: TServiceExists; // v0.1.0.1+
+ end;
+
+ { any module must export the below functions to be valid plugin
+ the export names MUST be 'MirandaPluginInfo' 'Load' 'Unload' }
+
+ TMirandaPluginInfo = function(mirandaVersion: DWORD): PPLUGININFO; cdecl;
+ TLoad = function(link: PPLUGINLINK): int; cdecl;
+ TUnload = function: int; cdecl;
+
+const
+ CALLSERVICE_NOTFOUND = $80000000;
+ MIID_LAST: TGUID = '{00000000-0000-0000-0000-000000000000}';
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/readme.txt b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/readme.txt new file mode 100644 index 0000000000..8b8e63231f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/readme.txt @@ -0,0 +1 @@ +https://opensvn.csie.org/traccgi/historypp/browser/historypp/trunk/inc
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/statusmodes.inc b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/statusmodes.inc new file mode 100644 index 0000000000..57facc8338 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/MirandaINC/statusmodes.inc @@ -0,0 +1,54 @@ +(*
+
+Miranda IM: the free IM client for Microsoft* Windows*
+
+Copyright 2000-2003 Miranda ICQ/IM project,
+all portions of this codebase are copyrighted to the people
+listed in contributors.txt.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+*)
+
+{$IFNDEF STATUSMODES}
+{$DEFINE STATUSMODES}
+
+const
+
+ // add 1 to the ID_STATUS_CONNECTING to mark retries (v0.1.0.1+)
+ // e.g. ID_STATUS_CONNECTING+2 is the third connection attempt, or the second retry
+
+ ID_STATUS_CONNECTING = 1;
+
+ // max retries is just a marker, so that the clist knows what
+ // numbers represent retries, it should set any kind of limit on the number
+ // of retries you can and/or should do
+
+ MAX_CONNECT_RETRIES = 10000;
+
+ // and the modes!
+
+ ID_STATUS_OFFLINE = 40071;
+ ID_STATUS_ONLINE = 40072;
+ ID_STATUS_AWAY = 40073;
+ ID_STATUS_DND = 40074;
+ ID_STATUS_NA = 40075;
+ ID_STATUS_OCCUPIED = 40076;
+ ID_STATUS_FREECHAT = 40077;
+ ID_STATUS_INVISIBLE = 40078;
+ ID_STATUS_ONTHEPHONE = 40079;
+ ID_STATUS_OUTTOLUNCH = 40080;
+
+{$ENDIF}
diff --git a/plugins/!NotAdopted/Chess4Net/MI/PluginCommonUnit.pas b/plugins/!NotAdopted/Chess4Net/MI/PluginCommonUnit.pas new file mode 100644 index 0000000000..30cbdccec5 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/PluginCommonUnit.pas @@ -0,0 +1,63 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit PluginCommonUnit;
+
+interface
+
+uses
+ ConnectorUnit,
+ ControlUnit;
+
+function CreatePluginInstance(Connector: TConnector): IMirandaPlugin;
+procedure InitializeControls;
+procedure DeinitializeControls;
+procedure ErrorDuringPluginStart;
+
+implementation
+
+uses
+ Windows, Forms, Dialogs, Graphics, SysUtils, Controls,
+ // plugin units
+ GlobalsUnit, GlobalsLocalUnit, ManagerUnit.MI, ModalForm;
+
+function CreatePluginInstance(Connector: TConnector): IMirandaPlugin;
+begin
+ Result := TManagerMIFactory.Create(Connector, ErrorDuringPluginStart);
+end;
+
+
+procedure InitializeControls;
+begin
+ MirandaPluginPath := MirandaPluginsPath + 'Chess4Net\';
+ Chess4NetPath := MirandaPluginPath;
+ if (not DirectoryExists(Chess4NetPath)) then
+ CreateDir(Chess4NetPath);
+ Chess4NetIniFilePath := Chess4NetPath;
+ Chess4NetGamesLogPath := Chess4NetPath;
+ Chess4NetIcon := TIcon.Create;
+ Chess4NetIcon.Handle := LoadIcon(hInstance, 'MAINICON');
+ pluginIcon := Chess4NetIcon;
+
+ MirandaPluginIcon := Chess4NetIcon;
+
+ InitConnectorGlobals(MSG_INVITATION, PROMPT_HEAD, MSG_DATA_SEPARATOR);
+end;
+
+
+procedure DeinitializeControls;
+begin
+ StopAllPlugins;
+ FreeAndNil(Chess4NetIcon);
+end;
+
+
+procedure ErrorDuringPluginStart;
+begin
+ TDialogs.ShowMessage('ERROR: Cannot start Chess4Net!');
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.dfm b/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.dfm new file mode 100644 index 0000000000..f776089094 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.dfm @@ -0,0 +1,47 @@ +object TransmitGameSelectionForm: TTransmitGameSelectionForm
+ Left = 487
+ Top = 197
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsDialog
+ Caption = 'Transmit Game'
+ ClientHeight = 99
+ ClientWidth = 381
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ PixelsPerInch = 96
+ TextHeight = 13
+ object OkButton: TTntButton
+ Left = 296
+ Top = 8
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 1
+ end
+ object CancelButton: TTntButton
+ Left = 296
+ Top = 40
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Cancel'
+ ModalResult = 2
+ TabOrder = 2
+ end
+ object TransmitGameListBox: TTntListBox
+ Left = 8
+ Top = 8
+ Width = 281
+ Height = 81
+ ItemHeight = 13
+ TabOrder = 0
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.pas b/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.pas new file mode 100644 index 0000000000..a70eb65ef5 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/TransmitGameSelectionUnit.pas @@ -0,0 +1,83 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit TransmitGameSelectionUnit;
+
+interface
+
+uses
+ Forms, Controls, StdCtrls, TntStdCtrls, Classes,
+ //
+ ModalForm;
+
+type
+ TTransmitGameSelectionForm = class(TModalForm)
+ OkButton: TTntButton;
+ CancelButton: TTntButton;
+ TransmitGameListBox: TTntListBox;
+ procedure FormCreate(Sender: TObject);
+ private
+ procedure FLocalize;
+ protected
+ function GetModalID: TModalFormID; override;
+ public
+ procedure SetGames(Games: TStrings);
+ function GetSelected: TObject;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ LocalizerUnit;
+
+////////////////////////////////////////////////////////////////////////////////
+// TTransmitGameSelectionForm
+
+procedure TTransmitGameSelectionForm.FormCreate(Sender: TObject);
+begin
+ FLocalize;
+end;
+
+
+procedure TTransmitGameSelectionForm.FLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ Caption := GetLabel(67);
+ OkButton.Caption := GetLabel(11);
+ CancelButton.Caption := GetLabel(12);
+ end;
+end;
+
+
+function TTransmitGameSelectionForm.GetModalID: TModalFormID;
+begin
+ Result := mfTransmitGame;
+end;
+
+
+procedure TTransmitGameSelectionForm.SetGames(Games: TStrings);
+begin
+ TransmitGameListBox.Items.Assign(Games);
+ if (TransmitGameListBox.Count > 0) then
+ TransmitGameListBox.ItemIndex := 0;
+end;
+
+
+function TTransmitGameSelectionForm.GetSelected: TObject;
+var
+ iIndex: integer;
+begin
+ iIndex := TransmitGameListBox.ItemIndex;
+ if (iIndex >= 0) then
+ Result := TransmitGameListBox.Items.Objects[iIndex]
+ else
+ Result := nil;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/MI/make.bat b/plugins/!NotAdopted/Chess4Net/MI/make.bat new file mode 100644 index 0000000000..4d4672bc2d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MI/make.bat @@ -0,0 +1,36 @@ +SET PROJ_DIR=Chess4Net_MI
+SET CHESS4NET_DIR=%PROJ_DIR%\Chess4Net
+
+rem -= Clean =-
+
+RMDIR /S /Q ..\bin\%PROJ_DIR%
+
+rem -= Environment =-
+
+MD ..\bin\%PROJ_DIR%
+MD ..\bin\%PROJ_DIR%\Chess4Net
+
+rem -= Compilation =-
+
+dcc32 -B Chess4Net_MI.dpr
+
+rem -= Build =-
+
+COPY ..\Readme.txt ..\bin\%PROJ_DIR%
+COPY ..\Readme_RU.txt ..\bin\%PROJ_DIR%
+
+COPY ..\Lang.ini ..\bin\%CHESS4NET_DIR%
+
+COPY ..\Build\Chigorin.mov ..\bin\%CHESS4NET_DIR%
+COPY ..\Build\Chigorin.pos ..\bin\%CHESS4NET_DIR%
+
+COPY ..\Build\eco.mov ..\bin\%CHESS4NET_DIR%
+COPY ..\Build\eco.pos ..\bin\%CHESS4NET_DIR%
+
+COPY ..\Build\Fischer.mov ..\bin\%CHESS4NET_DIR%
+COPY ..\Build\Fischer.pos ..\bin\%CHESS4NET_DIR%
+
+COPY ..\Build\Tal.mov ..\bin\%CHESS4NET_DIR%
+COPY ..\Build\Tal.pos ..\bin\%CHESS4NET_DIR%
+
+MOVE ..\bin\Chess4Net_MI.dll ..\bin\%PROJ_DIR%
diff --git a/plugins/!NotAdopted/Chess4Net/ManagerUnit.dfm b/plugins/!NotAdopted/Chess4Net/ManagerUnit.dfm new file mode 100644 index 0000000000..744ec26f31 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ManagerUnit.dfm @@ -0,0 +1,147 @@ +object Manager: TManager
+ Left = 555
+ Top = 124
+ BorderIcons = []
+ BorderStyle = bsToolWindow
+ Caption = 'Manager'
+ ClientHeight = 72
+ ClientWidth = 204
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Microsoft Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ Position = poDefault
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ PixelsPerInch = 96
+ TextHeight = 13
+ object ActionList: TTntActionList
+ OnUpdate = ActionListUpdate
+ Left = 176
+ Top = 8
+ object LookFeelOptionsAction: TTntAction
+ Caption = 'Look && Feel Options...'
+ OnExecute = LookFeelOptionsActionExecute
+ end
+ object AboutAction: TTntAction
+ Caption = 'About...'
+ OnExecute = AboutActionExecute
+ end
+ object BroadcastAction: TTntAction
+ Caption = 'Broadcast...'
+ OnExecute = BroadcastActionExecute
+ end
+ end
+ object ConnectedPopupMenu: TTntPopupMenu
+ AutoPopup = False
+ Left = 8
+ Top = 8
+ object StartAdjournedGameConnected: TTntMenuItem
+ Caption = 'Start Adjourned Game'
+ Visible = False
+ OnClick = StartAdjournedGameConnectedClick
+ end
+ object StartStandartGameConnected: TTntMenuItem
+ Caption = 'Start Standart Game'
+ OnClick = StartStandartGameConnectedClick
+ end
+ object StartPPRandomGameConnected: TTntMenuItem
+ Caption = 'Start PP Random Game'
+ OnClick = StartPPRandomGameConnectedClick
+ end
+ object N5: TTntMenuItem
+ Caption = '-'
+ end
+ object ChangeColorConnected: TTntMenuItem
+ Caption = 'Change Color'
+ OnClick = ChangeColorConnectedClick
+ end
+ object TTntMenuItem
+ Caption = '-'
+ end
+ object GameOptionsConnected: TTntMenuItem
+ Caption = 'Game Options...'
+ OnClick = GameOptionsConnectedClick
+ end
+ object LookFeelOptionsConnected: TTntMenuItem
+ Action = LookFeelOptionsAction
+ end
+ object N1: TTntMenuItem
+ Caption = '-'
+ end
+ object BroadcastConnected: TTntMenuItem
+ Action = BroadcastAction
+ end
+ object N3: TTntMenuItem
+ Caption = '-'
+ end
+ object AboutConnected: TTntMenuItem
+ Action = AboutAction
+ end
+ end
+ object GamePopupMenu: TTntPopupMenu
+ AutoPopup = False
+ OnPopup = GamePopupMenuPopup
+ Left = 40
+ Top = 8
+ object AbortGame: TTntMenuItem
+ Caption = 'Abort'
+ OnClick = AbortGameClick
+ end
+ object DrawGame: TTntMenuItem
+ Caption = 'Draw'
+ OnClick = DrawGameClick
+ end
+ object ResignGame: TTntMenuItem
+ Caption = 'Resign'
+ OnClick = ResignGameClick
+ end
+ object N6: TTntMenuItem
+ Caption = '-'
+ end
+ object AdjournGame: TTntMenuItem
+ Caption = 'Adjourn'
+ Visible = False
+ OnClick = AdjournGameClick
+ end
+ object GamePause: TTntMenuItem
+ Caption = 'Pause'
+ Visible = False
+ OnClick = GamePauseClick
+ end
+ object TakebackGame: TTntMenuItem
+ Caption = 'Takeback'
+ Visible = False
+ OnClick = TakebackGameClick
+ end
+ object N4: TTntMenuItem
+ Caption = '-'
+ end
+ object LookFeelOptionsGame: TTntMenuItem
+ Action = LookFeelOptionsAction
+ end
+ object N2: TTntMenuItem
+ Caption = '-'
+ end
+ object Broadcast: TTntMenuItem
+ Action = BroadcastAction
+ end
+ object N7: TTntMenuItem
+ Caption = '-'
+ end
+ object AboutGame: TTntMenuItem
+ Action = AboutAction
+ end
+ end
+ object ConnectorTimer: TTimer
+ Enabled = False
+ Interval = 500
+ OnTimer = ConnectorTimerTimer
+ Left = 8
+ Top = 40
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/ManagerUnit.pas b/plugins/!NotAdopted/Chess4Net/ManagerUnit.pas new file mode 100644 index 0000000000..a20cb4c1bc --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ManagerUnit.pas @@ -0,0 +1,2460 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ManagerUnit;
+
+{$DEFINE GAME_LOG}
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Menus, TntMenus, ActnList, TntActnList, ExtCtrls,
+{$IFDEF TRILLIAN}
+ plugin,
+{$ENDIF}
+ // Chess4Net Units
+ ChessBoardHeaderUnit, ChessRulesEngine, ChessBoardUnit,
+ GameChessBoardUnit, ConnectorUnit, ConnectingUnit, GameOptionsUnit,
+ ModalForm, DialogUnit, ContinueUnit, LocalizerUnit, URLVersionQueryUnit;
+
+type
+ TManager = class(TForm, ILocalizable)
+ ActionList: TTntActionList;
+ LookFeelOptionsAction: TTntAction;
+ AboutAction: TTntAction;
+
+ ConnectedPopupMenu: TTntPopupMenu;
+ LookFeelOptionsConnected: TTntMenuItem;
+ StartStandartGameConnected: TTntMenuItem;
+ StartPPRandomGameConnected: TTntMenuItem;
+ GameOptionsConnected: TTntMenuItem;
+ ChangeColorConnected: TTntMenuItem;
+ GamePopupMenu: TTntPopupMenu;
+ AbortGame: TTntMenuItem;
+ DrawGame: TTntMenuItem;
+ ResignGame: TTntMenuItem;
+ N4: TTntMenuItem;
+ LookFeelOptionsGame: TTntMenuItem;
+ TakebackGame: TTntMenuItem;
+ GamePause: TTntMenuItem;
+ N1: TTntMenuItem;
+ AboutConnected: TTntMenuItem;
+ N2: TTntMenuItem;
+ AboutGame: TTntMenuItem;
+ StartAdjournedGameConnected: TTntMenuItem;
+ AdjournGame: TTntMenuItem;
+ N5: TTntMenuItem;
+ N6: TTntMenuItem;
+
+ BroadcastAction: TTntAction;
+ N3: TTntMenuItem;
+ BroadcastConnected: TTntMenuItem;
+ N7: TTntMenuItem;
+ Broadcast: TTntMenuItem;
+
+ ConnectorTimer: TTimer;
+
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure ActionListUpdate(Action: TBasicAction;
+ var Handled: Boolean);
+ procedure LookFeelOptionsActionExecute(Sender: TObject);
+ procedure AbortGameClick(Sender: TObject);
+ procedure DrawGameClick(Sender: TObject);
+ procedure ResignGameClick(Sender: TObject);
+ procedure ChangeColorConnectedClick(Sender: TObject);
+ procedure GameOptionsConnectedClick(Sender: TObject);
+ procedure StartStandartGameConnectedClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure ConnectorTimerTimer(Sender: TObject);
+ procedure StartPPRandomGameConnectedClick(Sender: TObject);
+ procedure TakebackGameClick(Sender: TObject);
+ procedure GamePauseClick(Sender: TObject);
+ procedure AboutActionExecute(Sender: TObject);
+ procedure StartAdjournedGameConnectedClick(Sender: TObject);
+ procedure AdjournGameClick(Sender: TObject);
+ procedure GamePopupMenuPopup(Sender: TObject);
+ procedure BroadcastActionExecute(Sender: TObject);
+
+ private
+ m_ConnectingForm: TConnectingForm;
+ m_ContinueForm: TContinueForm;
+ m_Connector: TConnector;
+ m_ChessBoard: TGameChessBoard;
+ m_Dialogs: TDialogs;
+
+ m_ExtBaseList: TStringList;
+ m_strExtBaseName: string;
+{$IFDEF QIP}
+ iProtoDllHandle: integer;
+ wAccName: WideString;
+ QIPConnectionError: boolean;
+{$ENDIF}
+{$IFDEF TRILLIAN}
+ contactlistEntry: TTtkContactListEntry;
+{$ENDIF}
+{$IFDEF SKYPE}
+ m_bDontShowCredits: boolean;
+{$ENDIF}
+ m_lwOpponentClientVersion: LongWord;
+ // It's for ChessBoard
+ you_unlimited, opponent_unlimited: boolean;
+ you_time, opponent_time,
+ you_inc, opponent_inc: word;
+ you_takebacks, opponent_takebacks: boolean;
+ can_pause_game, can_adjourn_game, move_done: boolean;
+
+ m_strPlayerNick: string;
+ m_strPlayerNickId: string;
+
+ m_strOpponentNick: string;
+ m_strOpponentId: string;
+ m_strOverridedOpponentNickId: string;
+
+ extra_exit: boolean;
+ m_bConnectionOccured: boolean;
+
+ m_bTransmittable: boolean;
+
+ m_iDontShowLastVersion: integer;
+ m_iQueriedDontShowLastVersion: integer;
+
+{$IFDEF GAME_LOG}
+ // for game log
+ gameLog: string;
+ procedure FInitGameLog;
+ procedure FWriteToGameLog(const s: string);
+ procedure FlushGameLog;
+{$ENDIF}
+ procedure ChessBoardHandler(e: TGameChessBoardEvent;
+ d1: pointer = nil; d2: pointer = nil);
+ procedure SetClock; overload;
+ procedure SetClock(var sr: string); overload;
+
+ procedure FPopulateExtBaseList;
+
+ function FReadCommonSettings(setToOpponent: boolean): boolean;
+ procedure FWritePrivateSettings;
+ procedure FWriteCommonSettings;
+
+ function ClockToStr: string;
+ procedure ChangeColor;
+ procedure PauseGame;
+ procedure ContinueGame;
+ procedure FAdjournGame;
+ procedure FExitGameMode;
+
+ procedure FBuildAdjournedStr;
+ procedure FStartAdjournedGame;
+
+ function FGetAdjournedStr: string;
+ procedure FSetAdjournedStr(const strValue: string);
+
+ function FGetPlayerColor: TFigureColor;
+ procedure FSetPlayerColor(Value: TFigureColor);
+
+ function FGetOpponentNickId: string;
+{$IFDEF SKYPE}
+ procedure FShowCredits;
+{$ENDIF}
+
+ procedure FSetTransmittable(bValue: boolean);
+
+ procedure FOnURLQueryReady(Sender: TURLVersionQuery);
+
+ property AdjournedStr: string read FGetAdjournedStr write FSetAdjournedStr;
+ property _PlayerColor: TFigureColor read FGetPlayerColor write FSetPlayerColor;
+
+ protected
+ constructor RCreate;
+
+ procedure ROnCreate; virtual; abstract;
+ procedure ROnDestroy; virtual;
+
+ procedure ConnectorHandler(e: TConnectorEvent;
+ d1: pointer = nil; d2: pointer = nil); virtual;
+ procedure RCreateChessBoardAndDialogs;
+ procedure RCreateAndPopulateExtBaseList;
+ procedure RSetChessBoardToView;
+
+ procedure RReadPrivateSettings;
+ procedure RShowConnectingForm;
+
+ procedure ILocalizable.Localize = RLocalize;
+ procedure RLocalize;
+
+ class procedure RSplitStr(s: string; var strLeft: string; var strRight: string);
+ procedure RHandleConnectorDataCommand(sl: string); virtual;
+ procedure RSetOpponentClientVersion(lwVersion: LongWord); virtual;
+
+ procedure RSendData(const cmd: string = ''); virtual; abstract;
+
+ procedure RSetConnectionOccured; virtual;
+ function RGetGameName: string; virtual;
+
+ function RGetGameContextStr: string;
+ procedure RSetGameContext(const strValue: string);
+
+ procedure RReleaseWithConnectorGracefully;
+
+ procedure RRetransmit(const strCmd: string); virtual;
+ procedure RBroadcast; virtual;
+
+ procedure RUpdateChessBoardCaption;
+
+ procedure DialogFormHandler(modSender: TModalForm; msgDlgID: TModalFormID); virtual;
+
+ property Connector: TConnector read m_Connector write m_Connector;
+ property ChessBoard: TGameChessBoard read m_ChessBoard write m_ChessBoard;
+
+ property PlayerNick: string read m_strPlayerNick write m_strPlayerNick;
+ property PlayerNickId: string read m_strPlayerNickId write m_strPlayerNickId;
+ property OpponentNick: string read m_strOpponentNick write m_strOpponentNick;
+ property OpponentId: string read m_strOpponentId write m_strOpponentId;
+ property OpponentNickId: string read FGetOpponentNickId write m_strOverridedOpponentNickId;
+
+ property Transmittable: boolean read m_bTransmittable write FSetTransmittable;
+
+ property pDialogs: TDialogs read m_Dialogs;
+
+ public
+{$IFDEF AND_RQ}
+ class function Create: TManager; reintroduce;
+{$ENDIF}
+{$IFDEF QIP}
+ class function Create(const accName: WideString; const protoDllHandle: integer): TManager; reintroduce;
+{$ENDIF}
+{$IFDEF TRILLIAN}
+ class function Create(const vContactlistEntry: TTtkContactListEntry): TManager; reintroduce;
+{$ENDIF}
+ end;
+
+const
+ CMD_DELIMITER = '&&'; // CMD_DELIMITER has to be present in arguments
+
+ CMD_VERSION = 'ver';
+ CMD_WELCOME = 'wlcm'; // Accept of connection
+ CMD_GOODBYE = 'gdb'; // Refusion of connection
+ CMD_TRANSMITTING = 'trnsm';
+ CMD_NICK_ID = 'nkid';
+ CMD_CONTINUE_GAME = 'cont';
+ CMD_GAME_CONTEXT = 'gmctxt';
+
+implementation
+
+{$R *.dfm}
+{$J+}
+
+uses
+ // Chess4Net
+ DateUtils, Math, StrUtils, Dialogs,
+ //
+ LookFeelOptionsUnit, GlobalsUnit, GlobalsLocalUnit, InfoUnit, ChessClockUnit,
+ DontShowMessageDlgUnit, IniSettingsUnit, PosBaseChessBoardLayerUnit
+{$IFDEF AND_RQ}
+ , CallExec
+{$ENDIF}
+{$IFDEF QIP}
+ , ControlUnit
+{$ENDIF}
+{$IFDEF SKYPE}
+ , CreditsFormUnit
+{$ENDIF}
+ ;
+
+const
+ USR_BASE_NAME = 'Chess4Net';
+
+ NO_CLOCK_TIME ='u u';
+
+ HOUR_TIME_FORMAT = 'h:nn:ss';
+
+ // Command shorthands for Connector
+ CMD_ECHO = 'echo';
+ CMD_START_GAME = 'strt';
+ CMD_GAME_OPTIONS = 'gmopt'; // Doesn't exist from 2007.5
+ CMD_CHANGE_COLOR = 'chclr';
+// CMD_NICK_ID = 'nkid';
+ CMD_RESIGN = 'res';
+ CMD_ABORT = 'abrt';
+ CMD_ABORT_ACCEPTED = 'abrtacc';
+ CMD_ABORT_DECLINED = 'abrtdec';
+ CMD_DRAW = 'draw';
+ CMD_DRAW_ACCEPTED = 'drawacc';
+ CMD_DRAW_DECLINED = 'drawdec';
+ CMD_FLAG = 'flg';
+ CMD_FLAG_YES = 'flgyes';
+ CMD_FLAG_NO = 'flgno';
+ CMD_TAKEBACK = 'tkbk';
+ CMD_TAKEBACK_YES = 'tkbkyes';
+ CMD_TAKEBACK_NO = 'tkbkno';
+ CMD_SWITCH_CLOCK = 'swclck';
+ CMD_REPEAT_COMMAND = 'rptcmd';
+ CMD_POSITION = 'pos';
+// CMD_VERSION = 'ver';
+// CMD_WELCOME = 'wlcm'; // Accept of connection
+// CMD_GOODBYE = 'gdb'; // Refusion of connection
+ // ñóùåñòâóåò ñ 2007.5
+ CMD_NO_SETTINGS = 'noset'; // If global settings are absent then request from partner's client
+ CMD_ALLOW_TAKEBACKS = 'alwtkb';
+ CMD_SET_CLOCK = 'clck'; // Change of timing
+ CMD_SET_TRAINING = 'trnng'; // Setting training mode
+ // Ñóùåñòâóåò ñ 2007.6
+ CMD_CAN_PAUSE_GAME = 'canpaus';
+ CMD_PAUSE_GAME = 'paus';
+ CMD_PAUSE_GAME_YES = 'pausyes';
+ CMD_PAUSE_GAME_NO = 'pausno';
+// CMD_CONTINUE_GAME = 'cont';
+ // Ñóùåñòâóåò ñ 2008.1
+ CMD_CAN_ADJOURN_GAME = 'canadj';
+ CMD_SET_ADJOURNED = 'setadj'; // Setting of adj. position and timing
+ CMD_ADJOURN_GAME = 'adj';
+ CMD_ADJOURN_GAME_YES = 'adjyes';
+ CMD_ADJOURN_GAME_NO = 'adjno';
+ CMD_START_ADJOURNED_GAME = 'strtadj';
+
+ // CMD_DELIMITER = '&&'; // CMD_DELIMITER has to be present in arguments
+ // CMD_CLOSE = 'ext' - IS RESERVED
+
+type
+ TManagerDefault = class(TManager) // TODO: TRILLIAN, AND_RQ, QIP-> own classes
+ protected
+ procedure ROnCreate; override;
+ procedure ROnDestroy; override;
+ procedure RSendData(const cmd: string = ''); override;
+ public
+{$IFDEF AND_RQ}
+ constructor Create; reintroduce;
+{$ENDIF}
+{$IFDEF QIP}
+ constructor Create(const accName: WideString; const protoDllHandle: integer); reintroduce;
+{$ENDIF}
+{$IFDEF TRILLIAN}
+ constructor Create(const vContactlistEntry: TTtkContactListEntry); reintroduce;
+{$ENDIF}
+ end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TManager
+
+procedure TManager.RCreateChessBoardAndDialogs;
+begin
+// m_ChessBoard := TGameChessBoard.Create(self, ChessBoardHandler, Chess4NetPath + USR_BASE_NAME);
+ m_ChessBoard := TGameChessBoard.Create(nil, ChessBoardHandler, Chess4NetGamesLogPath + USR_BASE_NAME);
+ m_Dialogs := TDialogs.Create(ChessBoard, DialogFormHandler);
+end;
+
+
+procedure TManager.FormCreate(Sender: TObject);
+begin
+{$IFNDEF SKYPE}
+ BroadcastAction.Visible := TRUE;
+{$ENDIF}
+ ROnCreate;
+end;
+
+
+procedure TManager.RShowConnectingForm;
+begin
+ m_ConnectingForm := (m_Dialogs.CreateDialog(TConnectingForm) as TConnectingForm);
+ m_ConnectingForm.Show;
+end;
+
+
+procedure TManager.ChessBoardHandler(e: TGameChessBoardEvent;
+ d1: pointer = nil; d2: pointer = nil);
+var
+ s: string;
+ wstrMsg1, wstrMsg2: WideString;
+ strSwitchClockCmd: string;
+begin
+ case e of
+ cbeKeyPressed:
+ if extra_exit and (Word(d1) = VK_ESCAPE) then
+ begin
+{$IFDEF GAME_LOG}
+ if (ChessBoard.Mode = mGame) then
+ begin
+ FWriteToGameLog('*');
+ FlushGameLog;
+ end;
+{$ENDIF}
+ Release;
+ end;
+
+ cbeExit:
+ Close;
+
+ cbeMenu:
+ if (not m_Dialogs.Showing) then
+ begin
+ if ((ChessBoard.Mode = mView) or Transmittable) then
+ begin
+ if (Connector.connected) then
+ ConnectedPopupMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
+ end
+ else if (ChessBoard.Mode = mGame) then
+ begin
+ GamePopupMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
+ end;
+ end;
+
+ cbeMoved:
+ begin
+ if (not Transmittable) then
+ begin
+ RSendData(PString(d1)^);
+ RRetransmit(PString(d1)^);
+ end;
+{$IFDEF GAME_LOG}
+ if (ChessBoard.PositionColor = fcBlack) or (not move_done) then
+ begin
+ FWriteToGameLog(' ' + IntToStr(ChessBoard.NMoveDone) + '.');
+ if (ChessBoard.PositionColor = fcWhite) then
+ FWriteToGameLog(' ...');
+ end;
+ FWriteToGameLog(' ' + PString(d1)^);
+{$ENDIF}
+ move_done := TRUE;
+ TakebackGame.Enabled := TRUE;
+ end;
+
+ cbeMate:
+ with ChessBoard do
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('#');
+ if (PositionColor = fcWhite) then
+ FWriteToGameLog(sLineBreak + '0 - 1')
+ else
+ FWriteToGameLog(sLineBreak + '1 - 0');
+ FlushGameLog;
+{$ENDIF}
+ with TLocalizer.Instance do
+ begin
+ if (Transmittable) then
+ begin
+ if (PositionColor = fcWhite) then
+ wstrMsg1 := GetMessage(36) // White is checkmated.
+ else
+ wstrMsg1 := GetMessage(37); // Black is checkmated.
+ wstrMsg2 := wstrMsg1;
+ end
+ else // not Transmittable
+ begin
+ if (PositionColor = fcWhite) then
+ begin
+ wstrMsg1 := GetMessage(0); // White is checkmated. You win.
+ wstrMsg2 := GetMessage(1); // White is checkmated. You loose.
+ end
+ else
+ begin
+ wstrMsg1 := GetMessage(2); // Black is checkmated. You win.
+ wstrMsg2 := GetMessage(3); // Black is checkmated. You loose.
+ end;
+ end;
+ end; // with
+
+ if ((_PlayerColor <> fcWhite) and (PositionColor = fcWhite)) or
+ ((_PlayerColor <> fcBlack) and (PositionColor = fcBlack)) then
+ begin
+ m_Dialogs.MessageDlg(wstrMsg1, mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grWin);
+ end
+ else
+ begin
+ m_Dialogs.MessageDlg(wstrMsg2, mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grLost);
+ end;
+ end;
+
+ cbeStaleMate:
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('=' + sLineBreak + '1/2 - 1/2');
+ FlushGameLog;
+{$ENDIF}
+ if (Transmittable) then
+ wstrMsg1 := TLocalizer.Instance.GetMessage(35) // Stalemate.
+ else
+ wstrMsg1 := TLocalizer.Instance.GetMessage(4); // It's stalemate. No one wins.
+ m_Dialogs.MessageDlg(wstrMsg1, mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grDraw);
+ end;
+
+ cbeClockSwitched:
+ begin
+ if (Transmittable) then
+ exit;
+ with ChessBoard do
+ begin
+ if (move_done and (ClockColor = PositionColor)) then
+ begin
+ if (ClockColor <> _PlayerColor) then
+ begin
+ Time[_PlayerColor] := IncSecond(Time[_PlayerColor], you_inc);
+ s := TChessClock.ConvertToFullStr(Time[_PlayerColor]);
+
+ if ((not Unlimited[_PlayerColor]) or (m_lwOpponentClientVersion < 200706)) then
+ begin
+ strSwitchClockCmd := CMD_SWITCH_CLOCK + ' ' + s;
+ RSendData(strSwitchClockCmd);
+ RRetransmit(strSwitchClockCmd);
+ end;
+ end
+ else
+ begin
+ if (_PlayerColor = fcWhite) then
+ Time[fcBlack] := IncSecond(Time[fcBlack], opponent_inc)
+ else
+ Time[fcWhite] := IncSecond(Time[fcWhite], opponent_inc);
+ end;
+ end;
+ end; { with }
+ end;
+
+ cbeTimeOut:
+ begin
+ if (not Transmittable) then
+ RSendData(CMD_FLAG);
+ end;
+
+ cbeActivate:
+ begin
+ m_Dialogs.BringToFront;
+ end;
+
+ cbeFormMoving:
+ begin
+ m_Dialogs.MoveForms(integer(d1), integer(d2));
+ end;
+ end;
+end;
+
+
+class procedure TManager.RSplitStr(s: string; var strLeft: string; var strRight: string);
+var
+ x: integer;
+begin
+ x := pos(' ', s);
+ strLeft := copy(s, 1, sign(x) * (x - 1) + (1 - sign(x)) * length(s));
+ strRight := copy(s, length(strLeft) + 2, length(s));
+end;
+
+
+procedure TManager.SetClock(var sr: string);
+var
+ sl: string;
+
+
+ procedure NSetOpponentTime;
+ begin
+ RSplitStr(sr, sl, sr);
+ if (sl = 'u') then
+ opponent_unlimited := TRUE
+ else
+ begin
+ opponent_unlimited:= FALSE;
+ opponent_time:= StrToInt(sl);
+ RSplitStr(sr, sl, sr);
+ opponent_inc := StrToInt(sl);
+ end;
+ end;
+
+ procedure NSetYouTime;
+ begin
+ RSplitStr(sr, sl, sr);
+ if (sl = 'u') then
+ you_unlimited:= TRUE
+ else
+ begin
+ you_unlimited := FALSE;
+ you_time := StrToInt(sl);
+ RSplitStr(sr, sl, sr);
+ you_inc := StrToInt(sl);
+ end;
+ end;
+
+begin // TManager.SetClock
+ if (Transmittable) then
+ begin
+ NSetYouTime;
+ NSetOpponentTime;
+ end
+ else
+ begin
+ NSetOpponentTime;
+ NSetYouTime;
+ end;
+
+ SetClock;
+end;
+
+
+procedure TManager.ConnectorHandler(e: TConnectorEvent; d1: pointer = nil; d2: pointer = nil);
+var
+ strCmd: string;
+ strLeft: string;
+begin
+ case e of
+ ceConnected:
+ begin
+ if (Assigned(m_ConnectingForm)) then
+ m_ConnectingForm.Shut;
+ RSendData(CMD_VERSION + ' ' + IntToStr(CHESS4NET_VERSION));
+ end;
+
+ ceDisconnected:
+ begin
+ if (not Connector.connected) then
+ exit;
+
+ if (Transmittable) then
+ begin
+ m_Dialogs.CloseNoneDialogs;
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(34), mtCustom,
+ [mbOK], mfMsgLeave); // Broadcaster leaves. Transmition will be closed.
+ end;
+
+ case ChessBoard.Mode of
+ mView:
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(5), mtCustom, [mbOK],
+ mfMsgLeave); // 'Your opponent leaves.'
+ end;
+ mGame:
+ begin
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('*');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(6), mtWarning,
+ [mbOK], mfMsgLeave); // Your opponent leaves. The game is aborted.
+ end;
+ end;
+ end; { ceDisconnected }
+
+ ceError:
+ begin
+{$IFDEF GAME_LOG}
+ if ChessBoard.Mode = mGame then
+ begin
+ FWriteToGameLog('*');
+ FlushGameLog;
+ end;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(7), mtWarning,
+ [mbOk], mfMsgLeave); // An error during connection occured.
+ end;
+{$IFDEF QIP}
+ ceQIPError:
+ begin
+ QIPConnectionError := TRUE;
+ // TODO: Localize
+ m_Dialogs.MessageDlg('Special message channel is not responding.' + sLineBreak +
+ 'This can happen due to the following reasons:' + sLineBreak +
+ ' 1) Your partner is using an IM other than QIP Infium. OR' + sLineBreak +
+ ' 2) Your partner is offline. OR' + sLineBreak +
+ ' 3) Protocol doesn''t support multiple channels. OR' + sLineBreak +
+ ' 4) Other reasons.' + sLineBreak +
+ 'Chess4Net won''t start.', mtWarning, [mbOk], mfMsgLeave);
+ end;
+{$ENDIF}
+
+ ceData:
+ begin
+ strCmd := PString(d1)^;
+ repeat
+ strLeft := LeftStr(strCmd, pos(CMD_DELIMITER, strCmd) - 1);
+ strCmd := RightStr(strCmd, length(strCmd) - length(strLeft) - length(CMD_DELIMITER));
+
+ RHandleConnectorDataCommand(strLeft);
+ until (strCmd = '');
+
+ end; { ceData }
+
+ end; { case ChessBoard.Mode }
+end;
+
+
+procedure TManager.RSetOpponentClientVersion(lwVersion: LongWord);
+begin
+ m_lwOpponentClientVersion := lwVersion;
+end;
+
+
+procedure TManager.RSetConnectionOccured;
+begin
+ m_bConnectionOccured := TRUE;
+{$IFNDEF TESTING}
+ with TURLVersionQuery.Create do
+ begin
+ OnQueryReady := FOnURLQueryReady;
+ {$IFDEF SKYPE}
+ Query(aidSkype, CHESS4NET_VERSION, osidWindows);
+ {$ELSE}
+ Free; // TODO: URL query for other clients
+ {$ENDIF}
+ end;
+{$ENDIF}
+end;
+
+
+procedure TManager.FOnURLQueryReady(Sender: TURLVersionQuery);
+begin
+ if (not Assigned(Sender)) then
+ exit;
+
+ try
+ if ((Sender.LastVersion <= m_iDontShowLastVersion)) then
+ exit;
+
+ if (Sender.Info <> '') then
+ begin
+ with TDontShowMessageDlg.Create(m_Dialogs, Sender.Info) do
+ begin
+ m_iQueriedDontShowLastVersion := Sender.LastVersion;
+ Show;
+ end;
+ end;
+
+ finally
+ Sender.Free;
+ end;
+
+end;
+
+
+procedure TManager.RUpdateChessBoardCaption;
+begin
+ if (m_bConnectionOccured and Assigned(ChessBoard)) then
+ ChessBoard.Caption := RGetGameName;
+end;
+
+
+procedure TManager.RHandleConnectorDataCommand(sl: string);
+var
+ AMode: TMode;
+ sr: string;
+ strSavedCmd: string;
+ wstrMsg: WideString;
+begin
+ strSavedCmd := sl;
+
+ RSplitStr(sl, sl, sr);
+
+ if (Assigned(ChessBoard)) then
+ AMode := ChessBoard.Mode
+ else
+ AMode := mView;
+
+ case AMode of
+ mView:
+ if (sl = CMD_VERSION) then
+ begin
+ RSplitStr(sr, sl, sr);
+ RSetOpponentClientVersion(StrToIntDef(sl, CHESS4NET_VERSION));
+ RSendData(CMD_WELCOME);
+ if (m_lwOpponentClientVersion < CHESS4NET_VERSION) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(8), mtWarning,
+ [mbOK], mfNone); // Your opponent is using an older version of Chess4Net. ...
+ end;
+ // 2007.4 is the first client with a backward compatibility
+ // For incompatible versions:
+ // else RSendData(CMD_GOODBYE);
+ end
+ else if (sl = CMD_WELCOME) then
+ begin
+ RSendData(CMD_NICK_ID + ' ' + OpponentNickId);
+ if (Assigned(ChessBoard)) then
+ ChessBoard.InitPosition;
+ SetClock;
+ RSetConnectionOccured;
+ end
+ else if (sl = CMD_GOODBYE) then // For the future versions
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(9) , mtWarning, [mbOK], mfIncompatible); // The current version of Chess4Net is incompatible ...
+ end
+ else if (sl = CMD_START_GAME) then
+ begin
+ with ChessBoard do
+ begin
+ if (Transmittable) then
+ m_Dialogs.CloseNoneDialogs;
+ // Starting from 2007.6 only white can start the game
+ if ((m_lwOpponentClientVersion >= 200706) and (_PlayerColor = fcWhite) and
+ (not Transmittable)) then
+ begin
+ ChangeColor;
+ end;
+ SetClock;
+ ResetMoveList;
+ move_done:= FALSE;
+ TakebackGame.Enabled := FALSE;
+ Mode := mGame;
+ SwitchClock(PositionColor);
+{$IFDEF GAME_LOG}
+ FInitGameLog;
+{$ENDIF}
+ end;
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_START_ADJOURNED_GAME) then
+ begin
+ FStartAdjournedGame;
+ RRetransmit(CMD_GAME_CONTEXT + ' ' + RGetGameContextStr);
+ RRetransmit(CMD_CONTINUE_GAME);
+ end
+ else if (sl = CMD_CONTINUE_GAME) then
+ begin
+ if (Transmittable) then
+ begin
+ m_Dialogs.CloseNoneDialogs;
+ ChessBoard.Mode := mGame;
+ ContinueGame;
+ end;
+ end
+ else if (sl = CMD_ALLOW_TAKEBACKS) then
+ begin
+ RSplitStr(sr, sl, sr);
+ opponent_takebacks := (sl = '1');
+ TakebackGame.Visible := (opponent_takebacks or ChessBoard.pTrainingMode);
+ end
+ else if (sl = CMD_CAN_PAUSE_GAME) then
+ begin
+ RSplitStr(sr, sl, sr);
+ can_pause_game := (sl = '1');
+ GamePause.Visible := can_pause_game;
+ end
+ else if (sl = CMD_CAN_ADJOURN_GAME) then
+ begin
+ RSplitStr(sr, sl, sr);
+ can_adjourn_game := (sl = '1');
+ end
+ else if (sl = CMD_SET_CLOCK) then
+ begin
+ SetClock(sr);
+ RRetransmit(CMD_SET_CLOCK + ' ' + ClockToStr);
+ end
+ else if (sl = CMD_SET_TRAINING) then
+ begin
+ RSplitStr(sr, sl, sr);
+ ChessBoard.pTrainingMode := (sl = '1');
+ TakebackGame.Visible := (opponent_takebacks or ChessBoard.pTrainingMode);
+ end
+ else if (sl = CMD_GAME_OPTIONS) then // 2007.4
+ begin
+ SetClock(sr);
+ RSplitStr(sr, sl, sr);
+ opponent_takebacks := (sl = '1');
+ RSplitStr(sr, sl, sr);
+ ChessBoard.pTrainingMode := (sl = '1');
+ TakebackGame.Visible := (opponent_takebacks or ChessBoard.pTrainingMode);
+ end
+ else if (sl = CMD_SET_ADJOURNED) then // 2008.1
+ begin
+ if ((AdjournedStr = '') or (CompareStr(PlayerNickId, OpponentNickId) > 0)) then
+ begin
+ if (pos('&w&', sr) > 0) then
+ sr := StringReplace(sr, '&w&', '&b&', []) // White -> Black
+ else
+ sr := StringReplace(sr, '&b&', '&w&', []); // Black -> White
+ AdjournedStr := sr;
+ end;
+ end
+ else if (sl = CMD_CHANGE_COLOR) then
+ begin
+ ChangeColor;
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_NICK_ID) then
+ begin
+ m_strPlayerNickId := sr;
+ if (CompareStr(PlayerNickId, OpponentNickId) < 0) then
+ begin
+ StartStandartGameConnected.Enabled := TRUE;
+ StartPPRandomGameConnected.Enabled := TRUE;
+ _PlayerColor := fcWhite;
+ if (not FReadCommonSettings(TRUE)) then
+ RSendData(CMD_NO_SETTINGS);
+ end
+ else
+ begin
+ StartStandartGameConnected.Enabled := FALSE;
+ StartPPRandomGameConnected.Enabled := FALSE;
+ _PlayerColor := fcBlack;
+ FReadCommonSettings(FALSE);
+ end; // if CompareStr
+
+ RUpdateChessBoardCaption;
+ end
+ else if (sl = CMD_POSITION) then
+ begin
+ if (Assigned(ChessBoard)) then
+ ChessBoard.SetPosition(sr);
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_NO_SETTINGS) then
+ begin
+ FReadCommonSettings(TRUE);
+ end
+ else if (sl = CMD_TRANSMITTING) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(33),
+ mtCustom, [mbOK], mfMsgLeave); // Game transmition is not supported by this client!
+ end;
+
+ mGame:
+ if (sl = CMD_DRAW) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(10), mtConfirmation,
+ [mbYes, mbNo], mfMsgDraw) // Draw?
+ end
+ else if (sl = CMD_ABORT) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(11), mtConfirmation,
+ [mbYes, mbNo], mfMsgAbort); // Can we abort the game?
+ end
+ else if (sl = CMD_RESIGN) then
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ if (_PlayerColor = fcWhite) then
+ FWriteToGameLog(sLineBreak + 'Black resigns' + sLineBreak + '1 - 0')
+ else
+ FWriteToGameLog(sLineBreak + 'White resigns' + sLineBreak + '0 - 1');
+ FlushGameLog;
+{$ENDIF}
+ if (Transmittable) then
+ begin
+ RSplitStr(sr, sl, sr);
+ if (sl = 'w') then
+ wstrMsg := TLocalizer.Instance.GetMessage(31) // White resigns.
+ else // (sl = 'b')
+ wstrMsg := TLocalizer.Instance.GetMessage(32) // Black resigns.
+ end
+ else
+ wstrMsg := TLocalizer.Instance.GetMessage(12); // I resign. You win this game. Congratulations!
+
+ m_Dialogs.MessageDlg(wstrMsg, mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grWin);
+
+ RRetransmit(CMD_RESIGN + IfThen((_PlayerColor = fcWhite), ' b', ' w'));
+ end
+ else if (sl = CMD_ABORT_ACCEPTED) then
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('*');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(13), mtCustom,
+ [mbOK], mfNone); // The game is aborted.
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_ABORT_DECLINED) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(14),
+ mtCustom, [mbOK], mfNone) // Sorry, but we have to finish this game.
+ end
+ else if (sl = CMD_DRAW_ACCEPTED) then
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('=' + sLineBreak + '1/2 - 1/2');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(15), mtCustom, [mbOK], mfNone); // The game is drawn.
+ ChessBoard.WriteGameToBase(grDraw);
+
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_DRAW_DECLINED) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(16), mtCustom, [mbOK], mfNone) // No draw, sorry.
+ end
+ else if (sl = CMD_SWITCH_CLOCK) then
+ begin
+ with ChessBoard do
+ begin
+ RSplitStr(sr, sl, sr);
+
+ if (Transmittable) then
+ begin
+ if (PositionColor = fcWhite) then
+ Time[fcBlack] := TChessClock.ConvertFromFullStr(sl)
+ else
+ Time[fcWhite] := TChessClock.ConvertFromFullStr(sl);
+ end
+ else
+ begin
+ if (_PlayerColor = fcWhite) then
+ Time[fcBlack] := TChessClock.ConvertFromFullStr(sl)
+ else
+ Time[fcWhite] := TChessClock.ConvertFromFullStr(sl);
+ end;
+ end; // with
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_FLAG) then
+ with ChessBoard do
+ begin
+ if (Time[_PlayerColor] = 0.0) then
+ begin
+ RSendData(CMD_FLAG_YES);
+ RRetransmit(CMD_FLAG_YES);
+
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ if (_PlayerColor = fcWhite) then
+ FWriteToGameLog(sLineBreak + 'White forfeits on time')
+ else
+ FWriteToGameLog(sLineBreak + 'Black forfeits on time');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(17), mtCustom, [mbOK], mfNone); // You forfeited on time.
+ ChessBoard.WriteGameToBase(grLostTime);
+ end
+ else
+ RSendData(CMD_FLAG_NO);
+ end // with
+ else
+ if (sl = CMD_FLAG_YES) then
+ begin
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ if (_PlayerColor = fcWhite) then
+ FWriteToGameLog(sLineBreak + 'Black forfeits on time')
+ else
+ FWriteToGameLog(sLineBreak + 'White forfeits on time');
+ FlushGameLog;
+{$ENDIF}
+ if (Transmittable) then
+ begin
+ if (_PlayerColor = fcWhite) then
+ wstrMsg := TLocalizer.Instance.GetMessage(29) // Black forfeits on time.
+ else
+ wstrMsg := TLocalizer.Instance.GetMessage(30); // White forfeits on time.
+ end
+ else
+ wstrMsg := TLocalizer.Instance.GetMessage(18); // Your opponent forfeited on time.
+
+ m_Dialogs.MessageDlg(wstrMsg, mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grWinTime);
+
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_FLAG_NO) then
+ with ChessBoard do
+ begin
+ case _PlayerColor of
+ fcWhite:
+ if (Time[fcBlack] = 0.0) then
+ RSendData(CMD_FLAG);
+ fcBlack:
+ if (Time[fcWhite] = 0.0) then
+ RSendData(CMD_FLAG);
+ end // case
+ end // with
+ else if (sl = CMD_PAUSE_GAME) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(19), mtConfirmation,
+ [mbYes, mbNo], mfCanPause); // Can we pause the game?
+ end
+ else if (sl = CMD_PAUSE_GAME_YES) then
+ begin
+ PauseGame;
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_PAUSE_GAME_NO) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(20), mtCustom,
+ [mbOk], mfNone); // No pause, sorry.
+ end
+ else if (sl = CMD_CONTINUE_GAME) then
+ begin
+ if (Assigned(m_ContinueForm)) then
+ m_ContinueForm.Shut;
+ if (Transmittable) then
+ m_Dialogs.CloseNoneDialogs;
+ ContinueGame;
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_TAKEBACK) then
+ begin
+ if (you_takebacks or ChessBoard.pTrainingMode) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(21),
+ mtConfirmation, [mbYes, mbNo], mfMsgTakeBack); // 'May I take back last move?'
+ end
+ else
+ RSendData(CMD_TAKEBACK_NO)
+ end
+ else if (sl = CMD_ADJOURN_GAME) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(22),
+ mtConfirmation, [mbYes, mbNo], mfMsgAdjourn); // Can we adjourn this game?
+ end
+ else if (sl = CMD_ADJOURN_GAME_YES) then
+ begin
+ FAdjournGame;
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_ADJOURN_GAME_NO) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(23), mtCustom, [mbOk],
+ mfNone); // No adjourns, sorry.
+ end
+ else
+ if (sl = CMD_TAKEBACK_YES) then
+ begin
+ ChessBoard.TakeBack;
+ FBuildAdjournedStr;
+ TakebackGame.Enabled:= (ChessBoard.NMoveDone > 0);
+{$IFDEF GAME_LOG}
+ FWriteToGameLog(' <takeback>');
+{$ENDIF}
+ ChessBoard.SwitchClock(ChessBoard.PositionColor);
+ RRetransmit(strSavedCmd);
+ end
+ else if (sl = CMD_TAKEBACK_NO) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(24), mtCustom,
+ [mbOK], mfNone); // Sorry, no takebacks!
+ end
+ else if (sl = CMD_POSITION) then
+ begin
+ if (CompareStr(PlayerNickId, OpponentNickId) > 0) then
+ begin
+ ChessBoard.StopClock;
+ ChessBoard.Mode := mView;
+ ChessBoard.SetPosition(sr);
+ end;
+ RRetransmit(strSavedCmd);
+ end
+ else
+ begin
+ with ChessBoard do
+ begin
+ if ((_PlayerColor <> PositionColor) or Transmittable) then
+ begin
+ if (DoMove(sl)) then
+ begin
+{$IFDEF GAME_LOG}
+ if ((PositionColor = fcBlack) or (not move_done)) then
+ begin
+ FWriteToGameLog(' ' + IntToStr(NMoveDone) + '.');
+ if (PositionColor = fcWhite) then
+ FWriteToGameLog(' ...');
+ end;
+ FWriteToGameLog(' ' + sl);
+{$ENDIF}
+ move_done := TRUE;
+ TakebackGame.Enabled := TRUE;
+ FBuildAdjournedStr; // AdjournedStr ïîìå÷àåòñÿ òîëüêî ïðè âõîäÿùåì õîäå ïðîòèâíèêà
+ end; // if (DoMove...
+ end; // if (_Player...
+ end; // with ChessBoard
+
+ RRetransmit(strSavedCmd);
+ end;
+ end; // case ChessBoard.Mode
+end;
+
+
+procedure TManager.RRetransmit(const strCmd: string);
+begin
+end;
+
+
+procedure TManager.ROnDestroy;
+begin
+ TLocalizer.Instance.DeleteSubscriber(self);
+
+ if (m_bConnectionOccured) then
+ begin
+ FWritePrivateSettings;
+ if (not Transmittable) then
+ FWriteCommonSettings;
+ end;
+
+ m_ExtBaseList.Free;
+
+ if (Assigned(ChessBoard)) then
+ begin
+ ChessBoard.Release;
+ m_ChessBoard := nil;
+ end;
+ m_Dialogs.Free;
+
+ TIniSettings.FreeInstance;
+end;
+
+
+procedure TManager.FormDestroy(Sender: TObject);
+begin
+ ROnDestroy;
+end;
+
+
+procedure TManager.LookFeelOptionsActionExecute(Sender: TObject);
+var
+ lookFeelOptionsForm: TLookFeelOptionsForm;
+begin
+ lookFeelOptionsForm := (m_Dialogs.CreateDialog(TLookFeelOptionsForm) as TLookFeelOptionsForm);
+ with lookFeelOptionsForm, ChessBoard do
+ begin
+ AnimationComboBox.ItemIndex := ord(animation);
+ HilightLastMoveBox.Checked := LastMoveHilighted;
+ FlashIncomingMoveBox.Checked := FlashOnMove;
+ CoordinatesBox.Checked := CoordinatesShown;
+ StayOnTopBox.Checked := StayOnTop;
+ ExtraExitBox.Checked := extra_exit;
+ end;
+ lookFeelOptionsForm.Show;
+end;
+
+
+procedure TManager.AbortGameClick(Sender: TObject);
+begin
+ RSendData(CMD_ABORT);
+end;
+
+procedure TManager.DrawGameClick(Sender: TObject);
+begin
+ RSendData(CMD_DRAW);
+end;
+
+procedure TManager.ResignGameClick(Sender: TObject);
+begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(25),
+ mtConfirmation, [mbYes, mbNo], mfMsgResign); // Do you really want to resign?
+end;
+
+
+procedure TManager.ChangeColorConnectedClick(Sender: TObject);
+begin
+ if (Transmittable) then
+ begin
+ ChangeColor;
+ end
+ else if (ChessBoard.Mode = mView) then
+ begin
+ ChangeColor;
+
+ RSendData(CMD_CHANGE_COLOR);
+ RRetransmit(CMD_CHANGE_COLOR);
+ end;
+end;
+
+
+procedure TManager.GameOptionsConnectedClick(Sender: TObject);
+var
+ GameOptionsForm: TGameOptionsForm;
+ i: integer;
+begin
+ GameOptionsForm := (m_Dialogs.CreateDialog(TGameOptionsForm) as TGameOptionsForm);
+ with GameOptionsForm do
+ begin
+ EqualTimeCheckBox.Checked := ((you_unlimited = opponent_unlimited) and
+ (you_time = opponent_time) and (you_inc = opponent_inc));
+ YouUnlimitedCheckBox.Checked:= you_unlimited;
+ OpponentUnlimitedCheckBox.Checked:= opponent_unlimited;
+ YouMinUpDown.Position := you_time;
+ YouIncUpDown.Position := you_inc;
+ OpponentMinUpDown.Position := opponent_time;
+ OpponentIncUpDown.Position := opponent_inc;
+ AutoFlagCheckBox.Checked := ChessBoard.AutoFlag;
+ TakeBackCheckBox.Checked := you_takebacks;
+ TrainingEnabledCheckBox.Checked := ChessBoard.pTrainingMode;
+ for i := 1 to m_ExtBaseList.Count - 1 do
+ begin
+ ExtBaseComboBox.Items.Append(m_ExtBaseList[i]);
+ if (m_strExtBaseName = m_ExtBaseList[i]) then
+ ExtBaseComboBox.ItemIndex := i;
+ end;
+ UsrBaseCheckBox.Checked := ChessBoard.pUseUserBase;
+ GamePauseCheckBox.Checked := (can_pause_game and (m_lwOpponentClientVersion >= 200706));
+ GameAdjournCheckBox.Checked := (can_adjourn_game and (m_lwOpponentClientVersion >= 200801));
+ Show;
+ end; // with
+end;
+
+
+procedure TManager.StartStandartGameConnectedClick(Sender: TObject);
+var
+ strPositionCmd: string;
+begin
+ with ChessBoard do
+ begin
+ SetClock;
+ InitPosition;
+ ResetMoveList;
+
+ strPositionCmd := CMD_POSITION + ' ' + GetPosition;
+ RSendData(strPositionCmd);
+ RSendData(CMD_START_GAME);
+
+ move_done:= FALSE;
+ TakebackGame.Enabled := FALSE;
+ Mode := mGame;
+ SwitchClock(ChessBoard.PositionColor);
+
+ RRetransmit(strPositionCmd);
+ RRetransmit(CMD_START_GAME);
+ end;
+{$IFDEF GAME_LOG}
+ FInitGameLog;
+{$ENDIF}
+end;
+
+
+procedure TManager.SetClock;
+begin
+ if (not Assigned(ChessBoard)) then
+ exit;
+
+ with ChessBoard do
+ begin
+ Unlimited[_PlayerColor] := you_unlimited;
+ Time[_PlayerColor] := EncodeTime(you_time div 60, you_time mod 60, 0,0);
+ if (_PlayerColor = fcWhite) then
+ begin
+ Unlimited[fcBlack] := opponent_unlimited;
+ Time[fcBlack] := EncodeTime(opponent_time div 60,
+ opponent_time mod 60, 0,0);
+ end
+ else
+ begin
+ Unlimited[fcWhite] := opponent_unlimited;
+ Time[fcWhite] := EncodeTime(opponent_time div 60,
+ opponent_time mod 60, 0,0);
+ end;
+ end;
+end;
+
+procedure TManager.RSetChessBoardToView;
+var
+ clockTime: string;
+begin
+ with ChessBoard do
+ begin
+ clockTime := NO_CLOCK_TIME;
+ SetClock(clockTime);
+ Mode := mView;
+ Caption := CHESS4NET_TITLE;
+ ChessBoard.icon := Chess4NetIcon;
+ InitPosition;
+
+ Left:= (Screen.Width - Width) div 2;
+ Top:= (Screen.Height - Height) div 2;
+ Show;
+ end;
+end;
+
+
+procedure TManager.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if (Assigned(Connector) and Connector.connected) then
+ begin
+ if (Assigned(m_Dialogs)) then
+ begin
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(26), mtConfirmation, [mbYes, mbNo], mfMsgClose); // Do you want to exit?
+ Action:= caNone;
+ end
+ else
+ Release;
+ end
+ else
+// Release;
+ Action := caFree;
+end;
+
+
+procedure TManager.RReleaseWithConnectorGracefully;
+begin
+ ConnectorTimer.Enabled := TRUE;
+ if (Assigned(Connector)) then
+ Connector.Close;
+end;
+
+
+procedure TManager.ConnectorTimerTimer(Sender: TObject);
+begin
+ ConnectorTimer.Enabled := FALSE;
+ Release;
+end;
+
+
+procedure TManager.StartPPRandomGameConnectedClick(Sender: TObject);
+var
+ strPositionCmd: string;
+begin
+ with ChessBoard do
+ begin
+ SetClock;
+ PPRandom;
+ ResetMoveList;
+
+ strPositionCmd := CMD_POSITION + ' ' + GetPosition;
+ RSendData(strPositionCmd);
+ RSendData(CMD_START_GAME);
+
+ Mode := mGame;
+ move_done := FALSE;
+ TakebackGame.Enabled := FALSE;
+ SwitchClock(ChessBoard.PositionColor);
+
+ RRetransmit(strPositionCmd);
+ RRetransmit(CMD_START_GAME);
+ end;
+{$IFDEF GAME_LOG}
+ FInitGameLog;
+{$ENDIF}
+end;
+
+
+procedure TManager.TakebackGameClick(Sender: TObject);
+begin
+ RSendData(CMD_TAKEBACK);
+end;
+
+
+constructor TManager.RCreate;
+begin
+// inherited Create(Application);
+ inherited Create(nil);
+end;
+
+
+{$IFDEF AND_RQ}
+class function TManager.Create: TManager;
+begin
+ Result := TManagerDefault.Create;
+end;
+{$ENDIF}
+
+{$IFDEF QIP}
+class function TManager.Create(const accName: WideString; const protoDllHandle: integer): TManager;
+begin
+ Result := TManagerDefault.Create(accName, protoDllHandle);
+end;
+{$ENDIF}
+
+{$IFDEF TRILLIAN}
+class function TManager.Create(const vContactlistEntry: TTtkContactListEntry): TManager;
+begin
+ Result := TManagerDefault.Create(vContactlistEntry);
+end;
+{$ENDIF}
+
+procedure TManager.DialogFormHandler(modSender: TModalForm; msgDlgID: TModalFormID);
+var
+ modRes: TModalResult;
+ s, prevClock: string;
+ strCmd: string;
+begin
+ modRes := modSender.ModalResult;
+ case msgDlgID of
+ mfNone: ;
+
+ mfMsgClose:
+ begin
+ if modRes = mrYes then
+ begin
+{$IFDEF GAME_LOG}
+ if ChessBoard.Mode = mGame then
+ begin
+ FWriteToGameLog('*');
+ FlushGameLog;
+ end;
+{$ENDIF}
+{$IFDEF SKYPE}
+ FShowCredits;
+{$ENDIF}
+ Release;
+ end;
+ end;
+
+ mfMsgLeave, mfIncompatible:
+ begin
+{$IFDEF SKYPE}
+ FShowCredits;
+{$ENDIF}
+ if (Assigned(Connector) and Connector.Connected) then
+ RReleaseWithConnectorGracefully
+ else
+ Close;
+ end;
+
+ mfMsgAbort:
+ begin
+ if ChessBoard.Mode = mGame then
+ begin
+ if (modRes = mrNo) or (modRes = mrNone) then
+ RSendData(CMD_ABORT_DECLINED)
+ else
+ begin
+ RSendData(CMD_ABORT_ACCEPTED);
+ RRetransmit(CMD_ABORT_ACCEPTED);
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('*');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(13), mtCustom,
+ [mbOK], mfNone); // The game is aborted.
+ end;
+ end;
+ end;
+
+ mfMsgResign:
+ begin
+ if ChessBoard.Mode = mGame then
+ begin
+ if modRes = mrYes then
+ begin
+ FExitGameMode;
+ RSendData(CMD_RESIGN);
+ RRetransmit(CMD_RESIGN + IfThen((_PlayerColor = fcWhite), ' w', ' b'));
+ ChessBoard.WriteGameToBase(grLost);
+{$IFDEF GAME_LOG}
+ if (_PlayerColor = fcWhite) then
+ FWriteToGameLog(sLineBreak + 'White resigns' + sLineBreak + '0 - 1')
+ else
+ FWriteToGameLog(sLineBreak + 'Black resigns' + sLineBreak + '1 - 0');
+ FlushGameLog;
+{$ENDIF}
+ end;
+ end;
+ end;
+
+ mfMsgDraw:
+ begin
+ if ChessBoard.Mode = mGame then
+ begin
+ if (modRes = mrNo) or (modRes = mrNone) then
+ RSendData(CMD_DRAW_DECLINED)
+ else
+ begin
+ RSendData(CMD_DRAW_ACCEPTED);
+ RRetransmit(CMD_DRAW_ACCEPTED);
+
+ FExitGameMode;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('=' + sLineBreak + '1/2 - 1/2');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(15), mtCustom, [mbOK], mfNone);
+ ChessBoard.WriteGameToBase(grDraw); // The game is drawn.
+ end;
+ end;
+ end;
+
+ mfMsgTakeBack:
+ begin
+ if ChessBoard.Mode = mGame then
+ begin
+ if modRes = mrYes then
+ begin
+ RSendData(CMD_TAKEBACK_YES);
+ RRetransmit(CMD_TAKEBACK_YES);
+
+ ChessBoard.TakeBack;
+ FBuildAdjournedStr;
+ TakebackGame.Enabled:= (ChessBoard.NMoveDone > 0);
+{$IFDEF GAME_LOG}
+ FWriteToGameLog(' <takeback>');
+{$ENDIF}
+ ChessBoard.SwitchClock(ChessBoard.PositionColor);
+ end
+ else
+ RSendData(CMD_TAKEBACK_NO);
+ end;
+ end;
+
+ mfMsgAdjourn:
+ begin
+ if ChessBoard.Mode = mGame then
+ begin
+ if modRes = mrYes then
+ begin
+ RSendData(CMD_ADJOURN_GAME_YES);
+ RRetransmit(CMD_ADJOURN_GAME_YES);
+ FAdjournGame;
+ end
+ else
+ RSendData(CMD_ADJOURN_GAME_NO);
+ end;
+ end;
+
+ mfConnecting:
+ begin
+ m_ConnectingForm := nil;
+ if modRes = mrAbort then
+ Close; // ConnectionAbort;
+ end;
+
+ mfGameOptions:
+ begin
+ if (ChessBoard.Mode <> mGame) and (modRes = mrOK) then
+ with (modSender as TGameOptionsForm) do
+ begin
+ prevClock := ClockToStr;
+ you_unlimited := YouUnlimitedCheckBox.Checked;
+ opponent_unlimited := OpponentUnlimitedCheckBox.Checked;
+ you_time := StrToInt(YouMinEdit.Text);
+ you_inc := StrToInt(YouIncEdit.Text);
+ opponent_time := StrToInt(OpponentMinEdit.Text);
+ opponent_inc := StrToInt(OpponentIncEdit.Text);
+ ChessBoard.AutoFlag := AutoFlagCheckBox.Checked;
+ // Îòîáðàæåíèå íà äîñêå
+ SetClock;
+ // ñèíõðîíèçàöèÿ âðåìåíè ó îïïîíåíòà
+ s := ClockToStr;
+ if (m_lwOpponentClientVersion >= 200705) then
+ begin
+ if (prevClock <> s) then
+ begin
+ strCmd := CMD_SET_CLOCK + ' ' + s;
+ RSendData(strCmd);
+ RRetransmit(strCmd);
+ end;
+ RSendData(CMD_ALLOW_TAKEBACKS + IfThen(TakeBackCheckBox.Checked, ' 1', ' 0'));
+ end;
+ you_takebacks := TakeBackCheckBox.Checked;
+ if (m_lwOpponentClientVersion >= 200706) then
+ begin
+ if can_pause_game <> GamePauseCheckBox.Checked then
+ begin
+ can_pause_game := GamePauseCheckBox.Checked;
+ RSendData(CMD_CAN_PAUSE_GAME + IfThen(can_pause_game, ' 1', ' 0'))
+ end;
+ end;
+ if (m_lwOpponentClientVersion >= 200801) then
+ begin
+ if can_adjourn_game <> GameAdjournCheckBox.Checked then
+ begin
+ can_adjourn_game := GameAdjournCheckBox.Checked;
+ RSendData(CMD_CAN_ADJOURN_GAME + IfThen(can_adjourn_game, ' 1', ' 0'))
+ end;
+ end;
+ // Training mode
+ if (m_lwOpponentClientVersion >= 200705) and (ChessBoard.pTrainingMode <> TrainingEnabledCheckBox.Checked) then
+ begin
+ RSendData(CMD_SET_TRAINING + IfThen(TrainingEnabledCheckBox.Checked, ' 1', ' 0'));
+ end;
+ ChessBoard.pTrainingMode := TrainingEnabledCheckBox.Checked;
+ m_strExtBaseName := m_ExtBaseList[ExtBaseComboBox.ItemIndex];
+ if (m_strExtBaseName <> '') then
+ ChessBoard.SetExternalBase(Chess4NetPath + m_strExtBaseName)
+ else
+ ChessBoard.UnsetExternalBase;
+ ChessBoard.pUseUserBase := UsrBaseCheckBox.Checked;
+ GamePause.Visible := can_pause_game;
+ TakebackGame.Visible := (ChessBoard.pTrainingMode or opponent_takebacks);
+
+ if (m_lwOpponentClientVersion < 200705) then // 2007.4
+ begin
+ if ChessBoard.pTrainingMode then
+ s := s + ' 1 1'
+ else
+ s := s + IfThen(you_takebacks, ' 1 0', ' 0 0');
+ RSendData(CMD_GAME_OPTIONS + ' ' + s);
+ end;
+ end;
+ end;
+
+ mfLookFeel:
+ begin
+ with (modSender as TLookFeelOptionsForm), ChessBoard do
+ begin
+ animation := TAnimation(AnimationComboBox.ItemIndex);
+ LastMoveHilighted := HilightLastMoveBox.Checked;
+ FlashOnMove := FlashIncomingMoveBox.Checked;
+ CoordinatesShown := CoordinatesBox.Checked;
+ StayOnTop := StayOnTopBox.Checked;
+ extra_exit := ExtraExitBox.Checked;
+ end;
+ end;
+
+ mfContinue:
+ begin
+ m_ContinueForm := nil;
+ if modRes = mrOk then
+ begin
+ RSendData(CMD_CONTINUE_GAME);
+ RRetransmit(CMD_CONTINUE_GAME);
+ ContinueGame;
+ end;
+ end;
+
+ mfCanPause:
+ begin
+ if modRes = mrYes then
+ begin
+ RSendData(CMD_PAUSE_GAME_YES);
+ RRetransmit(CMD_PAUSE_GAME_YES);
+ PauseGame;
+ end
+ else // modRes = mrNo
+ RSendData(CMD_PAUSE_GAME_NO);
+ end;
+
+ mfDontShowDlg:
+ begin
+ if ((modSender as TDontShowMessageDlg).DontShow) then
+ m_iDontShowLastVersion := m_iQueriedDontShowLastVersion;
+ end;
+
+ end;
+end;
+
+{$IFDEF GAME_LOG}
+procedure TManager.FInitGameLog;
+var
+ s: string;
+begin
+ if ((not m_bConnectionOccured) or m_bTransmittable) then
+ exit;
+
+ gameLog := '';
+
+ LongTimeFormat := HOUR_TIME_FORMAT;
+ FWriteToGameLog('[' + DateTimeToStr(Now) + ']' + sLineBreak);
+
+ FWriteToGameLog(RGetGameName);
+
+ if not (you_unlimited and opponent_unlimited) then
+ begin
+ FWriteToGameLog(' (');
+ case _PlayerColor of
+ fcWhite:
+ begin
+ if (not you_unlimited) then
+ begin
+ FWriteToGameLog(IntToStr(you_time));
+ if (you_inc > 0) then
+ FWriteToGameLog('.' + IntToStr(you_inc));
+ end
+ else
+ FWriteToGameLog('inf');
+
+ FWriteToGameLog(':');
+
+ if (not opponent_unlimited) then
+ begin
+ FWriteToGameLog(IntToStr(opponent_time));
+ if (opponent_inc > 0) then
+ FWriteToGameLog('.' + IntToStr(opponent_inc));
+ end
+ else
+ FWriteToGameLog('inf');
+ end;
+
+ fcBlack:
+ begin
+ if (not opponent_unlimited) then
+ begin
+ FWriteToGameLog(IntToStr(opponent_time));
+ if (opponent_inc > 0) then
+ FWriteToGameLog('.' + IntToStr(opponent_inc));
+ end
+ else
+ FWriteToGameLog('inf');
+
+ FWriteToGameLog(':');
+
+ if (not you_unlimited) then
+ begin
+ FWriteToGameLog(IntToStr(you_time));
+ if (you_inc > 0) then
+ FWriteToGameLog('.' + IntToStr(you_inc));
+ end
+ else
+ FWriteToGameLog('inf');
+ end;
+ end;
+ FWriteToGameLog(')');
+ end;
+ FWriteToGameLog(sLineBreak);
+
+ s := ChessBoard.GetPosition;
+ if (s <> INITIAL_CHESS_POSITION) then
+ FWriteToGameLog(s + sLineBreak);
+end;
+
+
+procedure TManager.FWriteToGameLog(const s: string);
+begin
+ if ((not m_bConnectionOccured) or m_bTransmittable) then
+ exit;
+
+ gameLog := gameLog + s;
+end;
+
+
+procedure TManager.FlushGameLog;
+var
+ gameLogFile: TextFile;
+begin
+ if ((not m_bConnectionOccured) or m_bTransmittable) then
+ exit;
+
+ if (not move_done) then
+ exit;
+
+ AssignFile(gameLogFile, Chess4NetGamesLogPath + GAME_LOG_FILE);
+{$I-}
+ Append(gameLogFile);
+{$I+}
+ if (IOResult <> 0) then
+ begin
+ Rewrite(gameLogFile);
+ if (IOResult = 0) then
+ writeln(gameLogFile, gameLog);
+ end
+ else
+ writeln(gameLogFile, sLineBreak + gameLog);
+
+ CloseFile(gameLogFile);
+{$IFDEF SKYPE}
+ CreateLinkForGameLogFile;
+{$ENDIF}
+end;
+{$ENDIF}
+
+procedure TManager.FPopulateExtBaseList;
+var
+ sr: TSearchRec;
+ extBaseName: string;
+begin
+ m_ExtBaseList.Append('');
+ if (FindFirst(Chess4NetPath + '*.pos', faAnyFile, sr) = 0) then
+ begin
+ repeat
+ extBaseName := LeftStr(sr.Name, length(sr.Name) - length(ExtractFileExt(sr.Name)));
+ if (extBaseName <> USR_BASE_NAME) and FileExists(Chess4NetPath + extBaseName + '.mov') then
+ m_ExtBaseList.Append(extBaseName);
+ until FindNext(sr) <> 0;
+ end; // if
+ FindClose(sr);
+end;
+
+
+procedure TManager.RCreateAndPopulateExtBaseList;
+begin
+ m_ExtBaseList := TStringList.Create;
+ FPopulateExtBaseList;
+ m_strExtBaseName := '';
+end;
+
+
+procedure TManager.RReadPrivateSettings;
+var
+ initialClockTime: string;
+begin
+ // Îáùèå íàñòðîéêè ïî óìîë÷àíèþ
+ initialClockTime := INITIAL_CLOCK_TIME;
+ SetClock(initialClockTime);
+
+ ChessBoard.AutoFlag := TRUE;
+ you_takebacks := FALSE;
+ opponent_takebacks := FALSE;
+
+ // Reading private settings
+ ChessBoard.animation := TIniSettings.Instance.Animation;
+ ChessBoard.LastMoveHilighted := TIniSettings.Instance.LastMoveHilighted;
+ ChessBoard.FlashOnMove := TIniSettings.Instance.FlashOnMove;
+ ChessBoard.CoordinatesShown := TIniSettings.Instance.CoordinatesShown;
+ // TODO: read screen position and size
+ ChessBoard.StayOnTop := TIniSettings.Instance.StayOnTop;
+ extra_exit := TIniSettings.Instance.ExtraExit;
+ TLocalizer.Instance.ActiveLanguage := TIniSettings.Instance.ActiveLanguage;
+ m_iDontShowLastVersion := TIniSettings.Instance.DontShowLastVersion;
+{$IFDEF SKYPE}
+ m_bDontShowCredits := TIniSettings.Instance.DontShowCredits;
+{$ENDIF}
+end;
+
+
+function TManager.FReadCommonSettings(setToOpponent: boolean): boolean;
+var
+ strClock: string;
+ bFlag: boolean;
+begin
+ if (m_lwOpponentClientVersion < 200705) then // For 2007.4 common settings are not applied
+ begin
+ Result := TRUE;
+ exit;
+ end;
+
+ Result := FALSE;
+
+ TIniSettings.Instance.SetOpponentId(OpponentId);
+ if (not TIniSettings.Instance.HasCommonSettings) then
+ exit;
+
+ if (setToOpponent) then
+ begin
+ if (_PlayerColor = TIniSettings.Instance.PlayerColor) then // Every time change the saved color to opposite one
+ begin
+ ChangeColor;
+ RSendData(CMD_CHANGE_COLOR);
+ RRetransmit(CMD_CHANGE_COLOR);
+ end;
+
+ strClock := TIniSettings.Instance.Clock;
+ if (strClock <> ClockToStr) then
+ begin
+ SetClock(strClock);
+ RSendData(CMD_SET_CLOCK + ' ' + ClockToStr);
+ end;
+
+ bFlag := TIniSettings.Instance.TrainingMode;
+ if (ChessBoard.pTrainingMode <> bFlag) then
+ begin
+ ChessBoard.pTrainingMode := bFlag;
+ RSendData(CMD_SET_TRAINING + IfThen(ChessBoard.pTrainingMode, ' 1', ' 0'));
+ end;
+
+ if (m_lwOpponentClientVersion >= 200706) then
+ begin
+ bFlag := TIniSettings.Instance.CanPauseGame;
+ if (can_pause_game <> bFlag) then
+ begin
+ can_pause_game := bFlag;
+ RSendData(CMD_CAN_PAUSE_GAME + IfThen(can_pause_game, ' 1', ' 0'));
+ end;
+ end; { if opponentClientVersion >= 200706}
+
+ if (m_lwOpponentClientVersion >= 200801) then
+ begin
+ bFlag := TIniSettings.Instance.CanAdjournGame;
+ if (can_adjourn_game <> bFlag) then
+ begin
+ can_adjourn_game := bFlag;
+ RSendData(CMD_CAN_ADJOURN_GAME + IfThen(can_adjourn_game, ' 1', ' 0'));
+ end;
+ end; { opponentClientVersion >= 200801 }
+ end; { if setToOpponent }
+
+ m_strExtBaseName := TIniSettings.Instance.ExternalBaseName;
+ if (m_strExtBaseName <> '') then
+ ChessBoard.SetExternalBase(Chess4NetPath + m_strExtBaseName)
+ else
+ ChessBoard.UnsetExternalBase;
+
+ ChessBoard.pUseUserBase := TIniSettings.Instance.UseUserBase;
+
+ bFlag := TIniSettings.Instance.AllowTakebacks;
+ if (you_takebacks <> bFlag) then
+ begin
+ you_takebacks := bFlag;
+ RSendData(CMD_ALLOW_TAKEBACKS + IfThen(you_takebacks, ' 1', ' 0'));
+ end;
+
+ ChessBoard.AutoFlag := TIniSettings.Instance.AutoFlag;
+
+ TakebackGame.Visible := (opponent_takebacks or ChessBoard.pTrainingMode);
+ GamePause.Visible := can_pause_game;
+
+ if (m_lwOpponentClientVersion >= 200801) then
+ begin
+ if (AdjournedStr <> '') then
+ begin
+ RSendData(CMD_SET_ADJOURNED + ' ' + AdjournedStr);
+ end;
+ end;
+
+ Result := TRUE;
+end;
+
+
+procedure TManager.FWritePrivateSettings;
+begin
+ // Write private settings
+ TIniSettings.Instance.Animation := ChessBoard.Animation;
+ TIniSettings.Instance.LastMoveHilighted := ChessBoard.LastMoveHilighted;
+ TIniSettings.Instance.FlashOnMove := ChessBoard.FlashOnMove;
+ TIniSettings.Instance.CoordinatesShown := ChessBoard.CoordinatesShown;
+ // TODO: write screen position
+ TIniSettings.Instance.StayOnTop := ChessBoard.StayOnTop;
+ TIniSettings.Instance.ExtraExit := extra_exit;
+ TIniSettings.Instance.ActiveLanguage := TLocalizer.Instance.ActiveLanguage;
+ if (m_iDontShowLastVersion > CHESS4NET_VERSION) then
+ TIniSettings.Instance.DontShowLastVersion := m_iDontShowLastVersion;
+{$IFDEF SKYPE}
+ if (m_bDontShowCredits) then
+ TIniSettings.Instance.DontShowCredits := m_bDontShowCredits;
+{$ENDIF}
+end;
+
+
+procedure TManager.FWriteCommonSettings;
+begin
+ TIniSettings.Instance.SetOpponentId(OpponentId);
+
+ TIniSettings.Instance.PlayerColor := _PlayerColor;
+ TIniSettings.Instance.Clock := ClockToStr;
+ TIniSettings.Instance.TrainingMode := ChessBoard.pTrainingMode;
+ TIniSettings.Instance.ExternalBaseName := m_strExtBaseName;
+ TIniSettings.Instance.UseUserBase := ChessBoard.pUseUserBase;
+ TIniSettings.Instance.AllowTakebacks := you_takebacks;
+ TIniSettings.Instance.CanPauseGame := can_pause_game;
+ TIniSettings.Instance.CanAdjournGame := can_adjourn_game;
+ TIniSettings.Instance.AutoFlag := ChessBoard.AutoFlag;
+end;
+
+
+function TManager.ClockToStr: string;
+var
+ s: string;
+begin
+ if (you_unlimited) then
+ s := 'u'
+ else
+ s := IntToStr(you_time) + ' ' + IntToStr(you_inc);
+ if (opponent_unlimited) then
+ s := s + ' u'
+ else
+ s := s + ' ' + IntToStr(opponent_time) + ' ' + IntToStr(opponent_inc);
+
+ Result := s;
+end;
+
+
+procedure TManager.ChangeColor;
+begin
+ with ChessBoard do
+ begin
+ if (_PlayerColor = fcWhite) then
+ begin
+ StartStandartGameConnected.Enabled := FALSE;
+ StartPPRandomGameConnected.Enabled := FALSE;
+ _PlayerColor := fcBlack;
+ end
+ else // fcBlack
+ begin
+ StartStandartGameConnected.Enabled := TRUE;
+ StartPPRandomGameConnected.Enabled := TRUE;
+ _PlayerColor := fcWhite;
+ end;
+ RUpdateChessBoardCaption;
+ SetClock;
+ end;
+end;
+
+
+procedure TManager.GamePauseClick(Sender: TObject);
+begin
+ RSendData(CMD_PAUSE_GAME);
+end;
+
+
+procedure TManager.PauseGame;
+begin
+ ChessBoard.StopClock;
+ if (not Transmittable) then
+ begin
+ m_ContinueForm := (m_Dialogs.CreateDialog(TContinueForm) as TContinueForm);
+ m_ContinueForm.Show;
+ end;
+end;
+
+
+procedure TManager.ContinueGame;
+begin
+ ChessBoard.SwitchClock(ChessBoard.PositionColor);
+end;
+
+procedure TManager.AboutActionExecute(Sender: TObject);
+begin
+ ShowInfo;
+end;
+
+procedure TManager.AdjournGameClick(Sender: TObject);
+begin
+ RSendData(CMD_ADJOURN_GAME);
+end;
+
+procedure TManager.StartAdjournedGameConnectedClick(Sender: TObject);
+begin
+ if (AdjournedStr <> '') then
+ begin
+ RSendData(CMD_START_ADJOURNED_GAME);
+ FStartAdjournedGame;
+ RRetransmit(CMD_GAME_CONTEXT + ' ' + RGetGameContextStr);
+ RRetransmit(CMD_CONTINUE_GAME);
+ end;
+end;
+
+
+procedure TManager.FAdjournGame;
+begin
+ if (ChessBoard.Mode <> mGame) then
+ exit;
+ FBuildAdjournedStr;
+ ChessBoard.StopClock;
+ ChessBoard.Mode := mView;
+{$IFDEF GAME_LOG}
+ FWriteToGameLog('*');
+ FlushGameLog;
+{$ENDIF}
+ m_Dialogs.MessageDlg(TLocalizer.Instance.GetMessage(27), mtCustom, [mbOK], mfNone); // The game is adjourned.
+end;
+
+procedure TManager.FExitGameMode;
+begin
+ ChessBoard.StopClock;
+ ChessBoard.Mode := mView;
+ if (move_done) then
+ AdjournedStr := '';
+end;
+
+
+function TManager.RGetGameContextStr: string;
+var
+ str: string;
+begin
+ // Result ::= <position>&<this player's color>&<time control>&<current time>
+ with ChessBoard do
+ begin
+ // <position>
+ str := ChessBoard.GetPosition + '&';
+ // <this player's color>
+ str := str + IfThen((_PlayerColor = fcWhite), 'w', 'b') + '&';
+ // <time control>
+ str := str + ClockToStr + '&';
+ // <current time>
+ str := str + TChessClock.ConvertToFullStr(Time[fcWhite], FALSE) + ' ' +
+ TChessClock.ConvertToFullStr(Time[fcBlack], FALSE);
+ end;
+
+ Result := str;
+end;
+
+
+procedure TManager.FBuildAdjournedStr;
+begin
+ AdjournedStr := RGetGameContextStr;
+end;
+
+
+procedure TManager.FStartAdjournedGame;
+begin
+ if (AdjournedStr = '') then
+ exit;
+
+ RSetGameContext(AdjournedStr);
+
+ with ChessBoard do
+ begin
+ ResetMoveList;
+ move_done := TRUE;
+ TakebackGame.Enabled := FALSE;
+ Mode := mGame;
+ SwitchClock(PositionColor);
+ end;
+{$IFDEF GAME_LOG}
+ FInitGameLog;
+{$ENDIF}
+end;
+
+
+function TManager.FGetAdjournedStr: string;
+begin
+ Result := TIniSettings.Instance.Adjourned;
+end;
+
+
+procedure TManager.FSetAdjournedStr(const strValue: string);
+begin
+ TIniSettings.Instance.Adjourned := strValue;
+end;
+
+
+procedure TManager.RSetGameContext(const strValue: string);
+var
+ str: string;
+ l: integer;
+ strPosition, strPlayerColor, strTimeControl, strCurrentTime: string;
+begin
+ if (strValue = '') then
+ exit;
+
+ // strValue ::= <position>&<this player's color>&<time control>&<current time>
+
+ str := strValue;
+
+ l := pos('&', str);
+ strPosition := LeftStr(str, l - 1);
+ str := RightStr(str, length(str) - l);
+
+ l := pos('&', str);
+ strPlayerColor := LeftStr(str, l - 1);
+ str := RightStr(str, length(str) - l);
+
+ l := pos('&', str);
+ strTimeControl := LeftStr(str, l - 1);
+ strCurrentTime := RightStr(str, length(str) - l);
+
+ SetClock(strTimeControl);
+
+ if (((_PlayerColor = fcWhite) and (strPlayerColor <> 'w')) or
+ ((_PlayerColor = fcBlack) and (strPlayerColor <> 'b'))) then
+ ChangeColor;
+
+ with ChessBoard do
+ begin
+ SetPosition(strPosition);
+
+ RSplitStr(strCurrentTime, str, strCurrentTime);
+
+ Time[fcWhite] := TChessClock.ConvertFromFullStr(str);
+ Time[fcBlack] := TChessClock.ConvertFromFullStr(strCurrentTime);
+ end;
+end;
+
+
+procedure TManager.GamePopupMenuPopup(Sender: TObject);
+begin
+ N6.Visible := ((not Transmittable) and
+ (AdjournGame.Visible or GamePause.Visible or TakebackGame.Visible));
+ ResignGame.Enabled := move_done;
+ DrawGame.Enabled := (move_done and (_PlayerColor = ChessBoard.PositionColor));
+end;
+
+
+procedure TManager.RLocalize;
+begin
+ with TLocalizer.Instance do
+ begin
+ StartAdjournedGameConnected.Caption := GetLabel(51);
+ StartStandartGameConnected.Caption := GetLabel(52);
+ StartPPRandomGameConnected.Caption := GetLabel(53);
+ ChangeColorConnected.Caption := GetLabel(54);
+ GameOptionsConnected.Caption := GetLabel(55);
+ LookFeelOptionsAction.Caption := GetLabel(56);
+ AboutAction.Caption := GetLabel(57);
+
+ AbortGame.Caption := GetLabel(58);
+ DrawGame.Caption := GetLabel(59);
+ ResignGame.Caption := GetLabel(60);
+ AdjournGame.Caption := GetLabel(61);
+ GamePause.Caption := GetLabel(62);
+ TakebackGame.Caption := GetLabel(63);
+ BroadcastAction.Caption := GetLabel(69);
+ end;
+end;
+
+
+function TManager.FGetOpponentNickId: string;
+begin
+ if ((not m_bTransmittable) or (m_strOverridedOpponentNickId = '')) then
+ Result := OpponentNick + OpponentId
+ else
+ Result := m_strOverridedOpponentNickId;
+end;
+
+
+procedure TManager.FSetTransmittable(bValue: boolean);
+begin
+ m_bTransmittable := bValue;
+ if (bValue) then
+ begin
+ // connected menu
+ StartAdjournedGameConnected.Visible := FALSE;
+ StartStandartGameConnected.Visible := FALSE;
+ StartPPRandomGameConnected.Visible := FALSE;
+// ChangeColorConnected.Visible := FALSE;
+ GameOptionsConnected.Visible := FALSE;
+
+{$IFDEF SKYPE}
+ BroadcastAction.Visible := FALSE;
+{$ENDIF}
+
+ ChessBoard.ViewGaming := TRUE;
+ end;
+end;
+
+
+function TManager.FGetPlayerColor: TFigureColor;
+begin
+ if (Assigned(ChessBoard)) then
+ Result := ChessBoard.PlayerColor
+ else
+ Result := fcWhite;
+end;
+
+
+procedure TManager.FSetPlayerColor(Value: TFigureColor);
+begin
+ if (Assigned(ChessBoard)) then
+ ChessBoard.PlayerColor := Value;
+end;
+
+
+procedure TManager.ActionListUpdate(Action: TBasicAction;
+ var Handled: Boolean);
+begin
+ AdjournGame.Visible := (can_adjourn_game and (not Transmittable));
+ AdjournGame.Enabled := ((adjournedStr <> '') and move_done);
+ StartAdjournedGameConnected.Visible := ((adjournedStr <> '') and (not Transmittable));
+end;
+
+{$IFDEF SKYPE}
+procedure TManager.FShowCredits;
+
+ function NFridayThe13: boolean; // just for fun!
+ begin
+ Result := ((DayOfTheMonth(Today) = 13) and (DayOfWeek(Today) = 6));
+ end;
+
+begin // TManager.FShowCredits
+ if (m_bConnectionOccured and (not m_bDontShowCredits) and (not NFridayThe13)) then
+ begin
+ with TCreditsForm.Create(nil) do
+ try
+ ShowModal;
+ m_bDontShowCredits := DontShowAgain;
+ finally
+ Free;
+ end;
+ end;
+end;
+{$ENDIF}
+
+function TManager.RGetGameName: string;
+begin
+ if (_PlayerColor = fcWhite) then
+ Result := PlayerNick + ' - ' + OpponentNick
+ else // fcBlack
+ Result := OpponentNick + ' - ' + PlayerNick;
+end;
+
+
+procedure TManager.BroadcastActionExecute(Sender: TObject);
+begin
+ RBroadcast;
+end;
+
+
+procedure TManager.RBroadcast;
+begin
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TManagerDefault
+
+{$IFDEF AND_RQ}
+constructor TManagerDefault.Create;
+begin
+ RCreate;
+end;
+{$ENDIF}
+
+{$IFDEF QIP}
+constructor TManagerDefault.Create(const accName: WideString; const protoDllHandle: integer);
+begin
+ iProtoDllHandle := protoDllHandle;
+ wAccName := accName;
+
+ RCreate;
+end;
+{$ENDIF}
+
+{$IFDEF TRILLIAN}
+constructor TManagerDefault.Create(const vContactlistEntry: TTtkContactListEntry);
+begin
+ contactListEntry := vContactlistEntry;
+ RCreate;
+end;
+{$ENDIF}
+
+procedure TManagerDefault.ROnCreate;
+begin
+ try
+ RCreateChessBoardAndDialogs;
+
+ TLocalizer.Instance.AddSubscriber(self);
+ RLocalize;
+
+ RSetChessBoardToView;
+ RReadPrivateSettings;
+
+{$IFDEF AND_RQ}
+ Connector := TConnector.Create(RQ_GetChatUIN, ConnectorHandler);
+{$ENDIF}
+{$IFDEF QIP}
+// QIPConnectionError := FALSE;
+ Connector := TConnector.Create(wAccName, iProtoDllHandle, ConnectorHandler);
+{$ENDIF}
+{$IFDEF TRILLIAN}
+ Connector := TConnector.Create(@contactlistEntry, ConnectorHandler);
+{$ENDIF}
+
+ RCreateAndPopulateExtBaseList;
+
+ // nicks initialisation
+{$IFDEF AND_RQ}
+ PlayerNick := RQ_GetDisplayedName(RQ_GetCurrentUser);
+ OpponentNick := RQ_GetDisplayedName(RQ_GetChatUIN);
+ OpponentId := IntToStr(RQ_GetChatUIN);
+{$ENDIF}
+{$IFDEF QIP}
+ PlayerNick := GetOwnerNick(wAccName, iProtoDllHandle);
+ OpponentNick := GetContactNick(wAccName, iProtoDllHandle);
+ OpponentId := wAccName;
+{$ENDIF}
+{$IFDEF TRILLIAN}
+ PlayerNick := trillianOwnerNick;
+ OpponentNick := contactlistEntry.name;
+ OpponentId := contactlistEntry.real_name;
+{$ENDIF}
+{$IFDEF QIP}
+ if (not QIPConnectionError) then
+ begin
+{$ENDIF}
+ RShowConnectingForm;
+{$IFDEF QIP}
+ end;
+{$ENDIF}
+
+ except
+ Release;
+ raise;
+ end;
+end;
+
+
+procedure TManagerDefault.ROnDestroy;
+begin
+ if (Assigned(Connector)) then
+ begin
+ Connector.Close;
+ end;
+
+ inherited ROnDestroy;
+end;
+
+
+procedure TManagerDefault.RSendData(const cmd: string);
+const
+ last_cmd: string = '';
+begin
+ if (cmd = '') then
+ exit;
+ last_cmd := cmd + CMD_DELIMITER;
+ Connector.SendData(last_cmd);
+end;
+
+end.
+
diff --git a/plugins/!NotAdopted/Chess4Net/MessageDialogUnit.pas b/plugins/!NotAdopted/Chess4Net/MessageDialogUnit.pas new file mode 100644 index 0000000000..2d367c02c6 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/MessageDialogUnit.pas @@ -0,0 +1,273 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit MessageDialogUnit;
+
+interface
+
+uses
+ Forms, TntForms, Dialogs, Classes;
+
+function CreateMessageDialog(AOwner: TComponent; const Msg: WideString; DlgType: TMsgDlgType;
+ Buttons: TMsgDlgButtons; bStayOnTopIfNoOwner: boolean = FALSE): TTntForm; overload;
+function CreateMessageDialog(AOwner: TComponent; const Msg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn;
+ bStayOnTopIfNoOwner: boolean = FALSE): TTntForm; overload;
+
+implementation
+
+uses
+ Types, StdCtrls, TntStdCtrls, Graphics, Windows, TntWindows, Consts, Math,
+ ExtCtrls, TntExtCtrls, Controls, SysUtils,
+ // Chess4Net units
+ LocalizerUnit;
+
+type
+ TMessageForm = class(TTntForm)
+ private
+ Message: TTntLabel;
+ public
+ constructor CreateNew(AOwner: TComponent; bStayOnTop: boolean); reintroduce;
+ end;
+
+////////////////////////////////////////////////////////////////////////////////
+// Globals
+
+var
+// ButtonWidths : array[TMsgDlgBtn] of integer; // initialized to zero
+{
+ ButtonCaptions: array[TMsgDlgBtn] of Pointer = (
+ @SMsgDlgYes, @SMsgDlgNo, @SMsgDlgOK, @SMsgDlgCancel, @SMsgDlgAbort,
+ @SMsgDlgRetry, @SMsgDlgIgnore, @SMsgDlgAll, @SMsgDlgNoToAll, @SMsgDlgYesToAll,
+ @SMsgDlgHelp);
+}
+ IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
+ IDI_ASTERISK, IDI_QUESTION, nil);
+{
+ Captions: array[TMsgDlgType] of Pointer = (@SMsgDlgWarning, @SMsgDlgError,
+ @SMsgDlgInformation, @SMsgDlgConfirm, nil);
+}
+ ButtonNames: array[TMsgDlgBtn] of string = (
+ '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 CreateMessageDialog(AOwner: TComponent; const Msg: WideString;
+ DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn;
+ bStayOnTopIfNoOwner: boolean = FALSE): TTntForm; overload;
+
+ function NGetAveCharSize(Canvas: TCanvas): TPoint;
+ var
+ I: Integer;
+ Buffer: array[0..51] of Char;
+ begin
+ for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
+ for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
+ GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
+ Result.X := Result.X div 52;
+ end;
+
+ function NGetButtonCaption(MsgDlgBtn: TMsgDlgBtn): WideString;
+ begin
+ with TLocalizer.Instance do
+ case MsgDlgBtn of
+ mbYes: Result := GetLabel(40);
+ mbNo: Result := GetLabel(41);
+ mbOK: Result := GetLabel(42);
+ mbCancel: Result := GetLabel(43);
+ mbAbort: Result := GetLabel(44);
+ mbRetry: Result := GetLabel(45);
+ mbIgnore: Result := GetLabel(46);
+ mbAll: Result := GetLabel(47);
+ mbNoToAll: Result := GetLabel(48);
+ mbYesToAll: Result := GetLabel(49);
+ mbHelp: Result := GetLabel(50);
+ else
+ raise Exception.Create('Unexpected MsgDlgBtn in CreateMessageDialog\NGetButtonCaption.');
+ end;
+ end;
+
+ function NGetMessageCaption(MsgType: TMsgDlgType): WideString;
+ begin
+ case MsgType of
+ mtWarning: Result := SMsgDlgWarning;
+ mtError: Result := SMsgDlgError;
+ mtInformation: Result := SMsgDlgInformation;
+ mtConfirmation: Result := SMsgDlgConfirm;
+ mtCustom: Result := '';
+ else
+ raise Exception.Create('Unexpected MsgType in CreateMessageDialog\NGetMessageCaption.');
+ end;
+ end;
+
+const
+ mcHorzMargin = 8;
+ mcVertMargin = 8;
+ mcHorzSpacing = 10;
+ mcVertSpacing = 10;
+ mcButtonWidth = 50;
+ mcButtonHeight = 14;
+ mcButtonSpacing = 4;
+var
+ bStayOnTop: boolean;
+ 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 { CreateMessageDialog }
+ if (Assigned(AOwner)) then
+ bStayOnTop := (AOwner.InheritsFrom(TForm) and (TForm(AOwner).FormStyle = fsStayOnTOp))
+ else
+ bStayOnTop := bStayOnTopIfNoOwner;
+
+ Result := TMessageForm.CreateNew(AOwner, bStayOnTop);
+ 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;
+ DialogUnits := NGetAveCharSize(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(NGetButtonCaption(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 := NGetMessageCaption(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;
+ TMessageForm(Result).Message := TTntLabel.Create(Result);
+ with TMessageForm(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 := NGetButtonCaption(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);
+ end;
+ end;
+ end;
+end;
+
+
+function CreateMessageDialog(AOwner: TComponent; const Msg: WideString; DlgType: TMsgDlgType;
+ Buttons: TMsgDlgButtons; bStayOnTopIfNoOwner: boolean = FALSE): TTntForm;
+var
+ DefaultButton: TMsgDlgBtn;
+begin
+ if mbOk in Buttons then
+ DefaultButton := mbOk
+ else if mbYes in Buttons then
+ DefaultButton := mbYes
+ else
+ DefaultButton := mbRetry;
+ Result := CreateMessageDialog(AOwner, Msg, DlgType, Buttons, DefaultButton, bStayOnTopIfNoOwner);
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TMessageForm
+
+constructor TMessageForm.CreateNew(AOwner: TComponent; bStayOnTop: boolean);
+var
+ NonClientMetrics: TNonClientMetrics;
+begin
+ if (bStayOnTop) then
+ FormStyle := fsStayOnTop;
+ inherited CreateNew(AOwner);
+ NonClientMetrics.cbSize := sizeof(NonClientMetrics);
+ if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
+ Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/ModalForm.pas b/plugins/!NotAdopted/Chess4Net/ModalForm.pas new file mode 100644 index 0000000000..165fee6b86 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/ModalForm.pas @@ -0,0 +1,519 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit ModalForm;
+
+interface
+
+uses
+ Forms, TntForms, Dialogs, Classes, Windows, Controls;
+
+type
+ TModalForm = class;
+ TModalFormClass = class of TModalForm;
+
+ TModalFormID = (mfNone, mfMsgClose, mfMsgLeave, mfMsgAbort, mfMsgResign,
+ mfMsgDraw, mfMsgTakeBack, mfMsgAdjourn, mfConnecting, mfGameOptions,
+ mfLookFeel, mfCanPause, mfContinue, mfIncompatible, mfDontShowDlg
+{$IFDEF SKYPE}
+ , mfSelectSkypeContact
+{$ENDIF}
+{$IFDEF MIRANDA}
+ , mfTransmitting, mfTransmitGame
+{$ENDIF}
+ );
+
+ TModalFormHandler = procedure(modSender: TModalForm; modID: TModalFormID) of object;
+
+ TDialogs = class
+ private
+ IDCount: array[TModalFormID] of word;
+ frmList: TList;
+ function GetShowing: boolean;
+ protected
+ RHandler: TModalFormHandler;
+ public
+ Owner: TForm;
+ constructor Create(Owner: TForm; Handler: TModalFormHandler);
+ destructor Destroy; override;
+ procedure MessageDlg(const wstrMsg: WideString; DlgType: TMsgDlgType;
+ Buttons: TMsgDlgButtons; msgDlgID: TModalFormID);
+ function CreateDialog(modalFormClass: TModalFormClass): TModalForm;
+ procedure SetShowing(msgDlg: TModalForm);
+ procedure UnsetShowing(msgDlg: TModalForm);
+ function InFormList(frm: TForm): boolean;
+ procedure BringToFront;
+ procedure MoveForms(dx, dy: integer);
+ procedure CloseNoneDialogs;
+
+ class procedure ShowMessage(const wstrMsg: WideString);
+ class function HasStayOnTopOwners: boolean;
+
+ property Showing: boolean read GetShowing;
+ end;
+
+
+ TModalForm = class(TTntForm)
+ procedure FormShow(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure ButtonClick(Sender: TObject);
+ private
+ GenFormShow: TNotifyEvent;
+ GenFormClose: TCloseEvent;
+ protected
+ RHandler: TModalFormHandler;
+ dlgOwner: TDialogs;
+
+ constructor Create(dlgOwner: TDialogs; modHandler: TModalFormHandler); reintroduce; overload; virtual;
+
+ function GetHandle: hWnd; virtual;
+ function GetEnabled_: boolean; virtual;
+ procedure SetEnabled_(flag: boolean); virtual;
+ function GetLeft_: integer; virtual;
+ procedure SetLeft_(x: integer); virtual;
+ function GetTop_: integer; virtual;
+ procedure SetTop_(y: integer); virtual;
+
+ function GetModalID: TModalFormID; virtual;
+
+ function RGetModalResult: TModalResult; virtual;
+ procedure RSetModalResult(Value: TModalResult); virtual;
+
+ public
+ constructor Create(Owner: TForm; modHandler: TModalFormHandler = nil); reintroduce; overload; virtual;
+
+ procedure Show; virtual;
+ procedure Close; virtual;
+
+ property Handle: hWnd read GetHandle;
+ property Enabled: boolean read GetEnabled_ write SetEnabled_;
+ property Left: integer read GetLeft_ write SetLeft_;
+ property Top: integer read GetTop_ write SetTop_;
+
+ property ModalResult: TModalResult read RGetModalResult write RSetModalResult;
+ end;
+
+implementation
+
+uses
+ SysUtils, StdCtrls,
+ DialogUnit, GlobalsUnit;
+
+var
+ g_lstDialogs: TList = nil;
+
+////////////////////////////////////////////////////////////////////////////////
+// TModalForm
+
+procedure TModalForm.FormShow(Sender: TObject);
+var
+ frmOwner: TForm;
+ selfForm: TForm;
+
+ procedure NCorrectIfOutOfScreen(var iLeft, iTop: integer);
+ var
+ R: TRect;
+ M: TMonitor;
+ begin
+ if (Assigned(frmOwner)) then
+ begin
+ M := Screen.MonitorFromRect(frmOwner.BoundsRect);
+ R := M.WorkareaRect;
+ end
+ else
+ R := Screen.WorkAreaRect;
+
+ if ((iLeft + selfForm.Width) > R.Right) then
+ iLeft := R.Right - selfForm.Width;
+ if (iLeft < R.Left) then
+ iLeft := R.Left;
+ if ((iTop + selfForm.Height) > R.Bottom) then
+ iTop := R.Bottom - selfForm.Height;
+ if (iTop < R.Top) then
+ iTop := R.Top;
+ end;
+
+var
+ iWidth, iHeight: integer;
+ iLeft, iTop: integer;
+begin // TModalForm.FormShow
+ selfForm := Sender as TForm;
+ frmOwner := nil;
+
+ if (Assigned(Owner)) then
+ begin
+ frmOwner := (Owner as TForm);
+ iLeft := frmOwner.Left;
+ iTop := frmOwner.Top;
+ iWidth := frmOwner.Width;
+ iHeight := frmOwner.Height;
+ end
+ else
+ begin
+ iLeft := 0;
+ iTop := 0;
+ iWidth := Screen.Width;
+ iHeight := Screen.Height;
+ end;
+
+ iLeft := iLeft + (iWidth - selfForm.Width) div 2;
+ iTop := iTop + (iHeight - selfForm.Height) div 2;
+
+ NCorrectIfOutOfScreen(iLeft, iTop);
+
+ selfForm.Left := iLeft;
+ selfForm.Top := iTop;
+
+ if (Assigned(GenFormShow)) then
+ GenFormShow(Sender);
+end;
+
+
+procedure TModalForm.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if Assigned(GenFormClose) then
+ GenFormClose(Sender, Action);
+ if Assigned(dlgOwner) then
+ dlgOwner.UnsetShowing(self);
+ if fsModal in FormState then
+ exit;
+ if (Assigned(RHandler)) then
+ RHandler(self, GetModalID);
+ Action := caFree;
+end;
+
+
+procedure TModalForm.ButtonClick(Sender: TObject);
+begin
+ if (fsModal in FormState) then
+ exit;
+ Close;
+end;
+
+
+constructor TModalForm.Create(Owner: TForm; modHandler: TModalFormHandler);
+var
+ i: integer;
+begin
+ if (Assigned(Owner)) then
+ FormStyle := Owner.FormStyle;
+
+ inherited Create(Owner);
+ RHandler := modHandler;
+
+ GenFormShow := OnShow;
+ GenFormClose := OnClose;
+ OnShow := FormShow;
+ OnClose := FormClose;
+
+ for i := 0 to (ComponentCount - 1) do
+ begin
+ if (Components[i] is TButton) then
+ (Components[i] as TButton).OnClick := ButtonClick;
+ end;
+end;
+
+constructor TModalForm.Create(dlgOwner: TDialogs; modHandler: TModalFormHandler);
+begin
+ self.dlgOwner := dlgOwner;
+ Create(dlgOwner.Owner, modHandler);
+ dlgOwner.SetShowing(self);
+end;
+
+
+function TModalForm.GetModalID : TModalFormID;
+begin
+ Result := mfNone;
+end;
+
+
+function TModalForm.GetHandle: hWnd;
+begin
+ Result := inherited Handle;
+end;
+
+
+function TModalForm.GetEnabled_: boolean;
+begin
+ Result := inherited Enabled;
+end;
+
+
+procedure TModalForm.SetEnabled_(flag: boolean);
+begin
+ inherited Enabled := flag;
+end;
+
+
+procedure TModalForm.Show;
+begin
+ inherited Show;
+end;
+
+
+procedure TModalForm.Close;
+begin
+ inherited Close;
+end;
+
+
+function TModalForm.GetLeft_: integer;
+begin
+ Result := inherited Left;
+end;
+
+
+procedure TModalForm.SetLeft_(x: integer);
+begin
+ inherited Left := x;
+end;
+
+
+function TModalForm.GetTop_: integer;
+begin
+ Result := inherited Top;
+end;
+
+
+procedure TModalForm.SetTop_(y: integer);
+begin
+ inherited Top := y;
+end;
+
+
+function TModalForm.RGetModalResult: TModalResult;
+begin
+ Result := inherited ModalResult;
+end;
+
+procedure TModalForm.RSetModalResult(Value: TModalResult);
+begin
+ inherited ModalResult := Value;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TDialogs
+
+constructor TDialogs.Create(Owner: TForm; Handler: TModalFormHandler);
+var
+ i: TModalFormID;
+begin
+ inherited Create;
+
+ self.Owner := Owner;
+ self.RHandler := Handler;
+ frmList := TList.Create;
+ for i := Low(TModalFormID) to High(TModalFormID) do
+ IDCount[i] := 0;
+
+ if (not Assigned(g_lstDialogs)) then
+ g_lstDialogs := TList.Create;
+ g_lstDialogs.Add(self);
+end;
+
+
+destructor TDialogs.Destroy;
+var
+ i: integer;
+ ModalForm: TModalForm;
+begin
+ if (Assigned(g_lstDialogs)) then
+ begin
+ g_lstDialogs.Remove(self);
+ if (g_lstDialogs.Count = 0) then
+ FreeAndNil(g_lstDialogs);
+ end;
+
+ for i := 0 to frmList.Count - 1 do
+ begin
+ ModalForm := frmList[i];
+ ModalForm.RHandler := nil;
+ ModalForm.dlgOwner := nil;
+// ModalForm.Release;
+ ModalForm.Free;
+ end;
+
+ inherited;
+end;
+
+
+function TDialogs.GetShowing: boolean;
+var
+ i: TModalFormID;
+begin
+ Result := TRUE;
+ for i := Low(TModalFormID) to High(TModalFormID) do
+ begin
+ if IDCount[i] > 0 then
+ exit;
+ end;
+ Result := FALSE;
+end;
+
+
+procedure TDialogs.UnsetShowing(msgDlg: TModalForm);
+var
+ i: integer;
+begin
+ dec(IDCount[msgDlg.GetModalID]);
+
+ if (Assigned(msgDlg)) then
+ begin
+ for i := 0 to frmList.Count - 1 do
+ begin
+ if (TModalForm(frmList[i]).Handle = msgDlg.Handle) then
+ begin
+ frmList.Delete(i);
+ break;
+ end;
+ end; // for
+ end;
+
+ if (frmList.Count > 0) then
+ begin
+ TModalForm(frmList.Last).Enabled := TRUE;
+ TModalForm(frmList.Last).SetFocus;
+ end
+ else
+ begin
+ if (Assigned(Owner)) then
+ begin
+ Owner.Enabled := TRUE;
+ Owner.SetFocus;
+ end;
+ end;
+end;
+
+
+function TDialogs.InFormList(frm: TForm): boolean;
+var
+ i: integer;
+begin
+ for i := 0 to frmList.Count - 1 do
+ begin
+ if TModalForm(frmList[i]).Handle = frm.Handle then
+ begin
+ Result := TRUE;
+ exit;
+ end;
+ end;
+ Result := FALSE;
+end;
+
+
+procedure TDialogs.MessageDlg(const wstrMsg: WideString; DlgType: TMsgDlgType;
+ Buttons: TMsgDlgButtons; msgDlgID: TModalFormID);
+var
+ DialogForm: TDialogForm;
+begin
+ if ((msgDlgID <> mfNone) and (IDCount[msgDlgID] > 0)) then
+ exit;
+ DialogForm := TDialogForm.Create(self, wstrMsg, DlgType, Buttons, msgDlgID, RHandler,
+ HasStayOnTopOwners);
+ DialogForm.Caption := DIALOG_CAPTION;
+ SetShowing(DialogForm);
+ DialogForm.Show;
+ frmList.Add(DialogForm);
+end;
+
+
+function TDialogs.CreateDialog(modalFormClass: TModalFormClass): TModalForm;
+begin
+ Result := modalFormClass.Create(self, RHandler);
+ frmList.Add(Result);
+end;
+
+
+procedure TDialogs.SetShowing(msgDlg: TModalForm);
+begin
+ inc(IDCount[msgDlg.GetModalID]);
+ if (frmList.Count > 0) then
+ TModalForm(frmList.Last).Enabled := FALSE;
+end;
+
+
+procedure TDialogs.BringToFront;
+var
+ i: integer;
+begin
+ if frmList.Count = 0 then
+ exit;
+ for i := 0 to frmList.Count - 1 do
+ TModalForm(frmList[i]).Show;
+ TModalForm(frmList.Last).SetFocus;
+end;
+
+
+procedure TDialogs.MoveForms(dx, dy: integer);
+var
+ i: integer;
+begin
+ for i := 0 to frmList.Count - 1 do
+ begin
+ with TModalForm(frmList[i]) do
+ begin
+ Left := Left + dx;
+ Top := Top + dy;
+ end;
+ end;
+end;
+
+
+procedure TDialogs.CloseNoneDialogs;
+var
+ i: integer;
+ Dlg: TModalForm;
+begin
+ i := frmList.Count - 1;
+ while (i >= 0) do
+ begin
+ Dlg := frmList[i];
+ if (Dlg.GetModalID = mfNone) then
+ Dlg.Close;
+ dec(i);
+ end;
+end;
+
+
+class function TDialogs.HasStayOnTopOwners: boolean;
+var
+ i: integer;
+ Dlgs: TDialogs;
+begin
+ Result := FALSE;
+ if (not Assigned(g_lstDialogs)) then
+ exit;
+
+ for i := 0 to g_lstDialogs.Count - 1 do
+ begin
+ Dlgs := g_lstDialogs[i];
+ Result := (Assigned(Dlgs) and Assigned(Dlgs.Owner) and
+ (Dlgs.Owner.FormStyle = fsStayOnTop));
+ if (Result) then
+ exit;
+ end; // for
+end;
+
+
+class procedure TDialogs.ShowMessage(const wstrMsg: WideString);
+var
+ DummyOwner: TForm;
+ DummyHandler: TModalFormHandler;
+begin
+ DummyOwner := nil;
+ DummyHandler := nil;
+
+ with TDialogForm.Create(DummyOwner, wstrMsg, mtCustom, [mbOk], mfNone, DummyHandler,
+ HasStayOnTopOwners) do
+ try
+ ShowModal;
+ finally
+ Release;
+ end;
+end;
+
+end.
+
diff --git a/plugins/!NotAdopted/Chess4Net/NonMainFormStayOnTopUnit.pas b/plugins/!NotAdopted/Chess4Net/NonMainFormStayOnTopUnit.pas new file mode 100644 index 0000000000..47ded58c89 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/NonMainFormStayOnTopUnit.pas @@ -0,0 +1,74 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit NonMainFormStayOnTopUnit;
+
+// Inclusion of this unit enables all non-main forms with FormStyle = fsStayOnTop
+// to stay on top even if application is deactivated
+
+interface
+
+implementation
+
+uses
+ Forms, SysUtils, Classes, Messages, Windows;
+
+type
+ TApplicationObjSubclasser = class
+ private
+ m_NewObj, m_OldObj: pointer;
+ procedure FWndProc(var Message: TMessage);
+ public
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+var
+ g_ApplicationObjSubclasserInstance: TApplicationObjSubclasser = nil;
+
+////////////////////////////////////////////////////////////////////////////////
+// TApplicationObjSubclasser
+
+constructor TApplicationObjSubclasser.Create;
+begin
+ inherited Create;
+
+ m_NewObj := Classes.MakeObjectInstance(FWndProc);
+ m_OldObj := Pointer (SetWindowLong(Application.Handle, GWL_WNDPROC,
+ Cardinal(m_NewObj)));
+end;
+
+
+destructor TApplicationObjSubclasser.Destroy;
+begin
+ SetWindowLong(Application.Handle, GWL_WNDPROC, Cardinal(m_OldObj));
+ Classes.FreeObjectInstance(m_NewObj);
+
+ inherited;
+end;
+
+
+procedure TApplicationObjSubclasser.FWndProc(var Message: TMessage);
+begin
+ Message.Result := CallWindowProc (m_OldObj, Application.Handle,
+ Message.Msg, Message.wParam, Message.lParam);
+
+ case Message.Msg of
+ WM_ACTIVATEAPP:
+ begin
+ if (not TWMActivateApp(Message).Active) then
+ Application.RestoreTopMosts;
+ end;
+ end;
+end;
+
+initialization
+ g_ApplicationObjSubclasserInstance := TApplicationObjSubclasser.Create;
+
+finalization
+ FreeAndNil(g_ApplicationObjSubclasserInstance);
+
+end.
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/NonRefInterfacedObjectUnit.pas b/plugins/!NotAdopted/Chess4Net/NonRefInterfacedObjectUnit.pas new file mode 100644 index 0000000000..a6a32f2901 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/NonRefInterfacedObjectUnit.pas @@ -0,0 +1,44 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit NonRefInterfacedObjectUnit;
+
+interface
+
+type
+ TNonRefInterfacedObject = class(TObject, IInterface)
+ protected
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ end;
+
+implementation
+
+////////////////////////////////////////////////////////////////////////////////
+// TNonRefInterfacedObject
+
+function TNonRefInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then
+ Result := 0
+ else
+ Result := E_NOINTERFACE;
+end;
+
+
+function TNonRefInterfacedObject._AddRef: Integer;
+begin
+ Result := -1;
+end;
+
+
+function TNonRefInterfacedObject._Release: Integer;
+begin
+ Result := -1;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas b/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas new file mode 100644 index 0000000000..535f181e9c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas @@ -0,0 +1,620 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit PosBaseChessBoardLayerUnit;
+
+interface
+
+uses
+ Classes,
+ //
+ ChessBoardUnit, PosBaseUnit;
+
+
+type
+ TGameResult = (grWin, grWinTime, grDraw, grLost, grLostTime);
+
+ // Layer extended with Position DB
+ TPosBaseChessBoardLayer = class(TChessBoardLayerBase)
+ private
+ m_bTrainingMode: boolean;
+ m_lstMovePrior: TList;
+ m_bUseUserBase: boolean;
+ m_PosBase, m_ExtPosBase: TPosBase;
+ m_strPosBaseName, m_strExtPosBaseName: string;
+
+ procedure FSetTrainingMode(bValue: boolean);
+ procedure FSetUseUserBase(bValue: boolean);
+
+ procedure FClearMovePriorList;
+ procedure FReadFromBase;
+ procedure FWriteGameToBase;
+ protected
+ procedure RDraw; override;
+ procedure ROnAfterMoveDone; override;
+ procedure ROnAfterSetPosition; override;
+ procedure ROnAfterModeSet(const OldValue, NewValue: TMode); override;
+ procedure ROnResetMoveList; override;
+ public
+ constructor Create(const strPosBaseName: string = '');
+ destructor Destroy; override;
+ procedure SetExternalBase(const strExtPosBaseName: string);
+ procedure WriteGameToBase(AGameResult: TGameResult);
+ procedure UnsetExternalBase;
+ property TrainingMode: boolean read m_bTrainingMode write FSetTrainingMode;
+ property UseUserBase: boolean read m_bUseUserBase write FSetUseUserBase;
+ end;
+
+implementation
+
+uses
+ Graphics, SysUtils,
+ //
+ ChessRulesEngine, ChessBoardHeaderUnit;
+
+type
+ TPrior = (mpNo, mpHigh, mpMid, mpLow);
+
+ PMovePrior = ^TMovePrior;
+ TMovePrior = record
+ move: TMoveAbs;
+ prior: TPrior;
+ end;
+
+ TPosBaseOperator = class(TThread)
+ private
+ m_Operation: (opRead, opWrite);
+ m_Layer: TPosBaseChessBoardLayer;
+ constructor FCreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE);
+ constructor FCreateWrite(ALayer: TPosBaseChessBoardLayer);
+ protected
+ procedure Execute; override;
+ public
+ class function CreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE): TPosBaseOperator;
+ class function CreateWrite(ALayer: TPosBaseChessBoardLayer): TPosBaseOperator;
+ procedure WaitFor;
+ end;
+
+var
+ gameResult: TGameResult; // Not threadsafe
+ gameID: word; // It's used for writing unique positions (not threadsafe)
+
+const
+ NUM_PRIORITIES = 3; // Maximal number of priorities
+{$IFDEF RESTRICT_TRAINING_DB}
+ MAX_PLY_TO_BASE = 60;
+{$ELSE}
+ MAX_PLY_TO_BASE = -1; // The whole game is saved to the DB
+{$ENDIF}
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseChessBoardLayer
+
+constructor TPosBaseChessBoardLayer.Create(const strPosBaseName: string = '');
+begin
+ inherited Create;
+
+ m_bUseUserBase := TRUE;
+ m_strPosBaseName := strPosBaseName;
+
+ m_lstMovePrior := TList.Create;
+end;
+
+
+destructor TPosBaseChessBoardLayer.Destroy;
+begin
+ FClearMovePriorList;
+ m_lstMovePrior.Free;
+
+ TrainingMode := FALSE;
+
+ inherited;
+end;
+
+
+procedure TPosBaseChessBoardLayer.RDraw;
+const
+ ARROW_END_LENGTH = 10; // â ïèêñåëÿõ
+ ARROW_END_ANGLE = 15 * (Pi / 180); // óãîë êîíöîâ ñòðåëêè
+ ARROW_INDENT = 7;
+
+ HIGH_ARROW_COLOR = clRed;
+ HIGH_ARROW_WIDTH = 2;
+ MID_ARROW_COLOR = clTeal;
+ MID_ARROW_WIDTH = 2;
+ LOW_ARROW_COLOR = clSkyBlue;
+ LOW_ARROW_WIDTH = 1;
+
+var
+ i, x0, y0, x, y: integer;
+ xa, ya, ca, sa: double;
+ move: TMoveAbs;
+begin
+ if (not (Assigned(ChessBoard) and Assigned(Canvas))) then
+ exit;
+
+ if (not (m_bTrainingMode and (ChessBoard.Mode in [mGame, mAnalyse]) and
+ (ChessBoard.PlayerColor = ChessBoard.PositionColor))) then
+ exit;
+
+ Canvas.Pen.Style := psSolid;
+
+ for i := 0 to m_lstMovePrior.Count - 1 do
+ begin
+ case PMovePrior(m_lstMovePrior[i]).prior of
+ mpNo: continue;
+ mpHigh:
+ begin
+ Canvas.Pen.Color := HIGH_ARROW_COLOR;
+ Canvas.Pen.Width := HIGH_ARROW_WIDTH;
+ end;
+ mpMid:
+ begin
+ Canvas.Pen.Color := MID_ARROW_COLOR;
+ Canvas.Pen.Width := MID_ARROW_WIDTH;
+ end;
+ mpLow:
+ begin
+ Canvas.Pen.Color := LOW_ARROW_COLOR;
+ Canvas.Pen.Width := LOW_ARROW_WIDTH;
+ end;
+ end;
+
+ move := PMovePrior(m_lstMovePrior[i]).move;
+
+ if (not ChessBoard.Flipped) then
+ begin
+ x0 := CHB_X + SquareSize * (move.i0 - 1) + (SquareSize div 2);
+ y0 := CHB_Y + SquareSize * (8 - move.j0) + (SquareSize div 2);
+ x := CHB_X + SquareSize * (move.i - 1) + (SquareSize div 2);
+ y := CHB_Y + SquareSize * (8 - move.j) + (SquareSize div 2);
+ end
+ else
+ begin
+ x0 := CHB_X + SquareSize * (8 - move.i0) + (SquareSize div 2);
+ y0 := CHB_Y + SquareSize * (move.j0 - 1) + (SquareSize div 2);
+ x := CHB_X + SquareSize * (8 - move.i) + (SquareSize div 2);
+ y := CHB_Y + SquareSize * (move.j - 1) + (SquareSize div 2);
+ end;
+
+ // Draw an arrow
+ ca := (x - x0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ sa := (y - y0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ x0 := x0 + Round(ARROW_INDENT * ca);
+ y0 := y0 + Round(ARROW_INDENT * sa);
+ x := x - Round(ARROW_INDENT * ca);
+ y := y - Round(ARROW_INDENT * sa);
+
+ Canvas.MoveTo(x0, y0);
+ Canvas.LineTo(x, y);
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ Canvas.LineTo(Round(xa), Round(ya));
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ Canvas.MoveTo(x, y);
+ Canvas.LineTo(Round(xa), Round(ya));
+ end;
+
+end;
+
+
+procedure Reestimate(lstMoveEsts: TList; viRec: integer);
+var
+ est: SmallInt;
+ id: word;
+begin
+ id := LongWord(lstMoveEsts[viRec]) shr 16;
+ if id = gameID then
+ exit; // ïîçèöèÿ äóáëèðóåòñÿ â ðàìêàõ îäíîé ïàðòèè
+
+ est := SmallInt(lstMoveEsts[viRec]);
+ case gameResult of
+ grWin: inc(est, 2);
+ grWinTime: inc(est);
+ grDraw: ;
+ grLost: dec(est, 2);
+ grLostTime: dec(est);
+ end;
+ lstMoveEsts[viRec] := Pointer((gameID shl 16) or Word(est));
+end;
+
+
+procedure TPosBaseChessBoardLayer.FSetTrainingMode(bValue: boolean);
+begin
+ if (m_bTrainingMode = bValue) then
+ exit;
+
+ m_bTrainingMode := bValue;
+
+ try
+ if (m_bTrainingMode) then
+ begin
+ if (m_strPosBaseName <> '') then
+ m_PosBase := TPosBase.Create(m_strPosBaseName, Reestimate);
+ if (m_strExtPosBaseName <> '') then
+ m_ExtPosBase := TPosBase.Create(m_strExtPosBaseName);
+ with TPosBaseOperator.CreateRead(self, FALSE) do
+ try
+ WaitFor;
+ finally
+ Free;
+ end;
+ end
+ else
+ begin
+ FreeAndNil(m_PosBase);
+ FreeAndNil(m_ExtPosBase);
+ end;
+
+ RDoUpdate;
+
+ except
+ on Exception do
+ begin
+ FreeAndNil(m_PosBase);
+ FreeAndNil(m_ExtPosBase);
+ m_bTrainingMode := FALSE;
+ end;
+ end;
+
+end;
+
+
+procedure TPosBaseChessBoardLayer.FSetUseUserBase(bValue: boolean);
+begin
+ if (m_bUseUserBase = bValue) then
+ exit;
+ m_bUseUserBase := bValue;
+ TPosBaseOperator.CreateRead(self, FALSE);
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterMoveDone;
+begin
+ if (m_bTrainingMode) then
+ begin
+ if (Assigned(ChessBoard) and
+ (ChessBoard.PlayerColor = ChessBoard.PositionColor)) then
+ TPosBaseOperator.CreateRead(self) // Read from PosBase and update
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterSetPosition;
+begin
+ if (m_bTrainingMode) then
+ begin
+ with TPosBaseOperator.CreateRead(self, FALSE) do // Read from DB and update
+ try
+ WaitFor;
+ finally
+ Free;
+ end;
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.SetExternalBase(const strExtPosBaseName: string);
+begin
+ if (m_bTrainingMode) then
+ begin
+ if (m_strExtPosBaseName = strExtPosBaseName) then
+ exit;
+ FreeAndNil(m_ExtPosBase);
+ m_ExtPosBase := TPosBase.Create(strExtPosBaseName);
+ TPosBaseOperator.CreateRead(self, FALSE);
+ end;
+
+ m_strExtPosBaseName := strExtPosBaseName;
+end;
+
+
+procedure TPosBaseChessBoardLayer.WriteGameToBase(AGameResult: TGameResult);
+begin
+ if (m_bTrainingMode) then
+ begin
+ gameResult := AGameResult;
+ TPosBaseOperator.CreateWrite(self);
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.UnsetExternalBase;
+begin
+ FreeAndNil(m_ExtPosBase);
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterModeSet(const OldValue, NewValue: TMode);
+begin
+ if (OldValue = mEdit) then
+ ROnAfterSetPosition; // Read from PosBase
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnResetMoveList;
+begin
+ if (ChessBoard.Mode = mEdit) then
+ FClearMovePriorList;
+end;
+
+
+procedure TPosBaseChessBoardLayer.FClearMovePriorList;
+var
+ i: integer;
+begin
+ for i := 0 to m_lstMovePrior.Count - 1 do
+ Dispose(m_lstMovePrior[i]);
+ m_lstMovePrior.Clear;
+end;
+
+
+function EstComape(item1, item2: pointer): integer;
+begin
+ Result := SmallInt(PMoveEst(item2).estimate and $FFFF) - SmallInt(PMoveEst(item1).estimate and $FFFF);
+end;
+
+
+procedure TPosBaseChessBoardLayer.FReadFromBase;
+
+ procedure ClasterMoves(var rlstMove: TList);
+ var
+ i, j, num_clast, i_min, j_min, curr_assoc: integer;
+ modus_min: double;
+ clastWeights: array of record
+ grav: double;
+ assoc: integer;
+ end;
+ mp: PMovePrior;
+ p: TPrior;
+ begin
+ if rlstMove.Count = 0 then
+ exit;
+
+ rlstMove.Sort(EstComape);
+ SetLength(clastWeights, rlstMove.Count);
+
+ num_clast := rlstMove.Count;
+ for i := 0 to num_clast - 1 do
+ begin
+ clastWeights[i].assoc := i + 1;
+ clastWeights[i].grav := SmallInt(PMoveEst(rlstMove[i]).estimate and $FFFF);
+ end;
+
+ repeat
+ i_min := 0;
+ j_min := 0;
+ modus_min := $7FFF; // $7FFF - ìàêñ. çíà÷åíèå äëÿ îöåíêè
+ curr_assoc := 0; // òåêóùèé ïðîñìàòðèâàåìûé êëàñòåð
+
+ for i := 0 to length(clastWeights) - 2 do
+ begin
+ if curr_assoc = clastWeights[i].assoc then
+ continue;
+ curr_assoc := clastWeights[i].assoc;
+ for j := i + 1 to length(clastWeights) - 1 do
+ if (clastWeights[j].assoc <> clastWeights[j-1].assoc) and
+ (curr_assoc <> clastWeights[j].assoc) and
+ (abs(clastWeights[i].grav - clastWeights[j].grav) <= modus_min) then
+ begin
+ i_min := i;
+ j_min := j;
+ modus_min := abs(clastWeights[i].grav - clastWeights[j].grav);
+ end;
+ end;
+
+ if (num_clast > Ord(High(TPrior))) or (modus_min = 0.0) then
+ begin
+ for i := High(clastWeights) downto j_min do
+ if clastWeights[i].assoc = clastWeights[j_min].assoc then
+ clastWeights[i].assoc := clastWeights[i_min].assoc;
+ clastWeights[i_min].grav := (clastWeights[i_min].grav + clastWeights[j_min].grav) / 2;
+ end;
+
+ dec(num_clast);
+ until (num_clast <= Ord(High(TPrior))) and ((modus_min <> 0.0) or (num_clast < 1));
+
+ p := mpHigh;
+ for i := 0 to rlstMove.Count - 1 do
+ begin
+ new(mp);
+ if (i > 0) and (clastWeights[i].assoc > clastWeights[i-1].assoc) then
+ p := Succ(p);
+ mp.move := PMoveEst(rlstMove[i]).move;
+ mp.prior := p;
+ Dispose(rlstMove[i]);
+ rlstMove[i] := mp;
+ end;
+
+ SetLength(clastWeights, 0);
+ end;
+
+var
+ lstUsrMove, lstExtMove: TList;
+
+ procedure MergeMoves;
+ function NEqualMoves(i,j: integer): boolean;
+ begin
+ with PMovePrior(lstExtMove[i])^, PMovePrior(m_lstMovePrior[j]).move do
+ Result := (i0 = move.i0) and (j0 = move.j0) and (j = move.j) and (i = move.i) and
+ (prom_fig = move.prom_fig);
+ end;
+
+ var
+ i, j, n: integer;
+ const
+ PRIOR_CALC: array[TPrior, TPrior] of TPrior =
+ ((mpNo, mpNo, mpNo, mpNo), // UsrPrior = mpNo - ?, ò.ê. åù¸ íèãäå íå èñï.
+ (mpHigh, mpHigh, mpHigh, mpMid), // UsrPrior = mpHigh
+ (mpMid, mpMid, mpMid, mpMid), // UsrPrior = mpMid
+ (mpLow, mpMid, mpLow, mpLow)); // UsrPrior = mpLow
+ begin
+ for i := 0 to lstUsrMove.Count - 1 do
+ m_lstMovePrior.Add(lstUsrMove[i]);
+
+ // Merging of lists
+ n := m_lstMovePrior.Count;
+
+ for i := 0 to lstExtMove.Count - 1 do
+ begin
+ j := n - 1;
+ while (j >= 0) do
+ begin
+ if NEqualMoves(i,j) then
+ begin
+ PMovePrior(m_lstMovePrior[j]).prior :=
+ PRIOR_CALC[PMovePrior(m_lstMovePrior[j]).prior,
+ PMovePrior(lstExtMove[j]).prior];
+ Dispose(lstExtMove[i]);
+ break;
+ end;
+ dec(j);
+ end;
+ if (j < 0) then
+ m_lstMovePrior.Add(lstExtMove[i]);
+ end; // for
+ end;
+
+begin // .FReadFromBase
+ FClearMovePriorList;
+
+ if (not Assigned(Position)) then
+ exit;
+
+ lstExtMove := nil;
+ lstUsrMove := TList.Create;
+ try
+ lstExtMove := TList.Create;
+
+ if (m_bUseUserBase or (not Assigned(m_ExtPosBase))) then
+ begin
+ if (Assigned(m_PosBase)) then
+ m_PosBase.Find(Position^, lstUsrMove);
+ end;
+ if (Assigned(m_ExtPosBase)) then
+ m_ExtPosBase.Find(Position^, lstExtMove);
+
+ // TODO: Handle wrong DB
+
+ ClasterMoves(lstUsrMove);
+ ClasterMoves(lstExtMove);
+
+ MergeMoves;
+
+ finally
+ lstExtMove.Free;
+ lstUsrMove.Free;
+ end;
+
+end;
+
+
+procedure TPosBaseChessBoardLayer.FWriteGameToBase;
+var
+ ply: integer;
+begin
+ if (not (Assigned(m_PosBase) and Assigned(PositionsList))) then
+ exit;
+
+ gameID := Random($FFFF) + 1;
+
+ if (ChessBoard.PlayerColor = RGetColorStarts) then
+ ply := 0
+ else
+ ply := 1;
+
+ while ((ply < PositionsList.Count) and ((MAX_PLY_TO_BASE < 0) or (ply <= MAX_PLY_TO_BASE))) do
+ begin
+ m_PosBase.Add(PPosMove(PositionsList[ply])^);
+ inc(ply, 2);
+ end;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseOperator
+
+constructor TPosBaseOperator.FCreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE);
+begin
+ m_Operation := opRead;
+ m_Layer := ALayer;
+
+ inherited Create(TRUE);
+ Priority := tpNormal;
+ FreeOnTerminate := vbFreeOnTerminate;
+ Resume;
+end;
+
+
+constructor TPosBaseOperator.FCreateWrite(ALayer: TPosBaseChessBoardLayer);
+begin
+ m_Layer := ALayer;
+ m_Operation := opWrite;
+
+ inherited Create(TRUE);
+
+ Priority := tpNormal;
+ FreeOnTerminate := TRUE;
+
+ Resume;
+end;
+
+
+class function TPosBaseOperator.CreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE): TPosBaseOperator;
+begin
+ Result := nil;
+
+ if (Assigned(ALayer.ChessBoard) and (ALayer.ChessBoard.Mode <> mEdit)) then
+ Result := TPosBaseOperator.FCreateRead(ALayer, vbFreeOnTerminate);
+end;
+
+
+class function TPosBaseOperator.CreateWrite(ALayer: TPosBaseChessBoardLayer): TPosBaseOperator;
+begin
+ Result := nil;
+
+ if (Assigned(ALayer.ChessBoard) and (ALayer.ChessBoard.Mode <> mEdit)) then
+ Result := TPosBaseOperator.FCreateWrite(ALayer);
+end;
+
+
+procedure TPosBaseOperator.Execute;
+begin
+ case m_Operation of
+ opRead:
+ begin
+ m_Layer.FReadFromBase;
+ Synchronize(m_Layer.RDoUpdate);
+ end;
+ opWrite:
+ m_Layer.FWriteGameToBase;
+ end;
+end;
+
+
+procedure TPosBaseOperator.WaitFor;
+begin
+ if (not Assigned(self)) then
+ exit;
+ inherited WaitFor;
+end;
+
+initialization
+ Randomize;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardUnit.pas b/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardUnit.pas new file mode 100644 index 0000000000..c0c10001ad --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardUnit.pas @@ -0,0 +1,537 @@ +unit PosBaseChessBoardUnit;
+
+interface
+
+uses
+ Classes, PosBaseUnit, ChessBoardHeaderUnit, ChessRulesEngine, ChessBoardUnit;
+
+type
+ TGameResult = (grWin, grWinTime, grDraw, grLost, grLostTime);
+
+ // Ðàñøèðåíèå TChessBoard áàçîé äàííûõ ïîçèöèé
+ TPosBaseChessBoard = class(TChessBoard)
+ private
+ _bUseUserBase: boolean;
+ _lstMovePrior: TList;
+ _oPosBase, _oExtPosBase: TPosBase;
+ _bTrainingMode: boolean;
+ _sPosBaseName, _sExtPosBaseName: string;
+ procedure FSetTrainingMode(vbTrainingMode: boolean);
+ procedure FUseUserBase(vbUseUserBase: boolean);
+ procedure FReadFromBase;
+ procedure FWriteGameToBase;
+
+ protected
+ procedure ROnAfterMoveDone; override;
+ procedure ROnAfterSetPosition; override;
+ procedure RDrawHiddenBoard; override;
+
+ public
+ procedure WriteGameToBase(vGameResult: TGameResult);
+ procedure SetExternalBase(const vsExtPosBaseName: string);
+ procedure UnsetExternalBase;
+ constructor Create(voOwner: TComponent; vfHandler: TChessBoardHandler; const vsPosBaseName: string);
+ destructor Destroy; override;
+ property pTrainingMode: boolean read _bTrainingMode write FSetTrainingMode;
+ property pUseUserBase: boolean read _bUseUserBase write FUseUserBase;
+ procedure PPRandom; reintroduce;
+ end;
+
+implementation
+
+uses
+ SysUtils, Graphics;
+
+type
+ TPrior = (mpNo, mpHigh, mpMid, mpLow);
+
+ PMovePrior = ^TMovePrior;
+ TMovePrior = record
+ move: TMoveAbs;
+ prior: TPrior;
+ end;
+
+ TPosBaseOperator = class(TThread)
+ private
+ _enuOperation: (opRead, opWrite);
+ _oChessBoard: TPosBaseChessBoard;
+ _bHidden: boolean;
+ protected
+ procedure Execute; override;
+ public
+ constructor CreateRead(voChessBoard: TPosBaseChessBoard; vbHidden: boolean; vbFreeOnTerminate: boolean = TRUE);
+ constructor CreateWrite(voChessBoard: TPosBaseChessBoard);
+ end;
+
+var
+ gameResult: TGameResult; // íå íèòåáåçîïàñíî
+ gameID: word; // èñïîëüçóåòñÿ ïðè çàïèñè óíèêàëüíûõ ïîçèöèé (íå íèòåáåçîïàñíî)
+
+const
+ NUM_PRIORITIES = 3; // ìàêñèìàëüíîå êîëè÷åñòâî ïðèîðèòåòîâ
+{$IFDEF RESTRICT_TRAINING_DB}
+ MAX_PLY_TO_BASE = 60;
+{$ELSE}
+ MAX_PLY_TO_BASE = -1; // â áàçó ñîõðàíÿåòñÿ âñÿ èãðà ïîëíîñòüþ
+{$ENDIF}
+
+{------------- TPosBaseChessBoard --------------}
+
+constructor TPosBaseChessBoard.Create(voOwner: TComponent; vfHandler: TChessBoardHandler; const vsPosBaseName: string);
+begin
+ inherited Create(voOwner, vfHandler);
+
+ _bUseUserBase := TRUE;
+ _sPosBaseName := vsPosBaseName;
+ _lstMovePrior := TList.Create;
+end;
+
+
+destructor TPosBaseChessBoard.Destroy;
+var
+ i: integer;
+begin
+ for i := 0 to _lstMovePrior.Count - 1 do
+ dispose(_lstMovePrior[i]);
+ _lstMovePrior.Free;
+
+ pTrainingMode := FALSE;
+
+ inherited;
+end;
+
+
+procedure Reestimate(lstMoveEsts: TList; viRec: integer);
+var
+ est: SmallInt;
+ id: word;
+begin
+ id := LongWord(lstMoveEsts[viRec]) shr 16;
+ if id = gameID then
+ exit; // ïîçèöèÿ äóáëèðóåòñÿ â ðàìêàõ îäíîé ïàðòèè
+
+ est := SmallInt(lstMoveEsts[viRec]);
+ case gameResult of
+ grWin: inc(est, 2);
+ grWinTime: inc(est);
+ grDraw: ;
+ grLost: dec(est, 2);
+ grLostTime: dec(est);
+ end;
+ lstMoveEsts[viRec] := Pointer((gameID shl 16) or Word(est));
+end;
+
+
+procedure TPosBaseChessBoard.FSetTrainingMode(vbTrainingMode: boolean);
+begin
+ if _bTrainingMode = vbTrainingMode then
+ exit;
+
+ _bTrainingMode := vbTrainingMode;
+ try
+ if _bTrainingMode then
+ begin
+ _oPosBase := TPosBase.Create(_sPosBaseName, Reestimate);
+ if _sExtPosBaseName <> '' then
+ _oExtPosBase := TPosBase.Create(_sExtPosBaseName);
+ TPosBaseOperator.CreateRead(self, FALSE);
+ end
+ else
+ begin
+ FreeAndNil(_oPosBase);
+ FreeAndNil(_oExtPosBase);
+ end;
+ except
+ on Exception do
+ begin
+ FreeAndNil(_oPosBase);
+ FreeAndNil(_oExtPosBase);
+ _bTrainingMode := FALSE;
+ end;
+ end;
+end;
+
+
+procedure TPosBaseChessBoard.FUseUserBase(vbUseUserBase: boolean);
+begin
+ if _bUseUserBase = vbUseUserBase then
+ exit;
+ _bUseUserBase := vbUseUserBase;
+ TPosBaseOperator.CreateRead(self, FALSE);
+end;
+
+
+procedure TPosBaseChessBoard.RDrawHiddenBoard;
+const
+ ARROW_END_LENGTH = 10; // â ïèêñåëÿõ
+ ARROW_END_ANGLE = 15 * (Pi / 180); // óãîë êîíöîâ ñòðåëêè
+ ARROW_INDENT = 7;
+
+ HIGH_ARROW_COLOR = clRed;
+ HIGH_ARROW_WIDTH = 2;
+ MID_ARROW_COLOR = clTeal;
+ MID_ARROW_WIDTH = 2;
+ LOW_ARROW_COLOR = clSkyBlue;
+ LOW_ARROW_WIDTH = 1;
+
+var
+ i, x0, y0, x, y: integer;
+ xa, ya, ca, sa: double;
+ move: TMoveAbs;
+begin
+ if (not Assigned(bmHiddenBoard)) then
+ exit;
+
+ inherited;
+
+ if not _bTrainingMode or (Mode <> mGame) or (PlayerColor <> PositionColor) then
+ exit;
+
+ bmHiddenBoard.Canvas.Pen.Style := psSolid;
+
+ for i := 0 to _lstMovePrior.Count - 1 do
+ begin
+ case PMovePrior(_lstMovePrior[i]).prior of
+ mpNo: continue;
+ mpHigh:
+ begin
+ bmHiddenBoard.Canvas.Pen.Color := HIGH_ARROW_COLOR;
+ bmHiddenBoard.Canvas.Pen.Width := HIGH_ARROW_WIDTH;
+ end;
+ mpMid:
+ begin
+ bmHiddenBoard.Canvas.Pen.Color := MID_ARROW_COLOR;
+ bmHiddenBoard.Canvas.Pen.Width := MID_ARROW_WIDTH;
+ end;
+ mpLow:
+ begin
+ bmHiddenBoard.Canvas.Pen.Color := LOW_ARROW_COLOR;
+ bmHiddenBoard.Canvas.Pen.Width := LOW_ARROW_WIDTH;
+ end;
+ end;
+ move := PMovePrior(_lstMovePrior[i]).move;
+ if not flipped then
+ begin
+ x0 := CHB_X + iSquareSize * (move.i0 - 1) + (iSquareSize div 2);
+ y0 := CHB_Y + iSquareSize * (8 - move.j0) + (iSquareSize div 2);
+ x := CHB_X + iSquareSize * (move.i - 1) + (iSquareSize div 2);
+ y := CHB_Y + iSquareSize * (8 - move.j) + (iSquareSize div 2);
+ end
+ else
+ begin
+ x0 := CHB_X + iSquareSize * (8 - move.i0) + (iSquareSize div 2);
+ y0 := CHB_Y + iSquareSize * (move.j0 - 1) + (iSquareSize div 2);
+ x := CHB_X + iSquareSize * (8 - move.i) + (iSquareSize div 2);
+ y := CHB_Y + iSquareSize * (move.j - 1) + (iSquareSize div 2);
+ end;
+
+ // Ðèñîâàíèå ñòðåëêè
+ ca := (x - x0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ sa := (y - y0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ x0 := x0 + Round(ARROW_INDENT * ca);
+ y0 := y0 + Round(ARROW_INDENT * sa);
+ x := x - Round(ARROW_INDENT * ca);
+ y := y - Round(ARROW_INDENT * sa);
+
+ bmHiddenBoard.Canvas.MoveTo(x0, y0);
+ bmHiddenBoard.Canvas.LineTo(x, y);
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ bmHiddenBoard.Canvas.LineTo(Round(xa), Round(ya));
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ bmHiddenBoard.Canvas.MoveTo(x, y);
+ bmHiddenBoard.Canvas.LineTo(Round(xa), Round(ya));
+ end;
+
+end;
+
+
+procedure TPosBaseChessBoard.ROnAfterMoveDone;
+begin
+ inherited;
+ if (_bTrainingMode) then
+ begin
+ if (PlayerColor = PositionColor) then
+ TPosBaseOperator.CreateRead(self, TRUE) // ÷òåíèå èç áàçû è âûâîä íà ñêðûòóþ äîñêó
+ end;
+end;
+
+
+procedure TPosBaseChessBoard.ROnAfterSetPosition;
+var
+ PosBaseOperator: TPosBaseOperator;
+begin
+ if (_bTrainingMode) then
+ begin
+ PosBaseOperator := TPosBaseOperator.CreateRead(self, FALSE, FALSE); // ÷òåíèå èç áàçû è âûâîä íà ñêðûòóþ äîñêó
+ PosBaseOperator.WaitFor;
+ PosBaseOperator.Free;
+ end;
+end;
+
+
+procedure TPosBaseChessBoard.SetExternalBase(const vsExtPosBaseName: string);
+begin
+ if _bTrainingMode then
+ begin
+ if _sExtPosBaseName = vsExtPosBaseName then
+ exit;
+ FreeAndNil(_oExtPosBase);
+ _oExtPosBase := TPosBase.Create(vsExtPosBaseName);
+ TPosBaseOperator.CreateRead(self, FALSE);
+ end;
+ _sExtPosBaseName := vsExtPosBaseName;
+end;
+
+
+function EstComape(item1, item2: pointer): integer;
+begin
+ Result := SmallInt(PMoveEst(item2).estimate and $FFFF) - SmallInt(PMoveEst(item1).estimate and $FFFF);
+end;
+
+
+procedure TPosBaseChessBoard.FReadFromBase;
+
+ procedure ClasterMoves(var rlstMove: TList); // êëàñòåðèçàöèÿ õîäîâ
+ var
+ i, j, num_clast, i_min, j_min, curr_assoc: integer;
+ modus_min: double;
+ clastWeights: array of record
+ grav: double;
+ assoc: integer;
+ end;
+ mp: PMovePrior;
+ p: TPrior;
+ begin
+ if rlstMove.Count = 0 then
+ exit;
+
+ rlstMove.Sort(EstComape);
+ SetLength(clastWeights, rlstMove.Count);
+
+ num_clast := rlstMove.Count;
+ for i := 0 to num_clast - 1 do
+ begin
+ clastWeights[i].assoc := i + 1;
+ clastWeights[i].grav := SmallInt(PMoveEst(rlstMove[i]).estimate and $FFFF);
+ end;
+
+ repeat
+ i_min := 0;
+ j_min := 0;
+ modus_min := $7FFF; // $7FFF - ìàêñ. çíà÷åíèå äëÿ îöåíêè
+ curr_assoc := 0; // òåêóùèé ïðîñìàòðèâàåìûé êëàñòåð
+
+ for i := 0 to length(clastWeights) - 2 do
+ begin
+ if curr_assoc = clastWeights[i].assoc then
+ continue;
+ curr_assoc := clastWeights[i].assoc;
+ for j := i + 1 to length(clastWeights) - 1 do
+ if (clastWeights[j].assoc <> clastWeights[j-1].assoc) and
+ (curr_assoc <> clastWeights[j].assoc) and
+ (abs(clastWeights[i].grav - clastWeights[j].grav) <= modus_min) then
+ begin
+ i_min := i;
+ j_min := j;
+ modus_min := abs(clastWeights[i].grav - clastWeights[j].grav);
+ end;
+ end;
+
+ if (num_clast > Ord(High(TPrior))) or (modus_min = 0.0) then
+ begin
+ for i := High(clastWeights) downto j_min do
+ if clastWeights[i].assoc = clastWeights[j_min].assoc then
+ clastWeights[i].assoc := clastWeights[i_min].assoc;
+ clastWeights[i_min].grav := (clastWeights[i_min].grav + clastWeights[j_min].grav) / 2;
+ end;
+
+ dec(num_clast);
+ until (num_clast <= Ord(High(TPrior))) and ((modus_min <> 0.0) or (num_clast < 1));
+
+ p := mpHigh;
+ for i := 0 to rlstMove.Count - 1 do
+ begin
+ new(mp);
+ if (i > 0) and (clastWeights[i].assoc > clastWeights[i-1].assoc) then
+ p := Succ(p);
+ mp.move := PMoveEst(rlstMove[i]).move;
+ mp.prior := p;
+ dispose(rlstMove[i]);
+ rlstMove[i] := mp;
+ end;
+
+ SetLength(clastWeights, 0);
+ end;
+
+var
+ lstUsrMove, lstExtMove: TList;
+
+ procedure MergeMoves;
+ function NEqualMoves(i,j: integer): boolean;
+ begin
+ with PMovePrior(lstExtMove[i])^, PMovePrior(_lstMovePrior[j]).move do
+ Result := (i0 = move.i0) and (j0 = move.j0) and (j = move.j) and (i = move.i) and
+ (prom_fig = move.prom_fig);
+ end;
+
+ var
+ i, j, n: integer;
+ const
+ PRIOR_CALC: array[TPrior, TPrior] of TPrior =
+ ((mpNo, mpNo, mpNo, mpNo), // UsrPrior = mpNo - ?, ò.ê. åù¸ íèãäå íå èñï.
+ (mpHigh, mpHigh, mpHigh, mpMid), // UsrPrior = mpHigh
+ (mpMid, mpMid, mpMid, mpMid), // UsrPrior = mpMid
+ (mpLow, mpMid, mpLow, mpLow)); // UsrPrior = mpLow
+ begin
+ for i := 0 to lstUsrMove.Count - 1 do
+ _lstMovePrior.Add(lstUsrMove[i]);
+
+ // Ñëèâàíèå ñïèñêîâ
+ n := _lstMovePrior.Count;
+ for i := 0 to lstExtMove.Count - 1 do
+ begin
+ j := n - 1;
+ while (j >= 0) do
+ begin
+ if NEqualMoves(i,j) then
+ begin
+ PMovePrior(_lstMovePrior[j]).prior :=
+ PRIOR_CALC[PMovePrior(_lstMovePrior[j]).prior, PMovePrior(lstExtMove[j]).prior];
+ dispose(lstExtMove[i]);
+ break;
+ end;
+ dec(j);
+ end;
+ if j < 0 then
+ _lstMovePrior.Add(lstExtMove[i]);
+ end; { for }
+ end;
+
+var
+ i: integer;
+begin
+ for i := 0 to _lstMovePrior.Count - 1 do
+ dispose(_lstMovePrior[i]);
+ _lstMovePrior.Clear;
+
+ lstExtMove := nil;
+ lstUsrMove := TList.Create;
+ try
+ lstExtMove := TList.Create;
+
+ if _bUseUserBase or (not Assigned(_oExtPosBase)) then
+ _oPosBase.Find(Position^, lstUsrMove);
+ if Assigned(_oExtPosBase) then
+ _oExtPosBase.Find(Position^, lstExtMove);
+
+ // TODO: Handle wrong DB
+
+ ClasterMoves(lstUsrMove);
+ ClasterMoves(lstExtMove);
+ MergeMoves;
+
+ finally
+ lstExtMove.Free;
+ lstUsrMove.Free;
+ end;
+end;
+
+
+procedure TPosBaseChessBoard.WriteGameToBase(vGameResult: TGameResult);
+begin
+ if not _bTrainingMode then
+ exit;
+ gameResult := vGameResult;
+ TPosBaseOperator.CreateWrite(self);
+end;
+
+
+procedure TPosBaseChessBoard.FWriteGameToBase;
+var
+ ply: integer;
+begin
+ gameID := Random($FFFF) + 1;
+
+ if (PlayerColor = fcWhite) then
+ ply := 0
+ else
+ ply := 1;
+
+ while ((ply < PositionsList.Count) and ((MAX_PLY_TO_BASE < 0) or (ply <= MAX_PLY_TO_BASE))) do
+ begin
+ _oPosBase.Add(PPosMove(PositionsList[ply])^);
+ inc(ply, 2);
+ end;
+end;
+
+
+procedure TPosBaseChessBoard.UnsetExternalBase;
+begin
+ FreeAndNil(_oExtPosBase);
+end;
+
+
+procedure TPosBaseChessBoard.PPRandom;
+var
+ PosBaseOperator: TPosBaseOperator;
+begin
+ inherited;
+ if _bTrainingMode then
+ begin
+ PosBaseOperator := TPosBaseOperator.CreateRead(self, FALSE, FALSE); // ÷òåíèå èç áàçû è âûâîä íà ñêðûòóþ äîñêó
+ PosBaseOperator.WaitFor;
+ PosBaseOperator.Free;
+ end;
+end;
+
+{------------- TPosBaseOperator --------------}
+
+constructor TPosBaseOperator.CreateRead(voChessBoard: TPosBaseChessBoard; vbHidden: boolean; vbFreeOnTerminate: boolean = TRUE);
+begin
+ _enuOperation := opRead;
+ _oChessBoard := voChessBoard;
+ _bHidden := vbHidden;
+
+ inherited Create(TRUE);
+ Priority := tpNormal;
+ FreeOnTerminate := vbFreeOnTerminate;
+ Resume;
+end;
+
+
+constructor TPosBaseOperator.CreateWrite(voChessBoard: TPosBaseChessBoard);
+begin
+ _oChessBoard := voChessBoard;
+ _enuOperation := opWrite;
+ inherited Create(TRUE);
+ Priority := tpNormal;
+ FreeOnTerminate := TRUE;
+ Resume;
+end;
+
+
+procedure TPosBaseOperator.Execute;
+begin
+ case _enuOperation of
+ opRead:
+ _oChessBoard.FReadFromBase;
+ opWrite:
+ _oChessBoard.FWriteGameToBase;
+ end;
+end;
+
+
+initialization
+ Randomize;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas b/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas new file mode 100644 index 0000000000..60f6cba6c4 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas @@ -0,0 +1,603 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit PosBaseUnit;
+
+interface
+
+uses
+ Classes,
+ //
+ ChessRulesEngine;
+
+type
+ PMoveEst = ^TMoveEst;
+ TMoveEst = record
+ move: TMoveAbs;
+ estimate: LongWord;
+ end;
+
+ TReestimate = procedure(moveEsts: TList; nRec: integer);
+
+ TPosBaseStream = class
+ private
+ m_iRecordSize: integer;
+ m_iHeaderSize: integer;
+ m_InnerStream: TStream;
+ constructor Create(const strFileName: string; RecordSize: integer);
+ function FGetSize: integer;
+ public
+ destructor Destroy; override;
+ procedure SeekHeader;
+ procedure SeekRec(lwRecordNumber: LongWord);
+ procedure SeekEnd;
+ procedure Write(const Buffer); overload;
+ procedure Write(const Buffer; Count: integer); overload;
+ procedure Read(var Buffer); overload;
+ procedure Read(var Buffer; Count: integer); overload;
+ property Size: integer read FGetSize;
+ property HeaderSize: integer read m_iHeaderSize write m_iHeaderSize;
+ end;
+
+ TPosBase = class
+ private
+ m_iDBVersion: Integer;
+ fPos: TPosBaseStream;
+ fMov: TPosBaseStream;
+ FReestimate: TReestimate;
+ procedure FCreateStreams(const strPosFileName, strMovFileName: string);
+ procedure FDestroyStreams;
+ procedure FSetDBVersion;
+ function FCheckDBVersion: Boolean;
+ public
+ procedure Add(const posMove: TPosMove); // äîáàâëåíèå ïîçèöèè è õîäà â áàçó
+ function Find(const pos: TChessPosition): boolean; overload;
+ function Find(const pos: TChessPosition; var moveEsts: TList): boolean; overload;
+ constructor Create(fileNameNoExt: string; Reestimate: TReestimate = nil);
+ destructor Destroy; override;
+ end;
+
+implementation
+
+uses
+ SysUtils;
+
+type
+ TFieldNode = packed object
+ public
+ btField: byte;
+ private
+ m_btNextNode: byte; // ñë. óçåë
+ m_wNextNode: word;
+ m_btNextValue: byte; // ñë. çíà÷åíèå äàííûõ
+ m_wNextValue: word;
+ function FGetNextNode: LongWord;
+ procedure FSetNextNode(lwValue: LongWord);
+ function FGetNextValue: LongWord;
+ procedure FSetNextValue(lwValue: LongWord);
+ public
+ property NextNode: LongWord read FGetNextNode write FSetNextNode;
+ property NextValue: LongWord read FGetNextValue write FSetNextValue;
+ end;
+
+ TMoveNode = packed object
+ public
+ wMove: word;
+ estimate: LongWord;
+ private
+ m_btNextValue: byte; // ñë. çíà÷åíèå äàííûõ
+ m_wNextValue: word;
+ function FGetNextValuePos: LongWord;
+ procedure FSetNextValuePos(lwValue: LongWord);
+ public
+ procedure EmptyNode;
+ property NextValue: LongWord read FGetNextValuePos write FSetNextValuePos;
+ end;
+
+ TCoord = record
+ i, j: integer;
+ end;
+
+const
+ POS_FILE_EXT = 'pos';
+ MOV_FILE_EXT = 'mov';
+
+ DB_VERSION = 1;
+
+ FIELD_SEQ: array[1..64] of TCoord = // 13617 kb
+ ((i: 1; j: 1), (i: 1; j: 2), (i: 1; j: 3), (i: 1; j: 4),
+ (i: 1; j: 5), (i: 1; j: 6), (i: 1; j: 7), (i: 1; j: 8),
+ (i: 8; j: 8), (i: 8; j: 7), (i: 8; j: 6), (i: 8; j: 5),
+ (i: 8; j: 4), (i: 8; j: 3), (i: 8; j: 2), (i: 8; j: 1),
+ (i: 2; j: 1), (i: 2; j: 2), (i: 2; j: 3), (i: 2; j: 4),
+ (i: 2; j: 5), (i: 2; j: 6), (i: 2; j: 7), (i: 2; j: 8),
+ (i: 7; j: 8), (i: 7; j: 7), (i: 7; j: 6), (i: 7; j: 5),
+ (i: 7; j: 4), (i: 7; j: 3), (i: 7; j: 2), (i: 7; j: 1),
+ (i: 3; j: 1), (i: 3; j: 2), (i: 3; j: 3), (i: 3; j: 4),
+ (i: 3; j: 5), (i: 3; j: 6), (i: 3; j: 7), (i: 3; j: 8),
+ (i: 6; j: 8), (i: 6; j: 7), (i: 6; j: 6), (i: 6; j: 5),
+ (i: 6; j: 4), (i: 6; j: 3), (i: 6; j: 2), (i: 6; j: 1),
+ (i: 4; j: 1), (i: 4; j: 2), (i: 4; j: 3), (i: 4; j: 4),
+ (i: 4; j: 5), (i: 4; j: 6), (i: 4; j: 7), (i: 4; j: 8),
+ (i: 5; j: 1), (i: 5; j: 2), (i: 5; j: 3), (i: 5; j: 4),
+ (i: 5; j: 5), (i: 5; j: 6), (i: 5; j: 7), (i: 5; j: 8));
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBase
+
+constructor TPosBase.Create(fileNameNoExt: string; Reestimate: TReestimate = nil);
+begin
+ inherited Create;
+
+ self.FReestimate := Reestimate;
+
+ FCreateStreams(fileNameNoExt + '.' + POS_FILE_EXT,
+ fileNameNoExt + '.' + MOV_FILE_EXT);
+ FSetDBVersion;
+end;
+
+
+destructor TPosBase.Destroy;
+begin
+ FDestroyStreams;
+ inherited;
+end;
+
+
+procedure TPosBase.FSetDBVersion;
+var
+ btData: byte;
+ wVersion: word;
+begin
+ m_iDBVersion := DB_VERSION; // default version
+
+ if (fPos.Size > 0) then
+ begin
+ fPos.SeekHeader;
+ fPos.Read(btData, SizeOf(btData));
+ if (btData <> $FF) then
+ begin
+ m_iDBVersion := 0;
+ fPos.HeaderSize := 0;
+ exit;
+ end;
+ fPos.Read(wVersion, SizeOf(wVersion));
+ m_iDBVersion := wVersion;
+ end
+ else
+ begin
+ btData := $FF;
+ wVersion := m_iDBVersion;
+ fPos.Write(btData, SizeOf(btData));
+ fPos.Write(wVersion, SizeOf(wVersion));
+ end;
+
+ fPos.HeaderSize := SizeOf(byte) + SizeOf(word);
+end;
+
+
+function TPosBase.FCheckDBVersion: Boolean;
+begin
+ Result := (m_iDBVersion <= DB_VERSION);
+end;
+
+
+procedure TPosBase.FCreateStreams(const strPosFileName, strMovFileName: string);
+begin
+ fPos := TPosBaseStream.Create(strPosFileName, SizeOf(TFieldNode));
+ fMov := TPosBaseStream.Create(strMovFileName, SizeOf(TMoveNode));
+end;
+
+
+procedure TPosBase.FDestroyStreams;
+begin
+ fMov.Free;
+ fPos.Free;
+end;
+
+
+function EncodeAddInf(const pos: TChessPosition): byte;
+begin
+ Result := pos.en_passant;
+ if WhiteKingSide in pos.castling then
+ Result := Result or $80;
+ if WhiteQueenSide in pos.castling then
+ Result := Result or $40;
+ if BlackKingSide in pos.castling then
+ Result := Result or $20;
+ if BlackQueenSide in pos.castling then
+ Result := Result or $10;
+end;
+
+
+function EncodeMove(const move: TMoveAbs): word;
+begin
+ with move do
+ Result := ((((((((i0-1) shl 3) or (j0-1)) shl 3) or (i-1)) shl 3) or (j-1)) shl 3) or Ord(prom_fig);
+end;
+
+
+procedure TPosBase.Add(const posMove: TPosMove);
+var
+ addInf: byte;
+ fn: TFieldNode;
+
+ procedure AddPosNodes(k: integer; r: integer = -1);
+ var
+ l, nr: integer;
+ mn: TMoveNode;
+ estList: TList;
+ begin
+ // Äîáàâëåíèå óçëîâ ïîçèöèè
+ if r >= 0 then
+ begin
+ nr := fPos.Size;
+ fn.NextValue := nr;
+ fPos.SeekRec(r);
+ fPos.Write(fn);
+ fPos.SeekRec(nr);
+ end
+ else
+ nr := 0;
+ for l := k to 66 do // 65 - äîï. èíô, 66 - öâåò.
+ begin
+ if l = 66 then
+ begin
+ fn.btField := ord(posMove.pos.color);
+ nr := fMov.Size;
+ end
+ else
+ begin
+ if l <= 64 then
+ fn.btField := ord(posMove.pos.board[FIELD_SEQ[l].i, FIELD_SEQ[l].j])
+ else // l = 65
+ fn.btField := addInf;
+ inc(nr);
+ end;
+ fn.NextNode := nr;
+ fn.NextValue := 0;
+ fPos.Write(fn);
+ end;
+ // ôîðìèðîâàíèå çàïèñè õîäà
+ mn.EmptyNode;
+ mn.wMove := EncodeMove(posMove.move);
+
+ if Assigned(FReestimate) then
+ begin
+ estList := TList.Create;
+ try
+ estList.Add(Pointer(mn.estimate));
+ FReestimate(estList, 0);
+ mn.estimate := LongWord(estList[0]);
+ finally
+ estList.Free;
+ end;
+
+ end;
+ fMov.SeekEnd;
+ fMov.Write(mn);
+ end;
+
+var
+ k, r, pr, rm, moveSet, moveCount: integer;
+ mv: word;
+ mn: TMoveNode;
+ enc_mv: word;
+ estList: TList;
+begin
+ if (not FCheckDBVersion) then
+ exit;
+
+ addInf := EncodeAddInf(posMove.pos);
+ if (fPos.Size = 0) then
+ begin
+ AddPosNodes(1);
+ exit;
+ end;
+ r := 0;
+ for k := 1 to 66 do // 65 - äîï. èíô, 66 - öâåò.
+ begin
+ fPos.SeekRec(r);
+ fPos.Read(fn);
+
+ while ((k <= 64) and (fn.btField <> ord(posMove.pos.board[FIELD_SEQ[k].i, FIELD_SEQ[k].j]))) or
+ ((k = 65) and (fn.btField <> addInf)) or
+ ((k = 66) and (fn.btField <> ord(posMove.pos.color))) do
+ begin
+ pr := r;
+ r := fn.NextValue;
+ if (r = 0) then
+ begin
+ AddPosNodes(k, pr);
+ exit;
+ end;
+ fPos.SeekRec(r);
+ fPos.Read(fn);
+ end; { while }
+ // çíà÷åíèå â öåïî÷êå íàéäåíî
+ r := fn.NextNode;
+ end;
+
+ moveCount := 0;
+ moveSet := -1;
+ estList := TList.Create;
+ try
+ rm := r;
+ enc_mv := EncodeMove(posMove.move);
+ repeat
+ pr := r;
+ fMov.SeekRec(r);
+ fMov.Read(mn);
+
+ mv := mn.wMove;
+ if mv = enc_mv then
+ moveSet := moveCount;
+
+ if Assigned(FReestimate) then
+ estList.Add(Pointer(mn.estimate));
+
+ inc(moveCount);
+ r := mn.NextValue;
+ until r = 0;
+
+ if moveSet < 0 then // õîäà íåò â ñïèñêå, äîáàâëÿåì
+ begin
+ // ñâÿçûâàíèå íîâîãî óçëà ñ òåêóùèì óçëîì
+ r := fMov.Size;
+ mn.NextValue := r;
+ fMov.SeekRec(pr);
+ fMov.Write(mn);
+
+ // Äîáàâëåíèå íîâîãî óçëà õîäîâ
+ mn.EmptyNode;
+ mn.wMove := enc_mv;
+ fMov.SeekRec(r);
+ fMov.Write(mn);
+
+ if Assigned(FReestimate) then
+ estList.Add(Pointer(mn.estimate));
+ moveSet := moveCount;
+ end;
+
+ if Assigned(FReestimate) then
+ begin
+ FReestimate(estList, moveSet);
+ for k := 0 to estList.Count - 1 do
+ begin
+ fMov.SeekRec(rm);
+ fMov.Read(mn);
+ if (mn.estimate <> LongWord(estList[k])) then
+ begin
+ mn.estimate := LongWord(estList[k]);
+ fMov.SeekRec(rm);
+ fMov.Write(mn);
+ end;
+ rm := mn.NextValue;
+ end;
+ end;
+
+ finally
+ estList.Free;
+ end;
+end;
+
+
+function TPosBase.Find(const pos: TChessPosition): boolean;
+var
+ lstDummy: TList;
+begin
+ lstDummy := nil;
+ Result := Find(pos, lstDummy);
+end;
+
+
+function TPosBase.Find(const pos: TChessPosition; var moveEsts: TList): boolean;
+
+ function DecodeMove(enc_move: word): TMoveAbs;
+ begin
+ with Result do
+ begin
+ prom_fig := TFigureName(enc_move and $07);
+ enc_move := enc_move shr 3;
+ j := (enc_move and $07) + 1;
+ enc_move := enc_move shr 3;
+ i := (enc_move and $07) + 1;
+ enc_move := enc_move shr 3;
+ j0 := (enc_move and $07) + 1;
+ enc_move := enc_move shr 3;
+ i0 := (enc_move and $07) + 1;
+ end;
+ end;
+
+var
+ k, r: integer;
+ fn: TFieldNode;
+ mn: TMoveNode;
+ pme: PMoveEst;
+label
+ here;
+begin // TPosBase.Find
+ Result := FALSE;
+
+ if (not FCheckDBVersion) then
+ exit;
+
+ if (Assigned(moveEsts)) then
+ begin
+ for k := 0 to moveEsts.Count - 1 do
+ Dispose(moveEsts[k]);
+ moveEsts.Clear;
+ end;
+
+ if (fPos.Size = 0) then
+ exit;
+
+ r := 0;
+ for k := 1 to 66 do // 65 - äîï. èíô, 66 - öâåò.
+ begin
+here:
+ fPos.SeekRec(r);
+ fPos.Read(fn);
+
+ r := fn.NextNode;
+ while ((k <= 64) and (fn.btField <> ord(pos.board[FIELD_SEQ[k].i, FIELD_SEQ[k].j]))) or
+ ((k = 65) and (fn.btField <> EncodeAddInf(pos))) or
+ ((k = 66) and (fn.btField <> ord(pos.color))) do
+ begin
+ r := fn.NextValue;
+ if r = 0 then
+ exit
+ else
+ goto here;
+ end; { while }
+ end; { for }
+
+ Result := TRUE;
+ if (not Assigned(moveEsts)) then
+ exit;
+
+ // Filling the moves list
+ repeat
+ fMov.SeekRec(r);
+ fMov.Read(mn);
+
+ new(pme);
+ pme^.move := DecodeMove(mn.wMove);
+ pme^.estimate := mn.estimate;
+ moveEsts.Add(pme);
+
+ r := mn.NextValue;
+ until (r = 0);
+
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TFieldNode
+
+function TFieldNode.FGetNextNode: LongWord;
+begin
+ Result := (m_wNextNode shl 8) or m_btNextNode;
+end;
+
+
+procedure TFieldNode.FSetNextNode(lwValue: LongWord);
+begin
+ m_btNextNode := lwValue and $FF;
+ m_wNextNode := lwValue shr 8;
+end;
+
+
+function TFieldNode.FGetNextValue: LongWord;
+begin
+ Result := (m_wNextValue shl 8) or m_btNextValue;
+end;
+
+
+procedure TFieldNode.FSetNextValue(lwValue: LongWord);
+begin
+ m_btNextValue := lwValue and $FF;
+ m_wNextValue := lwValue shr 8;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TMoveNode
+
+
+function TMoveNode.FGetNextValuePos: LongWord;
+begin
+ Result := (m_wNextValue shl 8) or m_btNextValue;
+end;
+
+
+procedure TMoveNode.FSetNextValuePos(lwValue: LongWord);
+begin
+ m_btNextValue := lwValue and $FF;
+ m_wNextValue := lwValue shr 8;
+end;
+
+
+procedure TMoveNode.EmptyNode;
+begin
+ FillChar(self, SizeOf(self), 0);
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseStream
+
+constructor TPosBaseStream.Create(const strFileName: string; RecordSize: integer);
+var
+ FileHandle: Integer;
+begin
+ inherited Create;
+
+ m_iRecordSize := RecordSize;
+
+ if (not FileExists(strFileName)) then
+ begin
+ FileHandle := FileCreate(strFileName);
+ FileClose(FileHandle);
+ end;
+
+ m_InnerStream := TFileStream.Create(strFileName, fmOpenReadWrite,
+ fmShareDenyWrite);
+end;
+
+
+destructor TPosBaseStream.Destroy;
+begin
+ m_InnerStream.Free;
+ inherited;
+end;
+
+
+function TPosBaseStream.FGetSize: integer;
+begin
+ Result := (m_InnerStream.Size - m_iHeaderSize) div m_iRecordSize;
+end;
+
+
+procedure TPosBaseStream.SeekHeader;
+begin
+ m_InnerStream.Seek(0, soFromBeginning);
+end;
+
+
+procedure TPosBaseStream.SeekRec(lwRecordNumber: LongWord);
+begin
+ m_InnerStream.Seek(m_iHeaderSize + lwRecordNumber * m_iRecordSize, soFromBeginning);
+end;
+
+
+procedure TPosBaseStream.SeekEnd;
+begin
+ m_InnerStream.Seek(0, soFromEnd);
+end;
+
+
+procedure TPosBaseStream.Write(const Buffer);
+begin
+ m_InnerStream.WriteBuffer(Buffer, m_iRecordSize);
+end;
+
+
+procedure TPosBaseStream.Write(const Buffer; Count: integer);
+begin
+ m_InnerStream.WriteBuffer(Buffer, Count);
+end;
+
+
+procedure TPosBaseStream.Read(var Buffer);
+begin
+ m_InnerStream.ReadBuffer(Buffer, m_iRecordSize);
+end;
+
+
+procedure TPosBaseStream.Read(var Buffer; Count: integer);
+begin
+ m_InnerStream.ReadBuffer(Buffer, Count);
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/PromotionUnit.dfm b/plugins/!NotAdopted/Chess4Net/PromotionUnit.dfm new file mode 100644 index 0000000000..08762c7c8d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/PromotionUnit.dfm @@ -0,0 +1,30 @@ +object PromotionForm: TPromotionForm
+ Left = 1
+ Top = 1
+ Cursor = crHandPoint
+ AutoSize = True
+ BorderIcons = []
+ BorderStyle = bsNone
+ BorderWidth = 2
+ Caption = 'Promoting Figures'
+ ClientHeight = 40
+ ClientWidth = 166
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ OldCreateOrder = False
+ OnKeyPress = FormKeyPress
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object PromFigImage: TImage
+ Left = 0
+ Top = 0
+ Width = 166
+ Height = 40
+ OnMouseUp = PromFigImageMouseUp
+ end
+end
diff --git a/plugins/!NotAdopted/Chess4Net/PromotionUnit.pas b/plugins/!NotAdopted/Chess4Net/PromotionUnit.pas new file mode 100644 index 0000000000..10ed8a9218 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/PromotionUnit.pas @@ -0,0 +1,202 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit PromotionUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, ExtCtrls,
+ // Chess4net
+ ChessRulesEngine, ChessBoardHeaderUnit, BitmapResUnit;
+
+type
+ TPromotionForm = class(TForm)
+ PromFigImage: TImage;
+ procedure FormShow(Sender: TObject);
+ procedure PromFigImageMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure FormKeyPress(Sender: TObject; var Key: Char);
+ private
+ m_iSquareSize: integer;
+ m_BitmapRes: TBitmapRes;
+ m_bmFigure: array[TFigure] of TBitmap;
+ m_fig_color: TFigureColor;
+ m_fig: TFigureName;
+ procedure FLoadFigures;
+ public
+ function ShowPromotion(color: TFigureColor): TFigureName;
+ constructor Create(AOwner: TComponent; BitmapRes: TBitmapRes); reintroduce;
+ destructor Destroy; override;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+const
+ INDENT_SIZE = 2;
+
+////////////////////////////////////////////////////////////////////////////////
+// TPromotionForm
+
+procedure TPromotionForm.FormShow(Sender: TObject);
+
+ procedure NCorrectIfOutOfScreen(var iLeft, iTop: integer);
+ var
+ R: TRect;
+ M: TMonitor;
+ frmOwner: TForm;
+ begin
+ if (Assigned(Owner)) then
+ frmOwner := (Owner as TForm)
+ else
+ frmOwner := nil;
+ if (Assigned(frmOwner)) then
+ begin
+ M := Screen.MonitorFromRect(frmOwner.BoundsRect);
+ R := M.WorkareaRect;
+ end
+ else
+ R := Screen.WorkAreaRect;
+
+ if ((iLeft + self.Width) > R.Right) then
+ iLeft := R.Right - self.Width;
+ if (iLeft < R.Left) then
+ iLeft := R.Left;
+ if ((iTop + self.Height) > R.Bottom) then
+ iTop := R.Bottom - self.Height;
+ if (iTop < R.Top) then
+ iTop := R.Top;
+ end;
+
+var
+ k: byte;
+ iLeft, iTop: integer;
+begin // TPromotionForm.FormShow
+ if (m_iSquareSize <> m_BitmapRes.SquareSize) then
+ FLoadFigures;
+
+ // Óñòàíîâèòü îêíî â ïðåäåëàõ êóðñîðà
+ iLeft := Mouse.CursorPos.X - m_iSquareSize div 2;
+ iTop := Mouse.CursorPos.Y - m_iSquareSize div 2;
+
+ NCorrectIfOutOfScreen(iLeft, iTop);
+
+ Left := iLeft;
+ Top := iTop;
+
+ with PromFigImage.Canvas do
+ begin
+ Brush.Color:= Color;
+ FillRect(Rect(0,0, Width, PromFigImage.Height));
+
+ Brush.Color:= clWhite;
+ for k := 0 to 3 do
+ FillRect(Rect((m_iSquareSize + INDENT_SIZE) * k, 0,
+ (m_iSquareSize + INDENT_SIZE) * k + m_iSquareSize - 1, m_iSquareSize - 1));
+
+ case m_fig_color of
+ fcWhite:
+ begin
+ Draw(0, 0, m_bmFigure[WQ]);
+ Draw(m_iSquareSize + 2, 0, m_bmFigure[WR]);
+ Draw(2 * (m_iSquareSize + INDENT_SIZE), 0, m_bmFigure[WB]);
+ Draw(3 * (m_iSquareSize + INDENT_SIZE), 0, m_bmFigure[WN]);
+ end;
+ fcBlack:
+ begin
+ Draw(0, 0, m_bmFigure[BQ]);
+ Draw(m_iSquareSize + INDENT_SIZE, 0, m_bmFigure[BR]);
+ Draw(2 * (m_iSquareSize + INDENT_SIZE), 0, m_bmFigure[BB]);
+ Draw(3 * (m_iSquareSize + INDENT_SIZE), 0, m_bmFigure[BN]);
+ end;
+ end;
+ end;
+end;
+
+
+function TPromotionForm.ShowPromotion(color: TFigureColor): TFigureName;
+begin
+ m_fig := Q;
+ m_fig_color := color;
+
+ ShowModal;
+
+ Result := m_fig;
+end;
+
+
+procedure TPromotionForm.PromFigImageMouseUp(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+begin
+ case X div (m_BitmapRes.SquareSize + 1) of
+ 1: m_fig := R;
+ 2: m_fig := B;
+ 3: m_fig := N;
+ else
+ m_fig := Q;
+ end;
+
+ Close;
+end;
+
+procedure TPromotionForm.FormKeyPress(Sender: TObject; var Key: Char);
+begin
+ Key:= UpCase(Key);
+ case Key of
+ 'Q', '1', ' ', #13:
+ m_fig:= Q;
+ 'R', '2':
+ m_fig:= R;
+ 'B', '3':
+ m_fig:= B;
+ 'N', '4':
+ m_fig:= N;
+ else
+ exit;
+ end;
+ Close;
+end;
+
+
+constructor TPromotionForm.Create(AOwner: TComponent; BitmapRes: TBitmapRes);
+begin
+ self.FormStyle := (AOwner as TForm).FormStyle;
+ inherited Create(AOwner);
+ m_BitmapRes := BitmapRes;
+ FLoadFigures;
+end;
+
+
+destructor TPromotionForm.Destroy;
+var
+ fig: TFigure;
+begin
+ for fig := Low(m_bmFigure) to High(m_bmFigure) do
+ m_bmFigure[fig].Free;
+ inherited;
+end;
+
+
+procedure TPromotionForm.FLoadFigures;
+var
+ fig: TFigure;
+begin
+ for fig := Low(m_bmFigure) to High(m_bmFigure) do
+ begin
+ FreeAndNil(m_bmFigure[fig]);
+ m_BitmapRes.CreateFigureBitmap(fig, m_bmFigure[fig]);
+ end;
+ m_iSquareSize := m_BitmapRes.SquareSize;
+
+ // Adjust size of the form
+ PromFigImage.Width := 4 * m_iSquareSize + 3 * INDENT_SIZE;
+ PromFigImage.Height := m_iSquareSize;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/Readme.txt b/plugins/!NotAdopted/Chess4Net/Readme.txt new file mode 100644 index 0000000000..a2270d957d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Readme.txt @@ -0,0 +1,279 @@ +Chess4Net
+(c) 2007-2011 No rights reserved
+E-Mail: packpaul@mail.ru, packpaul1@gmail.com
+Skype: packpaul1
+URL: http://chess4net.ru
+==============================================
+
+Opening
+--------
+
+Chess4Net is a program for playing chess via Internet. It can be used as a standalone application (Socket version for Microsoft Windows or Linux) or as plug-in for such instant messengers as Skype, Miranda, QIP Infium, Trillian Pro and &RQ. Two modes of chess game are supported: standart chess and its random counterpart - PP Random Chess. Chess4Net supports sudden death and incremental time controls as well as possibility to give your opponent a time-handicap. If you want to improve your chess skills there is also a support for a training mode. You can also invite other contacts to watch the games you're playing in real-time.
+
+Middle game
+------------
+
+Installation:
+
+Socket version:
+ Extract the archive to desired folder on your computer.
+
+Skype plug-in:
+ * Windows:
+ There're two options. You can either install from installation package or download an archive and extract it to a desired folder on your computer (Windows version).
+
+ * Linux:
+ Extract downloaded archive to a folder. If you're root then make the user to have full access to the installation folder.
+
+Miranda plug-in:
+ Extract archive to the Miranda Plugins directory and re/start Miranda.
+
+QIP Infium plug-in:
+ Extract archive to the QIP Infium Plugins directory and re/start QIP Infium
+
+Trillian Pro plug-in:
+ Extract archive to the Trillian plugins directory; go to Trillian->Trillian Preferences... choose Plugins and check Chess4Net_trillian.dll box.
+
+&RQ plug-in:
+ Extract archive folder Plugins\ to the installation directory of &RQ (the one where &RQ.exe is located).
+
+How to use:
+
+Socket version:
+ 1) Start Chess4Net.exe
+ 2) Choose 'Connect...'
+ 3) Type in-your name into 'Your Nick' edit-box.
+ a) Choose Server; provide your partner with IP (type 'ipconfig' in Start->Run... or command line to find it out in Windows; run ./get_ip.pl from installation in terminal on Linux); enter Port# (agree upon it with your partner).
+ b) Choose Client; Enter IP or domain Name that your partner told you; Enter Port# (for each instance of Chess4Net it should be unique).
+ 4) Click OK and wait until the connection is completed.
+
+Skype:
+ * Windows:
+ 1) Run Chess4Net_Skype.exe. If you don't have Skype running it will start automatically. Click 'Allow access' when dialog 'Chess4Net_Skype.exe wants to use Skype' pops-up.
+ 2) When a window with Skype contacts appears choose a contact you want to play chess with.
+ 3) Wait until connection is completed.
+
+ * Linux
+ 1) You should have Skype running and be logged in to it.
+ 2) In terminal go to the installation folder for example:
+ cd ~/Chess4Net_Skype
+ 3) Run Chess4Net:
+ ./Chess4Net_Skype
+
+Miranda:
+ 1) Right-click the contact you want to play chess with and select 'Chess4Net' from contact pop-up menu.
+ 2) Wait until connection is completed.
+
+QIP Infium:
+ 1) Open a chat window for the contact you want to play chess with.
+ 2) Press 'Chess4Net' message button (below the upper frame on the right where the incomming and outgoing messages are shown).
+
+Trillian Pro:
+ 1) Right-click the contact you want to play chess with and select 'Chess4Net' from pop-up menu or open message window for that contact and type "/CHESS4NET" without double quotes.
+ 2) Wait until connection is completed.
+ NB: Chess4Net uses instant messages to transmit moves and other information. In Trillian Pro there is no way to suppress messages unlike in Miranda, so
+you may want to switch off the sounds for incomming messages while playing.
+
+&RQ:
+ 1) Open a chat window for the contact you want to play chess with.
+ 2) Press 'Chess4Net' chat button (below the upper frame where the incomming and outgoing messages are shown).
+ 3) Wait until connection is completed.
+
+Chess4Net uses context-menu so if you find yourself in trouble don't hesitate and press the right button of your mouse.
+After several runs in installation folder (socket, Skype) or \Chess4Net folder (messengers other than Skype) you will find Chess4Net_GAMELOG.txt with all games you have played with Chess4Net so far, user data base (Chess4Net.pos and Chess4Net.mov) and external data bases (other files *.pos and *.mov) which are used in training mode.
+
+Training mode:
+
+The training mode can be switched on/off in Game Options menu. The user data base and external data bases are used in training mode only. The User DB will contain all games played by the user in the training mode, and data from it is used to provide prioritized move hints.
+User DB can learn from your games in order to give you best choices. You can also select an external DB to use together with user DB to improve the quality of move hints.
+
+Game transmitting mode:
+
+While you're playing some games you can invite other contacts to follow up these games in real-time. Therefore you must
+
+Miranda:
+ start a new session of Chess4Net for a contact you want the game(s) be transmitted to. A mode selection dialog appears asking if game broadcasting has to be started. You must select 'Yes' (if you select 'No' an ordinary game session is created). After that you should select a game for transmition (only if there're several games in progress).
+
+Skype:
+ select Broadcast... from pop-up menu. A list of contacts appears. Select a contact whom you want to transmit the game played to.
+
+After your contact connects he/she'll be able to watch the game.
+
+
+Endgame
+--------
+
+Chess4Net is constantly improving and it is up to you what features will be included in the next release. Please send all your wishes and/or complaints to E-mail: packpaul@mail.ru or ICQ: 98750806 or Skype: packpaul1
+Chess4Net is a software and, like it is peculiar to software, it will never be bug free. Please report all bugs you may find to packpaul@mail.ru but see change log before reporting.
+
+How you can help?
+-----------------
+If you like Chess4Net you can give your credits at http://chess4net.ru or make some reasonable donations to Yandex-Money: 41001124111397 or Web Money: 774788633995. Also you can provide localization into new languages (see Lang.ini), and, of course, your fresh ideas won't be unnoticed!
+
+Congratulations you won!
+------------------------
+
+"I want this feature and I want it right now!!!"
+You can have this tuning. Drop me an E-mail we will discuss it.
+
+"I want more external data bases!"
+Yes, you can have them. E-mail me and we will discuss it too.
+
+"I want an external DB with the games of the champion from our town and my games played in the Icelandic National Championship!"
+Why not? You can have them. Send me an E-mail and we will discuss this.
+
+ENJOY!
+
+PP
+
+==============================
+
+Change log
+-----------
+
+Chess4Net 2011.1 (Skype)
+[2011-08-06] Localization for German, French, Italian and Estonian
+[2011-08-01] Game resurection after application failure improved
+[2011-07-24] Keeping Skype connection alive feature
+[2011-05-23] Game transmition feature
+[2011-05-30] Incorrect chess clock timing on different locales fix
+[2011-06-01] Stay on top enabled
+
+
+Chess4Net 2010.0 (MI)
+[2010-05-28] Game retransmition feature added. Dialog handling improved (stay on top, out of screen etc). Majority of crashes fixed. Games numbering if several ones are played.
+
+
+Chess4Net 2010.1 (Skype)
+[2010-02-07] Released with Credits reminder.
+[2010-03-06] Skype accept help image added.
+[2010-11-13] Linux version released
+
+
+Chess4net 2009.1 (MI)
+[2009-01-01] Localization for English and Russian and possibility to add new languages. Chess board resizing. Possibility to play more than one game simultaneously (multi-sessionality). Flashing window on incomming move.
+
+
+Chess4net 2008.1 (&RQ)
+[2008-06-28] Game adjourn feature added.
+
+
+Chess4net 2008.1 (Trillian)
+[2008-06-28] About dialog and game adjourn feature added.
+
+
+Chess4net 2008.1 (QIP Infium)
+[2008-06-28] Game adjourn feature added.
+
+
+Chess4net 2008.1 (MI)
+[2008-04-19] About dialog and game adjourn feature added.
+
+
+Chess4net 2008.0 (&RQ)
+[2008-02-12] New API version of 9.7.4 is utilized: no history entries are done anymore when plugin messages are transmited. Compatibility with 9.7.3 version is preserved.
+
+
+Chess4net 2008.0 (QIP Infium)
+[2007-12-31] Released; This version has some important restrictions: you will NOT be able to play against Chess4Net clients of other IMs due to the restriction imposed on QIP Infium SDK ver. 1.3.0 (waiting for that to be fixed)
+
+
+Chess4net 2007.6 (Socket - Linux)
+[2007-12-8] Released; code and functionality branched from Chess4net 2007.6 (Socket - Windows)
+
+
+Chess4net 2007.6 (Socket - Windows)
+[2007-10-09] Dialogs' caption changed to 'Chess4Net'. Casual color desynchronization on game start fixed.
+[2007-10-16] Game pause functionality introduced; Flag UI introduced; spin boxes added to Game Options dialog.
+[2007-10-17] Connector module slightly improved.
+[2007-11-25] Bugs in game options dialog fixed; auto-flag bugs fixed
+[2007-12-05] Critical bug in logic after en passant capture with double pawn in a position fixed. [!!!PLEASE UPDATE TO CURRENT VERSION!!!]
+[2007-12-07] Switching color disabled after the game has started
+
+
+Chess4net 2007.6 (MI)
+[2007-10-10] Dialogs handling improved.
+[2007-10-11] Casual ñolor desynchronization on game start fixed; Game pause functionality introduced.
+[2007-10-12] Writing empty games to game log canceled.
+[2007-10-16] Flag UI introduced; spin boxes added to Game Options dialog.
+[2007-11-25] Bugs in game options dialog fixed; auto-flag bugs fixed
+[2007-12-05] Critical bug in logic after en passant capture with double pawn in a position fixed. [!!!PLEASE UPDATE TO CURRENT VERSION!!!]
+[2007-12-07] Switching color disabled after the game has started
+
+
+Chess4net 2007.6 (Trillian)
+[2007-10-10] Dialogs handling improved.
+[2007-10-11] Casual ñolor desynchronization on game start fixed.
+[2007-10-16] Flag UI introduced; spin boxes added to Game Options dialog.
+[2007-10-17] Game pause functionality introduced;
+[2007-11-25] Bugs in game options dialog fixed; auto-flag bugs fixed
+[2007-12-05] Critical bug in logic after en passant capture with double pawn in a position fixed. [!!!PLEASE UPDATE TO CURRENT VERSION!!!]
+[2007-12-07] Switching color disabled after the game has started
+
+
+Chess4net 2007.6 (&RQ)
+[2007-10-10] Dialogs handling improved.
+[2007-10-11] Casual ñolor desynchronization on game start fixed.
+[2007-10-16] Flag UI introduced; spin boxes added to Game Options dialog.
+[2007-10-17] Game pause functionality introduced;
+[2007-11-25] Bugs in game options dialog fixed; auto-flag bugs fixed
+[2007-12-05] Critical bug in logic after en passant capture with double pawn in a position fixed. [!!!PLEASE UPDATE TO CURRENT VERSION!!!]
+[2007-12-07] Switching color disabled after the game has started
+
+
+Chess4net 2007.5 (Socket)
+[2007-08-29] Protocol changed; Takebacks on first move fixed; New behaviour to Game Options dialog introduced; Saving private and public settings introduced (also IP+port, socket state and nick); Display of hint moves after takeback and on start fixed; Amount of entries of training DB restricted up to 30 per game; 'Disconnect' item moved to lower part of pop-up menu.
+
+
+Chess4net 2007.5 (MI)
+[2007-08-22] Protocol changed; Takebacks on first move fixed; New behaviour to Game Options dialog introduced.
+[2007-08-24] Crash on opening pawn promotion window fixed.
+[2007-08-25] Saving private and public settings introduced.
+[2007-08-26] Creation of training DBs with empty name fixed.
+[2007-08-27] Display of hint moves after takeback and on start fixed.
+[2007-08-29] Bug with resetting of exteral training base for standard and PP mode fixed; Amount of entries of training DB restricted up to 30 per game.
+[2007-09-03] Hiding of Old version warning dialog in Always On Top mode fixed.
+[2007-09-12] Objectionable 'ext' command message suppreced.
+[2007-09-13] Wrong clock settings saving when client was forcibly closed.
+[2007-09-26] Modal dialogs with 'Stay On Top' option switched on caused AV error -> fixed.
+
+
+Chess4net 2007.5 (Trillian)
+[2007-09-13] A port of Chess4Net for Trillian has appeared. Some issues are still there: no icon for client menu; it was impossible to suppress Ch4N messages.
+[2007-09-15] HTML untagging for incomming plugin messages done.
+
+
+Chess4net 2007.5 (&RQ)
+[2007-09-17] A port of Chess4Net for &RQ has appeared. There are some issues though: it was impossible to force the outgoing messages be hidden from chat window (lack of API -> PE_MSG_SENT should be fired after the message actually has gone).
+
+
+Chess4Net 2007.4 (Socket)
+[2007-05-23] Training mode added.
+[2007-05-25] Tending to backward compatibility.
+[2007-05-31] Wrong pop-up menu by disconnection fixed.
+[2007-06-21] Clock setting to 0.0 after time control is out fixed.
+[2007-07-17] Extra Exit on ESCAPE added; Background of coordinates improved.
+
+
+Chess4Net 2007.4 (MI)
+[2007-05-21] New wellcome message.
+[2007-05-23] Training mode added.
+[2007-05-25] Tending to backward compatibility.
+[2007-07-17] Extra Exit on ESCAPE added; Background of coordinates improved; Click-click synchronization fixed; AV by pawn promotion fixed
+
+
+Chess4Net 2007.3 (Socket)
+[2007-03-31] time display refresh fixed when changing colors.
+[2007-04-01] game log added; 'Equal time for both players' checkbox initialization fixed.
+
+
+Chess4Net 2007.3 (MI)
+[2007-02-15] time incrementation fixed.
+[2007-03-31] game log added; time display refresh fixed when changing colors; ver. info changed.
+[2007-04-01] 'Equal time for both players' checkbox initialization fixed.
+[2007-04-02] 'Chess4Net' title addedd to pop-up windows; Chess4Net icon added to plugin window and contact menu.
+[2007-04-03] Saving to game log on exit and on connection error fixed.
+
+
+Chess4Net 2007.2 (Socket)
+[2007-02-15] time incrementation fixed.
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/Readme_RU.txt b/plugins/!NotAdopted/Chess4Net/Readme_RU.txt Binary files differnew file mode 100644 index 0000000000..cd9cf6b5d0 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/Readme_RU.txt diff --git a/plugins/!NotAdopted/Chess4Net/TODO.txt b/plugins/!NotAdopted/Chess4Net/TODO.txt new file mode 100644 index 0000000000..b41ea802b9 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/TODO.txt @@ -0,0 +1,62 @@ +- Äîáàâèòü â Readme óïîìèíàíèå î How you can help.
+- Message dialogs ïðè Stay on top ïðîïàäàþò.
+- Ch4N ïàäàåò, åñëè îòñóòñòâóåò Lang.ini
+- Ñäåëàòü ñêðèïò ñðåçêè ðåëèçà.
+
+
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Chess4Net Skype 2011.2
+
+- Ðåäèçàéí GUI
+- Ïîçèöèîíèðîâàíèå è ðàçìåð äîñêè
+- Ãîñòåâîé ñïèñîê
+- Èíäèêàòîð "÷åé õîä"
+
+Chess4Net Skype 2011.1
+
+- Ðåòðàíñëÿöèÿ ïàðòèé: ñìåíà öâåòà ïðè ïðîñìîòðå ïàðòèé
+- Âåðñèîííîñòü/ñòàòèñòèêà
+- -> Skype API support
+- Ïîâåðõ âñåõ îêîí
+
+Chess4Net 2011.1
+
+- Ñâîè ìåòîäû äåêîäèðîâàíèÿ âðåìåíè
+
+Chess4Net 2009.1
+
+- AV ïðè âûõîäå èç Ìèðàíäû ïðè íå çàêðûòîì Ch4N
+
+Chess4Net 2008.1
+
+- â äèñòðèáóòèâå äëÿ ëèíóêñà õîðîøî èìåòü ôàéë README, â êîòîðîì âêðàòöå îïèñàíà ïðîãà è êàê åå çàïóñêàòü (è ññûëêà íà àâòîðà è âåá ñàéò).
+- Èíîãäà ïîä Ubuntu îêîøêî ïðè âûõîäå ïèøåò "Do you want to". Ýòî ïîÿâëÿåòñÿ ïðè âòîðîé ïîïûòêå âûõîäà, êîãäà ïåðâàÿ ïîïûòêà áûëà îòìåíåíà
+- Ïðè àêòèâíîì îêîøêå "Do you want to exit" ïðè íàæàòèè Ecs ïðîèñîäèò âûõîä èç ïðîãðàììû, à äîëæíî îòìåíèòüñÿ çàïðîñ íà âûõîä.
+- Ñäåëàé ïðîâåðêó íà ââîä àé-ïè àäðåñà
+- Ïî÷åìó ïðè ñîåäèíåíèå ñ çàâåäîìî íåâåðíûì ñåðâåðîì âñå ðàâíî ïðîèñõîäèò îæèäàíèå ïîäêëþ÷íèÿ? Ìîæíî ëè ñðàçó îïðåäåëèòü, ÷òî ñåðâåð íåäîñòóïåí
+- Ïðîèñõîäèò ñîåäèíåíèå ñ äðóãèìè äåìîíàìè (ssh, web servers) êàê áóäòî ñ òâîèì øàõìàòíûì ñåðâåðîì. Ìîæåò ìîæíî ïåðåñûëàòü êàêîé-íèáóäü àé-äè, ïîäòâåæäàþùèé, ÷òî ñîåäèíåíèå ïðîèçîøëî èìåííî ñ òâîèì øàõìàòíûì ñåðâåðîì, à íå ñ êåì-òî äðóãèì.
+- ïðè ñîçäàíèè ñåðâåðà íà óæå çàíÿòîì ïîðòå âûñêàêèâàåò òàáëè÷êà "An error during connection" äâà ðàçà. Êñòàòè, æåëàòåëüíî áû ïîòî÷íåå ÷òî çà îøèáêà ïðîèçîøëà.
+- Ïî÷åìó âèäíî êóðñîð â ñïèñêà "Animate Move". Ñîçäàåòñÿ âïå÷àòëåíèå, ÷òî òóäà ìîæíî ÷òî-òî âïèñàòü
+- Âîîáùå ïî ïðàâèëàì îôîðìëåíèÿ èíòåðôåéñîâ â ïðåäëîæåíèÿõ ïîñëå ÷åêáîêñîâ íå ñëåäóåò ïèñàòü âñå ñëîâà ñ çàãëàâíûõ áóêâ. Ýòî äåëàåòñÿ â íàçâàíèÿõ êíîïîê.
+Ïîñëå ïðåäëîæåíèé ïåðåä ñïèñêàìè ñòàâèòñÿ äâîåòî÷èå, ò.å. "Animate move:" âìåñòî "Animate Move".
+
+
+- ïîäñîåäèíåíèå ê íåïðàâèëüíîìó ñåðâåðó
+- Default(íûå) çíà÷åíèÿ (Enter, Esc) â Game Options... è Look and Feel
+- äîèãðûâàíèå ïàðòèé (ôóíêöèîíàëüíîñòü àíàëèçà)
+- ìèãàíèå îêíà ïðè õîäå ïðîòèâíèêà.
+- <takeback> ôóíêöèîíàëüíîñòü - ?
+- Stay On Top (íå ðàáîòàåò â ñîêåòíîé âåðñèè)
+- ïîäàâëåíèå ïðèãëàøåíèÿ ïðè óæå çàêîííåê÷åííîì êëèåíòå. - ?
+- ñîõðàíåíèå îòëîæåííûõ ïàðòèé
+- Ñòðåëêè äëÿ ïåøåê ïðåâðàùåíèÿ
+- ïîñëåäíèé âûèãðûâàþùèé õîä â ñåðèè
+- Íåìîäàëüíîå îêíî ïðåâðàùåíèé â Miranda(å)
+- ìèãàíèå îêîøêà íà ïàíåëå çàäà÷ ïðè õîäå ïðîòèâíèêà.
+
+
+DONE:
+- game options unit
+- Îòñòóï ñòðîêè ìåæäó èãðîêàìè è òåêñòîì ïàðòèè ïðè u:u â Game log(å)
+- óáèðàíèå ôëàãà ïðè ñèíõðîíèçàöèè âðåìåíè è èíêðåìåíòå
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.dfm b/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.dfm new file mode 100644 index 0000000000..3fc902a9e3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.dfm @@ -0,0 +1,7 @@ +object URLVersionQuery: TURLVersionQuery
+ OldCreateOrder = False
+ Left = 562
+ Top = 338
+ Height = 102
+ Width = 215
+end
diff --git a/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.pas b/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.pas new file mode 100644 index 0000000000..24c73a1a94 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/URLVersionQueryUnit.pas @@ -0,0 +1,185 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit URLVersionQueryUnit;
+
+interface
+
+uses
+ Classes;
+
+type
+ TApplicationID = (aidAnalyzer = 1, aidSkype = 2);
+ TOperatingSystemID = (osidWindows = 1, osidLinux = 2);
+
+ TURLVersionQuery = class;
+
+ TQueryReadyEvent = procedure(Sender: TURLVersionQuery) of object;
+
+ TURLVersionQuery = class(TDataModule)
+ private
+ m_iLastVersion: integer;
+ m_wstrInfo: WideString;
+ FQueryReadyEvent: TQueryReadyEvent;
+ procedure FDoQueryReady;
+ function FQuery(const strURL: string): string;
+ function FGetURL(ApplicationID: TApplicationID; iVersion: integer;
+ OperatingSystemID: TOperatingSystemID): string;
+ procedure FParseResponse(const strResponse: string);
+ public
+ constructor Create; reintroduce;
+ procedure Query(ApplicationID: TApplicationID; iVersion: integer;
+ OperatingSystemID: TOperatingSystemID);
+ property LastVersion: integer read m_iLastVersion;
+ property Info: WideString read m_wstrInfo;
+ property OnQueryReady: TQueryReadyEvent read FQueryReadyEvent write FQueryReadyEvent;
+ end;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ Forms, SysUtils, StrUtils,
+ //
+ XIE;
+
+type
+ TQueryThread = class(TThread)
+ private
+ m_URLVersionQuery: TURLVersionQuery;
+ m_strURL: string;
+ m_strResponse: string;
+ procedure FNotifyOnResponse;
+ protected
+ procedure Execute; override;
+ public
+ constructor Create(AURLVersionQuery: TURLVersionQuery; const strURL: string);
+ end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TURLVersionQuery
+
+constructor TURLVersionQuery.Create;
+begin
+ inherited Create(Application);
+end;
+
+procedure TURLVersionQuery.FDoQueryReady;
+begin
+ if (Assigned(FQueryReadyEvent)) then
+ FQueryReadyEvent(self);
+end;
+
+
+procedure TURLVersionQuery.Query(ApplicationID: TApplicationID; iVersion: integer;
+ OperatingSystemID: TOperatingSystemID);
+begin
+ TQueryThread.Create(self, FGetURL(ApplicationID, iVersion, OperatingSystemID));
+end;
+
+
+function TURLVersionQuery.FQuery(const strURL: string): string;
+begin
+ with TIEWrapper.Create do
+ try
+ Result := OpenRequest(strURL);
+ finally
+ Free;
+ end;
+end;
+
+
+function TURLVersionQuery.FGetURL(ApplicationID: TApplicationID; iVersion: integer;
+ OperatingSystemID: TOperatingSystemID): string;
+begin
+ Result := Format('http://chess4net.ru/stat.php?app=%d&ver=%d&os=%d',
+ [Ord(ApplicationID), iVersion, Ord(OperatingSystemID)]);
+end;
+
+
+procedure TURLVersionQuery.FParseResponse(const strResponse: string);
+
+ procedure NSplit(const str: string; out strlList: TStringList);
+ var
+ iPosPrev, iPosNext: integer;
+ strSub: string;
+ begin
+ strlList := TStringList.Create;
+
+ strSub := '';
+ iPosPrev := 1;
+
+ while (iPosPrev <= Length(str)) do
+ begin
+ iPosNext := iPosPrev;
+
+ iPosNext := PosEx(';', str, iPosNext);
+
+ if (iPosNext = 0) then
+ iPosNext := MaxInt - 1;
+
+ strSub := strSub + Copy(str, iPosPrev, iPosNext - iPosPrev);
+ if ((iPosNext < Length(str)) and (str[iPosNext + 1] = ';')) then
+ begin
+ strSub := strSub + ';';
+ iPosPrev := iPosNext + 2;
+ continue;
+ end;
+
+ strlList.Append(strSub);
+ strSub := '';
+
+ iPosPrev := iPosNext + 1;
+ end;
+
+ end;
+
+var
+ strl: TStringList;
+begin // .FParseResponse
+ NSplit(strResponse, strl);
+ try
+ m_iLastVersion := StrToIntDef(strl.Values['Last version'], 0);
+ m_wstrInfo := strl.Values['Info'];
+ finally
+ strl.Free;
+ end;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TQueryThread
+
+constructor TQueryThread.Create(AURLVersionQuery: TURLVersionQuery; const strURL: string);
+begin
+ m_URLVersionQuery := AURLVersionQuery;
+ m_strURL := strURL;
+
+ inherited Create(TRUE);
+ FreeOnTerminate := TRUE;
+
+ Resume;
+end;
+
+
+procedure TQueryThread.Execute;
+begin
+{$IFNDEF TESTING}
+ m_strResponse := m_URLVersionQuery.FQuery(m_strURL);
+{$ELSE}
+ m_strResponse := 'Last version=201102;Info=Version 2011.2 is available'#10'TEST> You can download it from http://chess4net.ru <TEST';
+{$ENDIF}
+ Synchronize(FNotifyOnResponse);
+end;
+
+
+procedure TQueryThread.FNotifyOnResponse;
+begin
+ m_URLVersionQuery.FParseResponse(m_strResponse);
+ m_URLVersionQuery.FDoQueryReady;
+end;
+
+end.
diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/adler32.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/adler32.obj Binary files differnew file mode 100644 index 0000000000..84d2850efa --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/adler32.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/compress.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/compress.obj Binary files differnew file mode 100644 index 0000000000..90cf74f1e4 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/compress.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/crc32.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/crc32.obj Binary files differnew file mode 100644 index 0000000000..ea14153d31 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/crc32.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/deflate.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/deflate.obj Binary files differnew file mode 100644 index 0000000000..3ffc8bcae9 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/deflate.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/gzio.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/gzio.obj Binary files differnew file mode 100644 index 0000000000..ff94037b1e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/gzio.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/infback.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/infback.obj Binary files differnew file mode 100644 index 0000000000..2114f10ad5 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/infback.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inffast.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inffast.obj Binary files differnew file mode 100644 index 0000000000..c8f5b1f5e5 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inffast.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inflate.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inflate.obj Binary files differnew file mode 100644 index 0000000000..4c53c01a93 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inflate.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inftrees.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inftrees.obj Binary files differnew file mode 100644 index 0000000000..c37455e249 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/inftrees.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/trees.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/trees.obj Binary files differnew file mode 100644 index 0000000000..98a6110b3f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/trees.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/uncompr.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/uncompr.obj Binary files differnew file mode 100644 index 0000000000..12cd70b661 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/uncompr.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/zutil.obj b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/zutil.obj Binary files differnew file mode 100644 index 0000000000..9395409f01 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/obj/zutil.obj diff --git a/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pngextra.pas b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pngextra.pas new file mode 100644 index 0000000000..c219e7e22e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pngextra.pas @@ -0,0 +1,353 @@ +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/!NotAdopted/Chess4Net/lib/PNGImage/pngimage.pas b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pngimage.pas new file mode 100644 index 0000000000..320891d4d3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pngimage.pas @@ -0,0 +1,5824 @@ +{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/!NotAdopted/Chess4Net/lib/PNGImage/pnglang.pas b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pnglang.pas new file mode 100644 index 0000000000..c4a5fb84c1 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/pnglang.pas @@ -0,0 +1,355 @@ +{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/!NotAdopted/Chess4Net/lib/PNGImage/zlibpas.pas b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/zlibpas.pas new file mode 100644 index 0000000000..64a8526bd4 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/PNGImage/zlibpas.pas @@ -0,0 +1,156 @@ +{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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas new file mode 100644 index 0000000000..c515cf9a36 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/ActiveIMM_TLB.pas @@ -0,0 +1,1374 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas new file mode 100644 index 0000000000..0f3e69893c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntActnList.pas @@ -0,0 +1,835 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas new file mode 100644 index 0000000000..bc4b03c883 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntAxCtrls.pas @@ -0,0 +1,191 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas new file mode 100644 index 0000000000..2528c42ffb --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntBandActn.pas @@ -0,0 +1,92 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas new file mode 100644 index 0000000000..dd2ab6028c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntButtons.pas @@ -0,0 +1,982 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas new file mode 100644 index 0000000000..9d1ae95aa3 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCheckLst.pas @@ -0,0 +1,184 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas new file mode 100644 index 0000000000..e99c0fa3a5 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClasses.pas @@ -0,0 +1,1780 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas new file mode 100644 index 0000000000..cf2c16e9f6 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntClipBrd.pas @@ -0,0 +1,86 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas new file mode 100644 index 0000000000..42bec4cd46 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntComCtrls.pas @@ -0,0 +1,5058 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc new file mode 100644 index 0000000000..5ab13901ba --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntCompilers.inc @@ -0,0 +1,356 @@ +//----------------------------------------------------------------------------------------------------------------------
+// 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas new file mode 100644 index 0000000000..55025ecdc2 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas @@ -0,0 +1,1099 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas new file mode 100644 index 0000000000..4490bd12e2 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDB.pas @@ -0,0 +1,900 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas new file mode 100644 index 0000000000..681257ec1a --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBActns.pas @@ -0,0 +1,594 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas new file mode 100644 index 0000000000..98904c7380 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBClientActns.pas @@ -0,0 +1,197 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas new file mode 100644 index 0000000000..49111d4aba --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBCtrls.pas @@ -0,0 +1,2195 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas new file mode 100644 index 0000000000..2664bf7b5a --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBGrids.pas @@ -0,0 +1,1175 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm new file mode 100644 index 0000000000..fd0a07196b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.dfm @@ -0,0 +1,108 @@ +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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas new file mode 100644 index 0000000000..c8747e2f2a --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDBLogDlg.pas @@ -0,0 +1,133 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas new file mode 100644 index 0000000000..0c06d07f7d --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntDialogs.pas @@ -0,0 +1,981 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas new file mode 100644 index 0000000000..cf1f342142 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtActns.pas @@ -0,0 +1,1400 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas new file mode 100644 index 0000000000..4789fa714a --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtCtrls.pas @@ -0,0 +1,1062 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas new file mode 100644 index 0000000000..528c4f9f8f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntExtDlgs.pas @@ -0,0 +1,317 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas new file mode 100644 index 0000000000..892bd801ae --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFileCtrl.pas @@ -0,0 +1,118 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas new file mode 100644 index 0000000000..1149ec8f32 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntFormatStrUtils.pas @@ -0,0 +1,503 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas new file mode 100644 index 0000000000..780005714e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas @@ -0,0 +1,873 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas new file mode 100644 index 0000000000..617b901f77 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGraphics.pas @@ -0,0 +1,142 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas new file mode 100644 index 0000000000..8096cd445b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntGrids.pas @@ -0,0 +1,675 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas new file mode 100644 index 0000000000..7219950865 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFiles.pas @@ -0,0 +1,1011 @@ +{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas new file mode 100644 index 0000000000..87ec613976 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntIniFilesEx.pas @@ -0,0 +1,205 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas new file mode 100644 index 0000000000..00601c0449 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntListActns.pas @@ -0,0 +1,207 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas new file mode 100644 index 0000000000..577764661c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntMenus.pas @@ -0,0 +1,1146 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas new file mode 100644 index 0000000000..e3f445f92b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntRegistry.pas @@ -0,0 +1,148 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas new file mode 100644 index 0000000000..118e806336 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdActns.pas @@ -0,0 +1,1922 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas new file mode 100644 index 0000000000..09c7da4573 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntStdCtrls.pas @@ -0,0 +1,3215 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas new file mode 100644 index 0000000000..f6cd3e2ebb --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSysUtils.pas @@ -0,0 +1,1699 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas new file mode 100644 index 0000000000..cc99aa48f7 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntSystem.pas @@ -0,0 +1,1384 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas new file mode 100644 index 0000000000..02a64bbc3e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrUtils.pas @@ -0,0 +1,451 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas new file mode 100644 index 0000000000..dfe3755403 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWideStrings.pas @@ -0,0 +1,831 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas new file mode 100644 index 0000000000..12d74d8344 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntWindows.pas @@ -0,0 +1,1452 @@ +
+{*****************************************************************************}
+{ }
+{ 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/!NotAdopted/Chess4Net/lib/XIE/XIE.pas b/plugins/!NotAdopted/Chess4Net/lib/XIE/XIE.pas new file mode 100644 index 0000000000..bd2498e738 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/XIE/XIE.pas @@ -0,0 +1,333 @@ +{ =============================================================================
+
+ 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.
diff --git a/plugins/!NotAdopted/Chess4Net/res/BITMAPS.zip b/plugins/!NotAdopted/Chess4Net/res/BITMAPS.zip Binary files differnew file mode 100644 index 0000000000..510898f58a --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/BITMAPS.zip diff --git a/plugins/!NotAdopted/Chess4Net/res/BOARD.bmp b/plugins/!NotAdopted/Chess4Net/res/BOARD.bmp Binary files differnew file mode 100644 index 0000000000..6ccdd0f58b --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/BOARD.bmp diff --git a/plugins/!NotAdopted/Chess4Net/res/Delphi/Buttons.res b/plugins/!NotAdopted/Chess4Net/res/Delphi/Buttons.res Binary files differnew file mode 100644 index 0000000000..864f367d26 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/Delphi/Buttons.res diff --git a/plugins/!NotAdopted/Chess4Net/res/Delphi/Controls.res b/plugins/!NotAdopted/Chess4Net/res/Delphi/Controls.res Binary files differnew file mode 100644 index 0000000000..cd915ce63c --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/Delphi/Controls.res diff --git a/plugins/!NotAdopted/Chess4Net/res/Delphi/Extdlgs.res b/plugins/!NotAdopted/Chess4Net/res/Delphi/Extdlgs.res Binary files differnew file mode 100644 index 0000000000..9eaaa08d10 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/Delphi/Extdlgs.res diff --git a/plugins/!NotAdopted/Chess4Net/res/MakeRes.bat b/plugins/!NotAdopted/Chess4Net/res/MakeRes.bat new file mode 100644 index 0000000000..763831564f --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/MakeRes.bat @@ -0,0 +1 @@ +brcc32.exe %1
\ No newline at end of file diff --git a/plugins/!NotAdopted/Chess4Net/res/PNG_SET.zip b/plugins/!NotAdopted/Chess4Net/res/PNG_SET.zip Binary files differnew file mode 100644 index 0000000000..81f51e921e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/res/PNG_SET.zip diff --git a/plugins/!NotAdopted/ShlExt/clean.bat b/plugins/!NotAdopted/ShlExt/clean.bat new file mode 100644 index 0000000000..575eed729c --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/clean.bat @@ -0,0 +1 @@ +del *.o *.ppu *.dll *.a fpc-res.res *.or
\ No newline at end of file diff --git a/plugins/!NotAdopted/ShlExt/docs/HowToBuild.txt b/plugins/!NotAdopted/ShlExt/docs/HowToBuild.txt new file mode 100644 index 0000000000..53b6738616 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/docs/HowToBuild.txt @@ -0,0 +1,22 @@ +shlext 2.0.0.9
+
+Info
+=======================
+
+This source code is based on shlext 1.0.6.6 with minor changes so that it works
+with FreePascal 2.2.2.
+
+The included headers (inc dir) are from Miranda 0.3.3.1 SDK and so if you want newer APIs
+then get the API headers from the latest SVN tree.
+
+Note: I have included v0.8.xx API changes for GUIDs within a new file (m_v8.inc)
+
+
+How to build
+=======================
+
+Make sure you have installed the FreePascal compiler ( http://freepascal.org )
+the latest version is 2.2.2 at the time of writing.
+
+Run "make.bat" in this directory, this contains all the command line switches
+for the newer version should produce shlext.dll
diff --git a/plugins/!NotAdopted/ShlExt/docs/shlext release notes.txt b/plugins/!NotAdopted/ShlExt/docs/shlext release notes.txt new file mode 100644 index 0000000000..0e58edf9ff --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/docs/shlext release notes.txt @@ -0,0 +1,344 @@ +shlext 2.0.1.2
+
+Contents:
+
+ Introduction ``What is shlext?``
+ Why so long?
+ What you need
+ New features
+ Features
+ Quirks
+ Important changes
+ But Miranda has drag'n'drop!
+ Installation
+ Upgrading/Removing
+ Translation
+ License
+ Contact/Bug reporting
+ Credits
+
+
+
+ ---Introduction ``What is shlext?``
+
+ shlext is a Miranda and Explorer shell plugin, it allows you to use your
+ contact list under any file/directory from Windows.
+
+ This means that you can right click on a file/folder, see "Miranda" and then
+ see your entire contact list! this is a feature that ICQ has built in.
+
+ shlext is better of course.
+
+ ---Why so long?
+
+ A few people contacted me aeons ago about implementing a better file scanner
+ so that they could recreate directories whilst sending, etc, I said I would do
+ this as soon as I had time, that was several months ago.
+
+ I had made several changes/bugfixes when I had time, because I'm a Miranda
+ dev too, I don't usually have lots of time for this plugin, however lately I needed
+ shlext to run again, since I was sending lots of docs/logs around with Miranda.
+
+ So I fixed several things and improved lots of other stuff so that other users
+ could use shlext again (the XP bug was really annoying as soon as I got XP myself ;)
+
+
+ ---What you need
+
+ (2008) You will need 0.7.xx or 0.8.x -- older versions will not work.
+
+ shlext should work on all Window Explorer versions that support it,
+ certain features will not work on older Explorers, i.e. icons, but you will
+ still be able to use the main function of shlext, selection 'n' transfer.
+
+ ---New Features (2.0.1.2)
+
+ * shlext is now compiled with Free Pascal 2.2.4
+
+ * shlext now works with Windows Vista:
+
+ 1. shlext cannot automatically register itself with Windows Explorer due to permissions issues in Vista,
+ therefore you will be UAC prompted if shlext detects you are running Vista and that shlext isn't registered
+ with Explorer.
+
+ This is almost automatic, and you just have to press "OK".
+
+ 2. The entire menu drawing was overhauled and now looks much better, new APIs are used so that Vista draws the menus
+ (with theme) but the status icons are still present.
+
+ * added UAC button for "Remove" from the options dialog.
+
+ * Removed GetMenuItemInfo() debug message box.
+
+ * Note: Miranda is a 32bit application, 64bit editions of Windows require a 64bit extension DLL, this is not possible at present.
+
+ ---New features (2.0.0.9+)
+
+ * shlext is now compiled with Free Pascal 2.2.2 which is a newer compiler with better
+ optimisations so shlext should be faster. (2002 v.s. 2008)
+
+ * shlext now works with Miranda 0.8.x UUID typing system and 0.8.xx plugin loading APIs,
+ 0.7.xx still works too however.
+
+ * shlext now keeps track of recently used contacts and builds a "MRU" menu for quick
+ access within the menu system. This cannot be disabled, if you hate this feature,
+ please stick pins into a voodoo doll named "Christian", that is all.
+
+ * The menu strings "Recently" and "Clear entries" are translate()able but MRU is not.
+
+ ---New features (1.0.6.6+)
+
+ * shlext will now use all your icons per protocol, **not** just the first iconset
+ it finds, it will also use everything properly (because it doesn't do the icon
+ extraction, it just asks Miranda [don't ask why it didn't do this before :P])
+
+ * shlext will now use a Translate()'d version of "Miranda" so that each menu
+ shown for a profile can be given a custom user string
+
+ * reimplemented file/folder selection, finally! a work-as-expected version, it will
+ scan and add all files and folders you give it, producing a file list in the background
+ (scanning your drive) and then send the list to Miranda to send to your selected contact.
+
+ * Added option for disabling status icons in menus, which means that you can use shlext
+ with shell variants/file managers that invoke the shlext interface, such as FAR, but
+ don't need/use the icons.
+
+ * Added option about hiding offline users from the context menu, if this option is off
+ it will fall back onto syncing with your contact list's "hide offline users"
+
+ * Added proper thread safety because Miranda 0.3 now has it.
+
+ * Completely reimplemented group parsing, which means that all the old group bugs
+ can be expected to be gone, note that shlext will now even create menus for
+ subgroups of the same name, e.g. "Miranda\Miranda".
+
+ * shlext will now not show a menu for a running Miranda fails the following checks:
+
+ * not running shlext (duh)
+ * no non-offline contacts (or you have the setting 'hide offline users')
+ * and so on
+
+ * shlext will now also completely ignore contacts on protocols who have no file transfer support
+
+
+ ---Features
+
+ shlext can:
+
+ * allow you to refer to your entire contact list from a file/folder context
+ menu, this includes multiple profiles! if you have Miranda running
+ different profiles, you'll see all your profiles as menu items as long
+ as you're running shlext as a Miranda plugin in that profile.
+
+ * Group ability, see a faithful menu rendition of your group hierarchy.
+ This means you can go something like File->My Profile->Work->Friends->Dude...
+
+ This feature can also be turned off, or enabled in sync with your contact
+ list option to "Disable groups", this is a per profile setting, i.e. setting
+ disable groups on one profile won't affect other profiles running shlext.
+
+ * Multi protocol aware, shlext can send to anyone on your contact list
+ not just ICQ!
+
+ * Each contact will be shown next to their status icon, as selected in your
+ profile(s) which means that you'll easily feel at home with the icons,
+ because they will be used as how they are set in each profile.
+
+ * lots of files, shlext will now, if given a directory/folder go into that
+ folder and scan for files and sub directories/folders til it's added
+ everything.
+
+ This means if you send c:\foobar, it will search c:\foobar\*.* for more
+ files to add, it will also add c:\foobar as a directory space to send.
+ Which means that if the other side hasn't got a 'foobar' directory, it will
+ be created! (Note: recreating directory trees depends on the protocol being used to send)
+
+
+ --Quirks
+
+ * shlext displays all your users by default, if your contact list is set to
+ NOT show offline users, then shlext will not show them.
+
+ * shlext doesn't use all your group settings, it will not ad here to
+ "hide offline users in here", however if a group has got offline users
+ it won't show them (per setting option!)
+
+
+
+ ---Important changes
+
+ Older versions of shlext did not go into folders more than one level, i.e.
+ if you added c:\foobar it would scan for c:\foobar\*.* and add all the files
+ but not go into each directory\folder deeper than that!
+
+ shlext also now does background selection scanning, which means when you select
+ a group of files/folders/directories, it will let you get on with chating
+ until it's made a file list which you can send to the person you've selected.
+
+ shlext will NOT send any file/folder/directory that is marked "hidden"
+
+ Also, sometimes you will see "n files, 1 directory" when you say select something
+ e.g. c:\foobar, this is because shlext now also includes the top level directory so that the
+ remote side will know to create it, as well as sub directories.
+
+
+
+ ---But Miranda has drag'n'drop!
+
+ Yeah, that's okay when you can reach Miranda, but I have multiple profiles and
+ the "hide after NN seconds" option enabled, also I have groups!
+
+ Miranda doesn't auto expand a group when someone is online unless you do that
+ yourself, which means drag 'n' drop has failed. Also, when you've selected a
+ large amount of files, Miranda will *freeze* completely whilst
+ it 1) scans all those files, 2) builds a copy of the given send list
+
+ Whilst shlext only freezes Miranda for the latter, and that is seldom a "complete freeze".
+
+ And of course, shlext uses Miranda 0.3's advanced threading services, which means
+ if you've asked shlext to build a massive send list, you can still exit Miranda safely
+ which you can't with drag 'n' drop!
+
+
+
+ ---Installation
+
+ If you've never installed shlext before, all you have to do is install it like
+ any other Miranda plugin, i.e. copy it to your plugins directory.
+
+ That's it! you should goto Miranda->Options->Plugins->Shell Context Menus
+ to see if you'd like to set any of the options, however shlext works straight
+ out of the box and you don't really need to set anything up after that.
+
+ If you want to use shlext with multiple profiles, you don't have to do any
+ special setting up either, just make sure that shlext is running with each Miranda
+ you want shlext to show a menu contact list for.
+
+ Make sure ALL copies of shlext.dll are the same, i.e. 1.0.6.6, if they're not
+ then shlext will fail (this doesn't mean 'crash').
+
+
+ ---Upgrading/Removing
+
+ Upgrading shlext has always been a pain for users (and me!) this is because
+ shlext.dll runs in Windows and in Miranda (at the same time).
+
+ So when you've shutdown Miranda, shlext.dll maybe kept in memory by Windows
+ to make things worse, clicking any file/folder will result in shlext.dll being
+ reloaded, so if you do shlext.dll->Delete, Windows will ask shlext.dll if
+ it wants to show any menus, nevermind the fact delete was selected!
+
+ This happens also if you just press 'delete' whilst shlext.dll is selected.
+
+ However! All is not lost, this is what you do:
+
+ * goto M->Options->Plugins and disable shlext.dll as a Miranda plugin
+ * goto M->Options->Plugins->Shell context menus and click 'Remove'.
+ * Shutdown Miranda IM
+
+ Advanced users only: ----------------------------------------------------
+
+ * Do all the above and then open a console window (Command prompt, etc)
+ * Make sure all applications have been shutdown
+ * Goto the directory where Miranda is, e.g. c:\, cd Miranda
+ * Goto Start->Shutdown, let the dialog come up and hold CTRL+ALT+SHIFT
+ and press cancel.
+
+ This will shutdown Explorer but not Windows, you can now do: del shlext.dll
+
+ * now run Explorer.exe usually in C:\Windows, shlext.dll will be removed.
+
+ ----------------------------------------------------------------------------
+
+ The remove button will ask Windows not to load it anymore, by removing
+ all shlext registry entries, the button will also remove any settings from your
+ profile settings database that it may of made.
+
+ You should now be able to delete shlext.dll! however if you still are unable
+ to, you may need to log out (if you're using XP/2000/NT) if you're using
+ 9x then you may have to restart Windows (pain I know, sorry!)
+
+ You should now be free of old shlext copies and you can refer to "Installation"
+ above.
+
+ If you were using shlext.dll with multiple profiles, the remove shlext
+ from each profile as stated above and then copy the newer shlext.dll to
+ your plugins folder.
+
+ ---Translation
+
+ I haven't been nice about translation strings in the past, but you
+ can pretty much translate everything shlext uses a string, even
+ "Miranda" which is shown in the menu.
+
+ Note that some strings can't be translated, this is because some parts
+ of the plugin run within Explorer and that doesn't have access to Miranda's
+ langpacks, the "Miranda" string that appears in menus is a special exception
+
+ ;
+ ; Translate()'able strings for shlext/2.0.0.9
+ ;
+
+ ;"Miranda" limited to 63characters! (exceed and it's chopped)
+ ;[Miranda]
+ ;[Problem, registration missing/deleted.]
+ ;[Successfully created shell registration.]
+ ;[Not Approved]
+ ;[Approved]
+ ;[Are you sure? this will remove all the settings stored in your database and all registry entries created for shlext to work with Explorer]
+ ;[Disable/Remove shlext]
+ ;[Shell context menus]
+
+ ; new in 2.0.0.9, both these strings cannot be longer than 63 chracters
+ ;[Clear entries]
+ ;[Recently]
+
+ ;IDD_SHLOPTS
+ ;[Menus]
+ ;[Display contacts in their assigned groups (if any)]
+ ;[Only if/when the contact list is using them]
+ ;[Display hidden, ignored or temporary contacts]
+ ;[Shell Status]
+ ;[Do not display the profile name in use]
+ ;[Contact Status]
+ ;[Show contacts that you have set privacy rules for]
+ ;[Remove]
+ ;[Do not show status icons in menus]
+ ;[Do not show contacts that are offline, even if my contact list does]
+
+
+
+
+ ---License
+
+ Like Miranda, shlext is released under the GPL, you may find the full
+ FreePascal source-code on the CVS in plugins module 'shlext'
+
+ You will need at least FreePascal/2.2.2, GNU make (if you want to use the makefile)
+
+ Follow the CVS links from http://sf.net/projects/miranda-icq/
+
+ Note: All the tools used to build shlext are also under the GPL!
+
+
+ ---Contact/Bug reporting
+
+ In the past shlext hasn't been as stable as it could be, but this was mainly
+ due to the problems of 0.2.0.0 and early 0.3.0.0 Miranda builds, I've taken
+ care to make sure things are stable as can be.
+
+ If you have any problems/crashes, please contact me at: egodust at users.sf.net.
+
+ Please include the following information: Windows version, service packs installed,
+ build version of Explorer, Miranda version, shlext version, a list of plugins
+ that you think maybe involved in crashes, steps to reproduce errors and so on.
+
+ Note that shlext has been blamed for several bugs that were not shlext's fault,
+ for example the file xfer cancel bug was in ICQ and Miranda but not shlext ;)
+
+
+ ---Credits
+
+ Tig-crash\d - Thanks for beta testing every version before this one ;)
+ Erik?, DD Of Borg - Thanks for beta testing 0.0.2.2/1.0.6.6 -- ideas and suggestions
+ as well what to exactly steal from ShellFileSend, heh..
\ No newline at end of file diff --git a/plugins/!NotAdopted/ShlExt/make.bat b/plugins/!NotAdopted/ShlExt/make.bat new file mode 100644 index 0000000000..40131550cf --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/make.bat @@ -0,0 +1,9 @@ +@echo off
+REM -Fi/u are for include/unit dirs
+REM -Mdelphi is delphi mode
+REM -WG - graphical app
+REM -v0 turn off warnings
+REM -O2 -Os // optimise
+REM -Rintel (intel style asm)
+REM -WB (relocatable) -WR (relocate)
+fpc shlext.dpr -Fiinc -Fuinc -Mdelphi -WG -O2 -Os -Rintel -WR -WB49ac0000 -v0
\ No newline at end of file diff --git a/plugins/!NotAdopted/ShlExt/resource.h b/plugins/!NotAdopted/ShlExt/resource.h new file mode 100644 index 0000000000..c89660a88d --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/resource.h @@ -0,0 +1,13 @@ +#define IDD_SHLOPTS 101 +#define IDC_USEGROUPS 1014 +#define IDC_CLISTGROUPS 1015 +#define IDC_SHOWFULL 1016 +#define IDC_NOPROF 1020 +#define IDC_SHOWINVISIBLES 1021 +#define IDC_HIDEOFFLINE 1022 +#define IDC_STATUS 1023 +#define IDC_CAPMENUS 1025 +#define IDC_CAPSTATUS 1026 +#define IDC_CAPSHLSTATUS 1027 +#define IDC_REMOVE 1028 +#define IDC_USEOWNERDRAW 1029 diff --git a/plugins/!NotAdopted/ShlExt/shlc.inc b/plugins/!NotAdopted/ShlExt/shlc.inc new file mode 100644 index 0000000000..2952de8c74 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shlc.inc @@ -0,0 +1,144 @@ +{$IFDEF SHL_IDC} +
+const
+ IDD_SHLOPTS = 101;
+ IDC_USEGROUPS = 1014;
+ IDC_CLISTGROUPS = 1015;
+ // Show "HIT"
+ IDC_SHOWFULL = 1016;
+ IDC_NOPROF = 1020;
+ IDC_SHOWINVISIBLES = 1021;
+ IDC_HIDEOFFLINE = 1022;
+ // only in the options dialog
+ IDC_STATUS = 1023;
+ IDC_CAPMENUS = 1025;
+ IDC_CAPSTATUS = 1026;
+ IDC_CAPSHLSTATUS = 1027;
+ IDC_REMOVE = 1028;
+ IDC_USEOWNERDRAW = 1029;
+{$ENDIF}
+{$IFDEF SHL_KEYS}
+
+const
+ SHLExt_Name: PChar = 'shlext15';
+ SHLExt_MRU: PChar = 'MRU';
+ SHLExt_UseGroups: PChar = 'UseGroups';
+ SHLExt_UseCListSetting: PChar = 'UseCLGroups';
+ SHLExt_UseHITContacts: PChar = 'UseHITContacts';
+ // HIT2 contacts will get your messages but don't know your state
+ SHLExt_UseHIT2Contacts: PChar = 'UseHIT2Contacts';
+ SHLExt_ShowNoProfile: PChar = 'ShowNoProfile';
+ SHLExt_ShowNoIcons: PChar = 'ShowNoIcons';
+ SHLExt_ShowNoOffline: PChar = 'ShowNoOffline';
+{$ENDIF}
+{$IFDEF SHLCOM}
+
+const
+
+ S_OK = 0;
+ S_FALSE = 1;
+
+ E_UNEXPECTED = $8000FFFF;
+ E_NOTIMPL = $80004001;
+ E_INVALIDARG = $80070057;
+
+ CLASS_E_NOAGGREGATION = $80040110;
+ CLASS_E_CLASSNOTAVAILABLE = $80040111;
+
+ CLSCTX_INPROC_SERVER = $1;
+
+ { for FORMATETC }
+
+ TYMED_HGLOBAL = 1;
+ DVASPECT_CONTENT = 1;
+
+type
+
+ PGUID = ^TGUID;
+
+ TGUID = record
+ D1: Longword;
+ D2: Word;
+ D3: Word;
+ D4: array [0 .. 7] of Byte;
+ end;
+
+ TIID = TGUID;
+ TCLSID = TGUID;
+
+ TStgMedium = record
+ tymed: Longint;
+ case Integer of
+ 0: (hBitmap: hBitmap; unkForRelease: Pointer { IUnknown } );
+ 1: (hMetaFilePict: THandle);
+ 2: (hEnhMetaFile: THandle);
+ 3: (hGlobal: hGlobal);
+ 4: (lpszFileName: Pointer { POleStr } );
+ 5: (stm: Pointer { IUnknown } );
+ 6: (stg: Pointer { IStorage } );
+ end;
+
+ PFormatEtc = ^TFormatEtc;
+
+ TFormatEtc = record
+ cfFormat: Word; { TClipFormat; }
+ ptd: Pointer; { PDVTargetDevice; }
+ dwAspect: Longint;
+ lindex: Longint;
+ tymed: Longint;
+ end;
+
+{$ENDIF}
+{$IFDEF COM_STRUCTS}
+
+const
+
+ IID_IUnknown: TGUID = (D1: $00000000; D2: $0000; D3: $0000;
+ D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
+
+ IID_IClassFactory: TGUID = (D1: $00000001; D2: $0000; D3: $0000;
+ D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
+
+ IID_IShellExtInit: TGUID = (D1: $000214E8; D2: $0000; D3: $0000;
+ D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
+
+ IID_IContextMenu: TGUID = (D1: $000214E4; D2: $0000; D3: $0000;
+ D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
+
+ IID_IContextMenu2: TGUID = (D1: $000214F4; D2: $0000; D3: $0000;
+ D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
+
+ IID_IContextMenu3: TGUID = (D1: $BCFCE0A0; D2: $EC17; D3: $11D0;
+ D4: ($8D, $10, $00, $A0, $C9, $0F, $27, $19));
+
+ IID_WICImagingFactory: TGUID = (D1: $EC5EC8A9; D2: $C395; D3: $4314;
+ D4: ($9C, $77, $54, $D7, $A9, $35, $FF, $70));
+
+
+ // Vista+ only
+
+ CLSID_WICImagingFactory: TGUID = (D1: $CACAF262; D2: $9370; D3: $4615;
+ D4: ($A1, $3B, $9F, $55, $39, $DA, $4C, $0A));
+
+ // anything before 0.0.1.5 was : {A321A032-7976-11d6-A310-ED893982BF28}
+ // changed to a new GUID to avoid older plugins
+ // {72013A26-A94C-11d6-8540-A5E62932711D}
+ // the IPC header now checks the plugin version given anyway.
+
+ CLSID_ISHLCOM: TGUID = (D1: $72013A26; D2: $A94C; D3: $11D6;
+ D4: ($85, $40, $A5, $E6, $29, $32, $71, $1D););
+{$ENDIF}
+{$IFDEF COMAPI}
+function CoCreateInstance(const rclsid: TCLSID; pUnkOuter: Pointer; dwClsContext: DWORD;
+ const riid: TIID; var ppv): HResult; stdcall; external 'ole32.dll' name 'CoCreateInstance';
+procedure ReleaseStgMedium(var medium: TStgMedium); stdcall;
+ external 'ole32.dll' name 'ReleaseStgMedium';
+function IsEqualGUID(const guid1, guid2: TGUID): Boolean; stdcall;
+ external 'ole32.dll' name 'IsEqualGUID';
+function IsEqualIID(const iid1, iid2: TIID): Boolean; stdcall;
+ external 'ole32.dll' name 'IsEqualGUID';
+function IsEqualCLSID(const clsid1, clsid2: TCLSID): Boolean; stdcall;
+ external 'ole32.dll' name 'IsEqualGUID';
+function QueueUserAPC(pfnAPC: Pointer; hThread: THandle; dwData: DWORD): BOOL; stdcall;
+ external 'kernel32' name 'QueueUserAPC';
+{$ENDIF} diff --git a/plugins/!NotAdopted/ShlExt/shlcom.pas b/plugins/!NotAdopted/ShlExt/shlcom.pas new file mode 100644 index 0000000000..d3377d9cda --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shlcom.pas @@ -0,0 +1,2502 @@ +unit shlcom; +
+{$IFDEF FPC}
+{$PACKRECORDS 4}
+{$MODE Delphi}
+{$ENDIF}
+
+interface
+
+uses
+
+ Windows, m_api, shlipc, shlicons;
+
+{$DEFINE COM_STRUCTS}
+{$DEFINE SHLCOM}
+{$INCLUDE shlc.inc}
+{$UNDEF SHLCOM}
+{$UNDEF COM_STRUCTS}
+function DllGetClassObject(const CLSID: TCLSID; const IID: TIID; var Obj): HResult; stdcall;
+function DllCanUnloadNow: HResult; stdcall;
+
+procedure InvokeThreadServer;
+
+procedure CheckRegisterServer;
+
+procedure CheckUnregisterServer;
+
+function RemoveCOMRegistryEntries: HResult;
+
+function ExtractIcon(hInst: THandle; pszExe: PChar; nIndex: Integer): HICON; stdcall;
+ external 'shell32.dll' name 'ExtractIconA';
+
+implementation
+
+var
+ dllpublic: record
+ FactoryCount: Integer;
+ ObjectCount: Integer;
+ end;
+
+ VistaOrLater:Boolean;
+
+{$DEFINE COMAPI}
+{$INCLUDE shlc.inc}
+{$UNDEF COMAPI}
+
+const
+
+ IPC_PACKET_SIZE = $1000 * 32;
+ // IPC_PACKET_NAME = 'm.mi.miranda.ipc'; // prior to 1.0.6.6
+ // IPC_PACKET_NAME = 'mi.miranda.IPCServer'; // prior to 2.0.0.9
+ IPC_PACKET_NAME = 'm.mi.miranda.ipc.server';
+
+const
+
+ { Flags returned by IContextMenu*:QueryContextMenu() }
+
+ CMF_NORMAL = $00000000;
+ CMF_DEFAULTONLY = $00000001;
+ CMF_VERBSONLY = $00000002;
+ CMF_EXPLORE = $00000004;
+ CMF_NOVERBS = $00000008;
+ CMF_CANRENAME = $00000010;
+ CMF_NODEFAULT = $00000020;
+ CMF_INCLUDESTATIC = $00000040;
+ CMF_RESERVED = $FFFF0000; { view specific }
+
+ { IContextMenu*:GetCommandString() uType flags }
+
+ GCS_VERBA = $00000000; // canonical verb
+ GCS_HELPTEXTA = $00000001; // help text (for status bar)
+ GCS_VALIDATEA = $00000002; // validate command exists
+ GCS_VERBW = $00000004; // canonical verb (unicode)
+ GC_HELPTEXTW = $00000005; // help text (unicode version)
+ GCS_VALIDATEW = $00000006; // validate command exists (unicode)
+ GCS_UNICODE = $00000004; // for bit testing - Unicode string
+ GCS_VERB = GCS_VERBA; //
+ GCS_HELPTEXT = GCS_HELPTEXTA;
+ GCS_VALIDATE = GCS_VALIDATEA;
+
+type
+
+ { this structure is returned by InvokeCommand() }
+
+ PCMInvokeCommandInfo = ^TCMInvokeCommandInfo;
+
+ TCMInvokeCommandInfo = packed record
+ cbSize: DWORD;
+ fMask: DWORD;
+ hwnd: hwnd;
+ lpVerb: PChar; { maybe index, type cast as Integer }
+ lpParams: PChar;
+ lpDir: PChar;
+ nShow: Integer;
+ dwHotkey: DWORD;
+ HICON: THandle;
+ end;
+
+ { completely stolen from modules.c: 'NameHashFunction' modified slightly }
+
+function StrHash(const szStr: PChar): DWORD;// cdecl;
+begin
+ result:=mir_hash(szStr,strlen(szStr));
+{
+asm
+ // esi content has to be preserved with basm
+ push esi
+ xor edx,edx
+ xor eax,eax
+ mov esi,szStr
+ mov al,[esi]
+ xor cl,cl
+@@lph_top: // only 4 of 9 instructions in here don't use AL, so optimal pipe use is impossible
+ xor edx,eax
+ inc esi
+ xor eax,eax
+ and cl,31
+ mov al,[esi]
+ add cl,5
+ test al,al
+ rol eax,cl // rol is u-pipe only, but pairable
+ // rol doesn't touch z-flag
+ jnz @@lph_top // 5 clock tick loop. not bad.
+ xor eax,edx
+ pop esi
+}
+end;
+
+function CreateProcessUID(const pid: Cardinal): string;
+var
+ pidrep: string[16];
+begin
+ str(pid, pidrep);
+ Result := Concat('mim.shlext.', pidrep, '$');
+end;
+
+function CreateUID: string;
+var
+ pidrep, tidrep: string[16];
+begin
+ str(GetCurrentProcessId(), pidrep);
+ str(GetCurrentThreadId(), tidrep);
+ Result := Concat('mim.shlext.caller', pidrep, '$', tidrep);
+end;
+
+// FPC doesn't support array[0..n] of Char extended syntax with Str()
+
+function wsprintf(lpOut, lpFmt: PChar; ArgInt: Integer): Integer; cdecl;
+ external 'user32.dll' name 'wsprintfA';
+
+procedure str(i: Integer; S: PChar);
+begin
+ i := wsprintf(S, '%d', i);
+ if i > 2 then
+ PChar(S)[i] := #0;
+end;
+
+{ IShlCom }
+
+type
+
+ PLResult = ^LResult;
+
+ // bare minimum interface of IDataObject, since GetData() is only required.
+
+ PVTable_IDataObject = ^TVTable_IDataObject;
+
+ TVTable_IDataObject = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: function(Self: Pointer): Cardinal; stdcall;
+ Release: function(Self: Pointer): Cardinal; stdcall;
+ { IDataObject }
+ GetData: function(Self:Pointer; var formatetcIn:TFormatEtc; var medium:TStgMedium): HResult; stdcall;
+ GetDataHere: Pointer;
+ QueryGetData: Pointer;
+ GetCanonicalFormatEtc: Pointer;
+ SetData: Pointer;
+ EnumFormatEtc: Pointer;
+ DAdvise: Pointer;
+ DUnadvise: Pointer;
+ EnumDAdvise: Pointer;
+ end;
+
+ PDataObject_Interface = ^TDataObject_Interface;
+
+ TDataObject_Interface = record
+ ptrVTable: PVTable_IDataObject;
+ end;
+
+ { TShlComRec inherits from different interfaces with different function tables
+ all "compiler magic" is lost in this case, but it's pretty easy to return
+ a different function table for each interface, IContextMenu is returned
+ as IContextMenu'3' since it inherits from '2' and '1' }
+
+ PVTable_IShellExtInit = ^TVTable_IShellExtInit;
+
+ TVTable_IShellExtInit = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: Pointer;
+ Release: Pointer;
+ { IShellExtInit }
+ Initialise: Pointer;
+ end;
+
+ PShlComRec = ^TShlComRec;
+ PShellExtInit_Interface = ^TShellExtInit_Interface;
+
+ TShellExtInit_Interface = record
+ { pointer to function table }
+ ptrVTable: PVTable_IShellExtInit;
+ { instance data }
+ ptrInstance: PShlComRec;
+ { function table itself }
+ vTable: TVTable_IShellExtInit;
+ end;
+
+ PVTable_IContextMenu3 = ^TVTable_IContextMenu3;
+
+ TVTable_IContextMenu3 = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: Pointer;
+ Release: Pointer;
+ { IContextMenu }
+ QueryContextMenu: Pointer;
+ InvokeCommand: Pointer;
+ GetCommandString: Pointer;
+ { IContextMenu2 }
+ HandleMenuMsg: Pointer;
+ { IContextMenu3 }
+ HandleMenuMsg2: Pointer;
+ end;
+
+ PContextMenu3_Interface = ^TContextMenu3_Interface;
+
+ TContextMenu3_Interface = record
+ ptrVTable: PVTable_IContextMenu3;
+ ptrInstance: PShlComRec;
+ vTable: TVTable_IContextMenu3;
+ end;
+
+ PCommon_Interface = ^TCommon_Interface;
+
+ TCommon_Interface = record
+ ptrVTable: Pointer;
+ ptrInstance: PShlComRec;
+ end;
+
+ TShlComRec = record
+ ShellExtInit_Interface: TShellExtInit_Interface;
+ ContextMenu3_Interface: TContextMenu3_Interface;
+ { fields }
+ RefCount: LongInt;
+ // this is owned by the shell after items are added 'n' is used to
+ // grab menu information directly via id rather than array indexin'
+ hRootMenu: THandle;
+ idCmdFirst: Integer;
+ // most of the memory allocated is on this heap object so HeapDestroy()
+ // can do most of the cleanup, extremely lazy I know.
+ hDllHeap: THandle;
+ // This is a submenu that recently used contacts are inserted into
+ // the contact is inserted twice, once in its normal list (or group) and here
+ // Note: These variables are global data, but refered to locally by each instance
+ // Do not rely on these variables outside the process enumeration.
+ hRecentMenu: THandle;
+ RecentCount: Cardinal; // number of added items
+ // array of all the protocol icons, for every running instance!
+ ProtoIcons: ^TSlotProtoIconsArray;
+ ProtoIconsCount: Cardinal;
+ // maybe null, taken from IShellExtInit_Initalise() and AddRef()'d
+ // only used if a Miranda instance is actually running and a user
+ // is selected
+ pDataObject: PDataObject_Interface;
+ // DC is used for font metrics and saves on creating and destroying lots of DC handles
+ // during WM_MEASUREITEM
+ hMemDC: HDC;
+ end;
+
+ { this is passed to the enumeration callback so it can process PID's with
+ main windows by the class name MIRANDANAME loaded with the plugin
+ and use the IPC stuff between enumerations -- }
+
+ PEnumData = ^TEnumData;
+
+ TEnumData = record
+ Self: PShlComRec;
+ // autodetected, don't hard code since shells that don't support it
+ // won't send WM_MEASUREITETM/WM_DRAWITEM at all.
+ bOwnerDrawSupported: LongBool;
+ // as per user setting (maybe of multiple Mirandas)
+ bShouldOwnerDraw: LongBool;
+ idCmdFirst: Integer;
+ ipch: PHeaderIPC;
+ // OpenEvent()'d handle to give each IPC server an object to set signalled
+ hWaitFor: THandle;
+ pid: DWORD; // sub-unique value used to make work object name
+ end;
+
+procedure FreeGroupTreeAndEmptyGroups(hParentMenu: THandle; pp, p: PGroupNode);
+var
+ q: PGroupNode;
+begin
+ while p <> nil do
+ begin
+ q := p^.Right;
+ if p^.Left <> nil then
+ begin
+ FreeGroupTreeAndEmptyGroups(p^.Left^.hMenu, p, p^.Left);
+ end; // if
+ if p^.dwItems = 0 then
+ begin
+ if pp <> nil then
+ begin
+ DeleteMenu(pp^.hMenu, p^.hMenuGroupID, MF_BYCOMMAND)
+ end
+ else
+ begin
+ DeleteMenu(hParentMenu, p^.hMenuGroupID, MF_BYCOMMAND);
+ end; // if
+ end
+ else
+ begin
+ // make sure this node's parent know's it exists
+ if pp <> nil then
+ inc(pp^.dwItems);
+ end;
+ Dispose(p);
+ p := q;
+ end;
+end;
+
+procedure DecideMenuItemInfo(pct: PSlotIPC; pg: PGroupNode; var mii: TMenuItemInfo; lParam: PEnumData);
+var
+ psd: PMenuDrawInfo;
+ hDllHeap: THandle;
+ c: Cardinal;
+ pp: ^TSlotProtoIconsArray;
+begin
+ mii.wID := lParam^.idCmdFirst;
+ inc(lParam^.idCmdFirst);
+ // get the heap object
+ hDllHeap := lParam^.Self^.hDllHeap;
+ psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
+ if pct <> nil then
+ begin
+ psd^.cch := pct^.cbStrSection - 1; // no null;
+ psd^.szText := HeapAlloc(hDllHeap, 0, pct^.cbStrSection);
+ lstrcpya(psd^.szText, PChar(uint_ptr(pct) + sizeof(TSlotIPC)));
+ psd^.hContact := pct^.hContact;
+ psd^.fTypes := [dtContact];
+ // find the protocol icon array to use and which status
+ c := lParam^.Self^.ProtoIconsCount;
+ pp := lParam^.Self^.ProtoIcons;
+ psd^.hStatusIcon := 0;
+ while c > 0 do
+ begin
+ dec(c);
+ if (pp[c].hProto = pct^.hProto) and (pp[c].pid = lParam^.pid) then
+ begin
+ psd^.hStatusIcon := pp[c].hIcons[pct^.Status - ID_STATUS_OFFLINE];
+ psd^.hStatusBitmap := pp[c].hBitmaps[pct^.Status - ID_STATUS_OFFLINE];
+ break;
+ end;
+ end; // while
+ psd^.pid := lParam^.pid;
+ end
+ else if pg <> nil then
+ begin
+ // store the given ID
+ pg^.hMenuGroupID := mii.wID;
+ // steal the pointer from the group node it should be on the heap
+ psd^.cch := pg^.cchGroup;
+ psd^.szText := pg^.szGroup;
+ psd^.fTypes := [dtGroup];
+ end; // if
+ psd^.wID := mii.wID;
+ psd^.szProfile := nil;
+ // store
+ mii.dwItemData := uint_ptr(psd);
+
+ if ((lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw)) then
+ begin
+ mii.fType := MFT_OWNERDRAW;
+ Pointer(mii.dwTypeData) := psd;
+ end
+ else
+ begin
+ // normal menu
+ mii.fType := MFT_STRING;
+ if pct <> nil then
+ begin
+ uint_ptr(mii.dwTypeData) := uint_ptr(pct) + sizeof(TSlotIPC);
+ end
+ else
+ begin
+ mii.dwTypeData := pg^.szGroup;
+ end;
+ { For Vista + let the system draw the theme and icons, pct = contact associated data }
+ if VistaOrLater and (pct <> nil) and (psd <> nil) then
+ begin
+ mii.fMask := MIIM_BITMAP or MIIM_FTYPE or MIIM_ID or MIIM_DATA or MIIM_STRING;
+ // BuildSkinIcons() built an array of bitmaps which we can use here
+ mii.hBmpItem := psd^.hStatusBitmap;
+ end;
+ end; // if
+end;
+
+// must be called after DecideMenuItemInfo()
+procedure BuildMRU(pct: PSlotIPC; var mii: TMenuItemInfo; lParam: PEnumData);
+begin
+ if pct^.MRU > 0 then
+ begin
+ inc(lParam^.Self^.RecentCount);
+ // lParam^.Self == pointer to object data
+ InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);
+ end;
+end;
+
+procedure BuildContactTree(group: PGroupNode; lParam: PEnumData);
+label
+ grouploop;
+var
+ pct: PSlotIPC;
+ pg, px: PGroupNode;
+ str: TStrTokRec;
+ sz: PChar;
+ Hash: Cardinal;
+ Depth: Cardinal;
+ mii: TMenuItemInfo;
+begin
+ // set up the menu item
+ mii.cbSize := sizeof(TMenuItemInfo);
+ mii.fMask := MIIM_ID or MIIM_TYPE or MIIM_DATA;
+ // set up the scanner
+ str.szSet := ['\'];
+ str.bSetTerminator := False;
+ // go thru all the contacts
+ pct := lParam^.ipch^.ContactsBegin;
+ while (pct <> nil) and (pct^.cbSize = sizeof(TSlotIPC)) and (pct^.fType = REQUEST_CONTACTS) do
+ begin
+ if pct^.hGroup <> 0 then
+ begin
+ // at the end of the slot header is the contact's display name
+ // and after a double NULL char there is the group string, which has the full path of the group
+ // this must be tokenised at '\' and we must walk the in memory group tree til we find our group
+ // this is faster than the old version since we only ever walk one or at most two levels of the tree
+ // per tokenised section, and it doesn't matter if two levels use the same group name (which is valid)
+ // as the tokens processed is equatable to depth of the tree
+ str.szStr := PChar(uint_ptr(pct) + sizeof(TSlotIPC) + uint_ptr(pct^.cbStrSection) + 1);
+ sz := StrTok(str);
+ // restore the root
+ pg := group;
+ Depth := 0;
+ while sz <> nil do
+ begin
+ Hash := StrHash(sz);
+ // find this node within
+ while pg <> nil do
+ begin
+ // does this node have the right hash and the right depth?
+ if (Hash = pg^.Hash) and (Depth = pg^.Depth) then
+ break;
+ // each node may have a left pointer going to a sub tree
+ // the path syntax doesn't know if a group is a group at the same level
+ // or a nested one, which means the search node can be anywhere
+ px := pg^.Left;
+ if px <> nil then
+ begin
+ // keep searching this level
+ while px <> nil do
+ begin
+ if (Hash = px^.Hash) and (Depth = px^.Depth) then
+ begin
+ // found the node we're looking for at the next level to pg, px is now pq for next time
+ pg := px;
+ goto grouploop;
+ end; // if
+ px := px^.Right;
+ end; // if
+ end; // if
+ pg := pg^.Right;
+ end; // while
+ grouploop:
+ inc(Depth);
+ // process next token
+ sz := StrTok(str);
+ end; // while
+ // tokenisation finished, if pg <> nil then the group is found
+ if pg <> nil then
+ begin
+ DecideMenuItemInfo(pct, nil, mii, lParam);
+ BuildMRU(pct, mii, lParam);
+ InsertMenuitem(pg^.hMenu, $FFFFFFFF, True, mii);
+ inc(pg^.dwItems);
+ end;
+ end; // if
+ pct := pct^.Next;
+ end; // while
+end;
+
+procedure BuildMenuGroupTree(p: PGroupNode; lParam: PEnumData; hLastMenu: hMenu);
+var
+ mii: TMenuItemInfo;
+begin
+ mii.cbSize := sizeof(TMenuItemInfo);
+ mii.fMask := MIIM_ID or MIIM_DATA or MIIM_TYPE or MIIM_SUBMENU;
+ // go thru each group and create a menu for it adding submenus too.
+ while p <> nil do
+ begin
+ mii.hSubMenu := CreatePopupMenu();
+ if p^.Left <> nil then
+ BuildMenuGroupTree(p^.Left, lParam, mii.hSubMenu);
+ p^.hMenu := mii.hSubMenu;
+ DecideMenuItemInfo(nil, p, mii, lParam);
+ InsertMenuitem(hLastMenu, $FFFFFFFF, True, mii);
+ p := p^.Right;
+ end; // while
+end;
+
+{ this callback is triggered by the menu code and IPC is already taking place,
+ just the transfer type+data needs to be setup }
+function ClearMRUIPC(pipch: PHeaderIPC; // IPC header info, already mapped
+ hWorkThreadEvent: THandle; // event object being waited on on miranda thread
+ hAckEvent: THandle; // ack event object that has been created
+ psd: PMenuDrawInfo // command/draw info
+ ): Integer; stdcall;
+begin
+ Result := S_OK;
+ ipcPrepareRequests(IPC_PACKET_SIZE, pipch, REQUEST_CLEARMRU);
+ ipcSendRequest(hWorkThreadEvent, hAckEvent, pipch, 100);
+end;
+
+procedure RemoveCheckmarkSpace(hMenu: hMenu);
+const
+ MIM_STYLE = $00000010;
+ MNS_CHECKORBMP = $4000000;
+type
+ TMENUINFO = record
+ cbSize: DWORD;
+ fMask: DWORD;
+ dwStyle: DWORD;
+ cyMax: LongInt;
+ hbrBack: THandle;
+ dwContextHelpID: DWORD;
+ dwMenuData: Pointer;
+ end;
+var
+ SetMenuInfo: function(hMenu: hMenu; var mi: TMENUINFO): Boolean; stdcall;
+ mi: TMENUINFO;
+begin
+ if not VistaOrLater then
+ Exit;
+ SetMenuInfo := GetProcAddress(GetModuleHandle('user32'), 'SetMenuInfo');
+ if @SetMenuInfo = nil then
+ Exit;
+ mi.cbSize := sizeof(mi);
+ mi.fMask := MIM_STYLE;
+ mi.dwStyle := MNS_CHECKORBMP;
+ SetMenuInfo(hMenu, mi);
+end;
+
+procedure BuildMenus(lParam: PEnumData);
+{$DEFINE SHL_IDC}
+{$DEFINE SHL_KEYS}
+{$INCLUDE shlc.inc}
+{$UNDEF SHL_KEYS}
+{$UNDEF SHL_IDC}
+var
+ hBaseMenu: hMenu;
+ hGroupMenu: hMenu;
+ pg: PSlotIPC;
+ mii: TMenuItemInfo;
+ j: TGroupNodeList;
+ p, q: PGroupNode;
+ Depth, Hash: Cardinal;
+ Token: PChar;
+ tk: TStrTokRec;
+ hDllHeap: THandle;
+ psd: PMenuDrawInfo;
+ c: Cardinal;
+ pp: ^TSlotProtoIconsArray;
+begin
+ ZeroMemory(@mii, sizeof(mii));
+ hDllHeap := lParam^.Self^.hDllHeap;
+ hBaseMenu := lParam^.Self^.hRootMenu;
+ // build an in memory tree of the groups
+ pg := lParam^.ipch^.GroupsBegin;
+ tk.szSet := ['\'];
+ tk.bSetTerminator := False;
+ j.First := nil;
+ j.Last := nil;
+ while pg <> nil do
+ begin
+ if (pg^.cbSize <> sizeof(TSlotIPC)) or (pg^.fType <> REQUEST_GROUPS) then
+ break;
+ Depth := 0;
+ p := j.First; // start at root again
+ // get the group
+ uint_ptr(tk.szStr) := (uint_ptr(pg) + sizeof(TSlotIPC));
+ // find each word between \ and create sub groups if needed.
+ Token := StrTok(tk);
+ while Token <> nil do
+ begin
+ Hash := StrHash(Token);
+ // if the (sub)group doesn't exist, create it.
+ q := FindGroupNode(p, Hash, Depth);
+ if q = nil then
+ begin
+ q := AllocGroupNode(@j, p, Depth);
+ q^.Depth := Depth;
+ // this is the hash of this group node, but it can be anywhere
+ // i.e. Foo\Foo this is because each node has a different depth
+ // trouble is contacts don't come with depths!
+ q^.Hash := Hash;
+ // don't assume that pg^.hGroup's hash is valid for this token
+ // since it maybe Miranda\Blah\Blah and we have created the first node
+ // which maybe Miranda, thus giving the wrong hash
+ // since "Miranda" can be a group of it's own and a full path
+ q^.cchGroup := lstrlena(Token);
+ q^.szGroup := HeapAlloc(hDllHeap, 0, q^.cchGroup + 1);
+ lstrcpya(q^.szGroup, Token);
+ q^.dwItems := 0;
+ end;
+ p := q;
+ inc(Depth);
+ Token := StrTok(tk);
+ end; // while
+ pg := pg^.Next;
+ end; // while
+ // build the menus inserting into hGroupMenu which will be a submenu of
+ // the instance menu item. e.g. Miranda -> [Groups ->] contacts
+ hGroupMenu := CreatePopupMenu();
+
+ // allocate MRU menu, this will be associated with the higher up menu
+ // so doesn't need to be freed (unless theres no MRUs items attached)
+ // This menu is per process but the handle is stored globally (like a stack)
+ lParam^.Self^.hRecentMenu := CreatePopupMenu();
+ lParam^.Self^.RecentCount := 0;
+ // create group menus only if they exist!
+ if lParam^.ipch^.GroupsBegin <> nil then
+ begin
+ BuildMenuGroupTree(j.First, lParam, hGroupMenu);
+ // add contacts that have a group somewhere
+ BuildContactTree(j.First, lParam);
+ end;
+ //
+ mii.cbSize := sizeof(TMenuItemInfo);
+ mii.fMask := MIIM_ID or MIIM_TYPE or MIIM_DATA;
+ // add all the contacts that have no group (which maybe all of them)
+ pg := lParam^.ipch^.ContactsBegin;
+ while pg <> nil do
+ begin
+ if (pg^.cbSize <> sizeof(TSlotIPC)) or (pg^.fType <> REQUEST_CONTACTS) then
+ break;
+ if pg^.hGroup = 0 then
+ begin
+ DecideMenuItemInfo(pg, nil, mii, lParam);
+ BuildMRU(pg, mii, lParam);
+ InsertMenuitem(hGroupMenu, $FFFFFFFF, True, mii);
+ end; // if
+ pg := pg^.Next;
+ end; // while
+
+ // insert MRU menu as a submenu of the contact menu only if
+ // the MRU list has been created, the menu popup will be deleted by itself
+ if lParam^.Self^.RecentCount > 0 then
+ begin
+
+ // insert seperator and 'clear list' menu
+ mii.fType := MFT_SEPARATOR;
+ mii.fMask := MIIM_TYPE;
+ InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);
+
+ // insert 'clear MRU' item and setup callback
+ mii.fMask := MIIM_TYPE or MIIM_ID or MIIM_DATA;
+ mii.wID := lParam^.idCmdFirst;
+ inc(lParam^.idCmdFirst);
+ mii.fType := MFT_STRING;
+ mii.dwTypeData := lParam^.ipch^.ClearEntries; // "Clear entries"
+ // allocate menu substructure
+ psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
+ psd^.fTypes := [dtCommand];
+ psd^.MenuCommandCallback := @ClearMRUIPC;
+ psd^.wID := mii.wID;
+ // this is needed because there is a clear list command per each process.
+ psd^.pid := lParam^.pid;
+ Pointer(mii.dwItemData) := psd;
+ InsertMenuitem(lParam^.Self^.hRecentMenu, $FFFFFFFF, True, mii);
+
+ // insert MRU submenu into group menu (with) ownerdraw support as needed
+ psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
+ psd^.szProfile := 'MRU';
+ psd^.fTypes := [dtGroup];
+ // the IPC string pointer wont be around forever, must make a copy
+ psd^.cch := strlen(lParam^.ipch^.MRUMenuName);
+ psd^.szText := HeapAlloc(hDllHeap, 0, psd^.cch + 1);
+ lstrcpyn(psd^.szText, lParam^.ipch^.MRUMenuName, sizeof(lParam^.ipch^.MRUMenuName) - 1);
+
+ pointer(mii.dwItemData) := psd;
+ if (lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw) then
+ begin
+ mii.fType := MFT_OWNERDRAW;
+ Pointer(mii.dwTypeData) := psd;
+ end
+ else
+ begin
+ mii.dwTypeData := lParam^.ipch^.MRUMenuName; // 'Recent';
+ end;
+ mii.wID := lParam^.idCmdFirst;
+ inc(lParam^.idCmdFirst);
+ mii.fMask := MIIM_TYPE or MIIM_SUBMENU or MIIM_DATA or MIIM_ID;
+ mii.hSubMenu := lParam^.Self^.hRecentMenu;
+ InsertMenuitem(hGroupMenu, 0, True, mii);
+ end
+ else
+ begin
+ // no items were attached to the MRU, delete the MRU menu
+ DestroyMenu(lParam^.Self^.hRecentMenu);
+ lParam^.Self^.hRecentMenu := 0;
+ end;
+
+ // allocate display info/memory for "Miranda" string
+
+ mii.cbSize := sizeof(TMenuItemInfo);
+ mii.fMask := MIIM_ID or MIIM_DATA or MIIM_TYPE or MIIM_SUBMENU;
+ if VistaOrLater then
+ begin
+ mii.fMask := MIIM_ID or MIIM_DATA or MIIM_FTYPE or MIIM_SUBMENU or MIIM_STRING or
+ MIIM_BITMAP;
+ end;
+ mii.hSubMenu := hGroupMenu;
+
+ // by default, the menu will have space for icons and checkmarks (on Vista+) and we don't need this
+ RemoveCheckmarkSpace(hGroupMenu);
+
+ psd := HeapAlloc(hDllHeap, 0, sizeof(TMenuDrawInfo));
+ psd^.cch := strlen(lParam^.ipch^.MirandaName);
+ psd^.szText := HeapAlloc(hDllHeap, 0, psd^.cch + 1);
+ lstrcpyn(psd^.szText, lParam^.ipch^.MirandaName, sizeof(lParam^.ipch^.MirandaName) - 1);
+ // there may not be a profile name
+ pg := lParam^.ipch^.DataPtr;
+ psd^.szProfile := nil;
+ if ((pg <> nil) and (pg^.Status = STATUS_PROFILENAME)) then
+ begin
+ psd^.szProfile := HeapAlloc(hDllHeap, 0, pg^.cbStrSection);
+ lstrcpya(psd^.szProfile, PChar(uint_ptr(pg) + sizeof(TSlotIPC)));
+ end; // if
+ // owner draw menus need ID's
+ mii.wID := lParam^.idCmdFirst;
+ inc(lParam^.idCmdFirst);
+ psd^.fTypes := [dtEntry];
+ psd^.wID := mii.wID;
+ psd^.hContact := 0;
+ // get Miranda's icon or bitmap
+ c := lParam^.Self^.ProtoIconsCount;
+ pp := lParam^.Self^.ProtoIcons;
+ while c > 0 do
+ begin
+ dec(c);
+ if (pp[c].pid = lParam^.pid) and (pp[c].hProto = 0) then
+ begin
+ // either of these can be 0
+ psd^.hStatusIcon := pp[c].hIcons[0];
+ mii.hBmpItem := pp[c].hBitmaps[0];
+ break;
+ end; // if
+ end; // while
+ pointer(mii.dwItemData) := psd;
+ if ((lParam^.bOwnerDrawSupported) and (lParam^.bShouldOwnerDraw)) then
+ begin
+ mii.fType := MFT_OWNERDRAW;
+ Pointer(mii.dwTypeData) := psd;
+ end
+ else
+ begin
+ mii.fType := MFT_STRING;
+ mii.dwTypeData := lParam^.ipch^.MirandaName;
+ mii.cch := sizeof(lParam^.ipch^.MirandaName) - 1;
+ end;
+ // add it all
+ InsertMenuitem(hBaseMenu, 0, True, mii);
+ // free the group tree
+ FreeGroupTreeAndEmptyGroups(hGroupMenu, nil, j.First);
+end;
+
+procedure BuildSkinIcons(lParam: PEnumData);
+var
+ pct: PSlotIPC;
+ p, d: PSlotProtoIcons;
+ Self: PShlComRec;
+ j: Cardinal;
+ imageFactory: PImageFactory_Interface;
+begin
+ pct := lParam^.ipch^.NewIconsBegin;
+ Self := lParam^.Self;
+ while (pct <> nil) do
+ begin
+ if (pct^.cbSize <> sizeof(TSlotIPC)) or (pct^.fType <> REQUEST_NEWICONS) then
+ break;
+ uint_ptr(p) := uint_ptr(pct) + sizeof(TSlotIPC);
+ ReAllocMem(Self^.ProtoIcons, (Self^.ProtoIconsCount + 1) * sizeof(TSlotProtoIcons));
+ d := @Self^.ProtoIcons[Self^.ProtoIconsCount];
+ CopyMemory(d, p, sizeof(TSlotProtoIcons));
+
+ {
+ If using Vista (or later), clone all the icons into bitmaps and keep these around,
+ if using anything older, just use the default code, the bitmaps (and or icons) will be freed
+ with the shell object.
+ }
+
+ imageFactory := nil;
+
+ for j := 0 to 9 do
+ begin
+ if imageFactory = nil then
+ imageFactory := ARGB_GetWorker();
+ if VistaOrLater then
+ begin
+ d^.hBitmaps[j] := ARGB_BitmapFromIcon(imageFactory, Self^.hMemDC, p^.hIcons[j]);
+ d^.hIcons[j] := 0;
+ end
+ else
+ begin
+ d^.hBitmaps[j] := 0;
+ d^.hIcons[j] := CopyIcon(p^.hIcons[j]);
+ end;
+ end;
+
+ if imageFactory <> nil then
+ begin
+ imageFactory^.ptrVTable^.Release(imageFactory);
+ imageFactory := nil;
+ end;
+
+ inc(Self^.ProtoIconsCount);
+ pct := pct^.Next;
+ end;
+end;
+
+function ProcessRequest(hwnd: hwnd; lParam: PEnumData): BOOL; stdcall;
+var
+ pid: Integer;
+ hMirandaWorkEvent: THandle;
+ replyBits: Integer;
+ szBuf: array [0 .. MAX_PATH] of Char;
+begin
+ Result := True;
+ pid := 0;
+ GetWindowThreadProcessId(hwnd, @pid);
+ If pid <> 0 then
+ begin
+ // old system would get a window's pid and the module handle that created it
+ // and try to OpenEvent() a event object name to it (prefixed with a string)
+ // this was fine for most Oses (not the best way) but now actually compares
+ // the class string (a bit slower) but should get rid of those bugs finally.
+ hMirandaWorkEvent := OpenEvent(EVENT_ALL_ACCESS, False, PChar(CreateProcessUID(pid)));
+ if (hMirandaWorkEvent <> 0) then
+ begin
+ GetClassName(hwnd, szBuf, sizeof(szBuf));
+ if lstrcmp(szBuf, MirandaName) <> 0 then
+ begin
+ // opened but not valid.
+ CloseHandle(hMirandaWorkEvent);
+ Exit;
+ end; // if
+ end; // if
+ { If the event object exists, then a shlext.dll running in the instance must of created it. }
+ If hMirandaWorkEvent <> 0 then
+ begin
+ { prep the request }
+ ipcPrepareRequests(IPC_PACKET_SIZE, lParam^.ipch, REQUEST_ICONS or REQUEST_GROUPS or
+ REQUEST_CONTACTS or REQUEST_NEWICONS);
+ // slots will be in the order of icon data, groups then contacts, the first
+ // slot will contain the profile name
+ replyBits := ipcSendRequest(hMirandaWorkEvent, lParam^.hWaitFor, lParam^.ipch, 1000);
+ { replyBits will be REPLY_FAIL if the wait timed out, or it'll be the request
+ bits as sent or a series of *_NOTIMPL bits where the request bit were, if there are no
+ contacts to speak of, then don't bother showing this instance of Miranda }
+ if (replyBits <> REPLY_FAIL) and (lParam^.ipch^.ContactsBegin <> nil) then
+ begin
+ // load the address again, the server side will always overwrite it
+ lParam^.ipch^.pClientBaseAddress := lParam^.ipch;
+ // fixup all the pointers to be relative to the memory map
+ // the base pointer of the client side version of the mapped file
+ ipcFixupAddresses(False, lParam^.ipch);
+ // store the PID used to create the work event object
+ // that got replied to -- this is needed since each contact
+ // on the final menu maybe on a different instance and another OpenEvent() will be needed.
+ lParam^.pid := pid;
+ // check out the user options from the server
+ lParam^.bShouldOwnerDraw := (lParam^.ipch^.dwFlags and HIPC_NOICONS) = 0;
+ // process the icons
+ BuildSkinIcons(lParam);
+ // process other replies
+ BuildMenus(lParam);
+ end;
+ { close the work object }
+ CloseHandle(hMirandaWorkEvent);
+ end; // if
+ end; // if
+end;
+
+function TShlComRec_QueryInterface(Self: PCommon_Interface; const IID: TIID; var Obj): HResult; stdcall;
+begin
+ Pointer(Obj) := nil;
+ { IShellExtInit is given when the TShlRec is created }
+ if IsEqualIID(IID, IID_IContextMenu) or IsEqualIID(IID, IID_IContextMenu2) or
+ IsEqualIID(IID, IID_IContextMenu3) then
+ begin
+ with Self^.ptrInstance^ do
+ begin
+ Pointer(Obj) := @ContextMenu3_Interface;
+ inc(RefCount);
+ end; { with }
+ Result := S_OK;
+ end
+ else
+ begin
+ // under XP, it may ask for IShellExtInit again, this fixes the -double- click to see menus issue
+ // which was really just the object not being created
+ if IsEqualIID(IID, IID_IShellExtInit) then
+ begin
+ with Self^.ptrInstance^ do
+ begin
+ Pointer(Obj) := @ShellExtInit_Interface;
+ inc(RefCount);
+ end; // if
+ Result := S_OK;
+ end
+ else
+ begin
+ Result := CLASS_E_CLASSNOTAVAILABLE;
+ end; // if
+ end; // if
+end;
+
+function TShlComRec_AddRef(Self: PCommon_Interface): LongInt; stdcall;
+begin
+ with Self^.ptrInstance^ do
+ begin
+ inc(RefCount);
+ Result := RefCount;
+ end; { with }
+end;
+
+function TShlComRec_Release(Self: PCommon_Interface): LongInt; stdcall;
+var
+ j, c: Cardinal;
+begin
+ with Self^.ptrInstance^ do
+ begin
+ dec(RefCount);
+ Result := RefCount;
+ If RefCount = 0 then
+ begin
+ // time to go byebye.
+ with Self^.ptrInstance^ do
+ begin
+ // Note MRU menu is associated with a window (indirectly) so windows will free it.
+ // free icons!
+ if ProtoIcons <> nil then
+ begin
+ c := ProtoIconsCount;
+ while c > 0 do
+ begin
+ dec(c);
+ for j := 0 to 9 do
+ begin
+ with ProtoIcons[c] do
+ begin
+ if hIcons[j] <> 0 then
+ DestroyIcon(hIcons[j]);
+ if hBitmaps[j] <> 0 then
+ DeleteObject(hBitmaps[j]);
+ end;
+ end;
+ end;
+ FreeMem(ProtoIcons);
+ ProtoIcons := nil;
+ end; // if
+ // free IDataObject reference if pointer exists
+ if pDataObject <> nil then
+ begin
+ pDataObject^.ptrVTable^.Release(pDataObject);
+ end; // if
+ pDataObject := nil;
+ // free the heap and any memory allocated on it
+ HeapDestroy(hDllHeap);
+ // destroy the DC
+ if hMemDC <> 0 then
+ DeleteDC(hMemDC);
+ end; // with
+ // free the instance (class record) created
+ Dispose(Self^.ptrInstance);
+ dec(dllpublic.ObjectCount);
+ end; { if }
+ end; { with }
+end;
+
+function TShlComRec_Initialise(Self: PContextMenu3_Interface; pidLFolder: Pointer;
+ DObj: PDataObject_Interface; hKeyProdID: HKEY): HResult; stdcall;
+begin
+ // DObj is a pointer to an instance of IDataObject which is a pointer itself
+ // it contains a pointer to a function table containing the function pointer
+ // address of GetData() - the instance data has to be passed explicitly since
+ // all compiler magic has gone.
+ with Self^.ptrInstance^ do
+ begin
+ if DObj <> nil then
+ begin
+ Result := S_OK;
+ // if an instance already exists, free it.
+ if pDataObject <> nil then
+ pDataObject^.ptrVTable^.Release(pDataObject);
+ // store the new one and AddRef() it
+ pDataObject := DObj;
+ pDataObject^.ptrVTable^.AddRef(pDataObject);
+ end
+ else
+ begin
+ Result := E_INVALIDARG;
+ end; // if
+ end; // if
+end;
+
+function MAKE_HRESULT(Severity, Facility, Code: Integer): HResult;
+{$IFDEF FPC}
+inline;
+{$ENDIF}
+begin
+ Result := (Severity shl 31) or (Facility shl 16) or Code;
+end;
+
+function TShlComRec_QueryContextMenu(Self: PContextMenu3_Interface; Menu: hMenu;
+ indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
+type
+ TDllVersionInfo = record
+ cbSize: DWORD;
+ dwMajorVersion: DWORD;
+ dwMinorVersion: DWORD;
+ dwBuildNumber: DWORD;
+ dwPlatformID: DWORD;
+ end;
+
+ TDllGetVersionProc = function(var dv: TDllVersionInfo): HResult; stdcall;
+var
+ hShellInst: THandle;
+ bMF_OWNERDRAW: Boolean;
+ DllGetVersionProc: TDllGetVersionProc;
+ dvi: TDllVersionInfo;
+ ed: TEnumData;
+ hMap: THandle;
+ pipch: PHeaderIPC;
+begin
+ Result := 0;
+ if ((LOWORD(uFlags) and CMF_VERBSONLY) <> CMF_VERBSONLY) and
+ ((LOWORD(uFlags) and CMF_DEFAULTONLY) <> CMF_DEFAULTONLY) then
+ begin
+ bMF_OWNERDRAW := False;
+ // get the shell version
+ hShellInst := LoadLibrary('shell32.dll');
+ if hShellInst <> 0 then
+ begin
+ DllGetVersionProc := GetProcAddress(hShellInst, 'DllGetVersion');
+ if @DllGetVersionProc <> nil then
+ begin
+ dvi.cbSize := sizeof(TDllVersionInfo);
+ if DllGetVersionProc(dvi) >= 0 then
+ begin
+ // it's at least 4.00
+ bMF_OWNERDRAW := (dvi.dwMajorVersion > 4) or (dvi.dwMinorVersion >= 71);
+ end; // if
+ end; // if
+ FreeLibrary(hShellInst);
+ end; // if
+
+ // if we're using Vista (or later), then the ownerdraw code will be disabled, because the system draws the icons.
+ if VistaOrLater then
+ bMF_OWNERDRAW := False;
+
+ hMap := CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, IPC_PACKET_SIZE,
+ IPC_PACKET_NAME);
+ If (hMap <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS) then
+ begin
+ { map the memory to this address space }
+ pipch := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
+ If pipch <> nil then
+ begin
+ { let the callback have instance vars }
+ ed.Self := Self^.ptrInstance;
+ // not used 'ere
+ ed.Self^.hRootMenu := Menu;
+ // store the first ID to offset with index for InvokeCommand()
+ Self^.ptrInstance^.idCmdFirst := idCmdFirst;
+ // store the starting index to offset
+ Result := idCmdFirst;
+ ed.bOwnerDrawSupported := bMF_OWNERDRAW;
+ ed.bShouldOwnerDraw := True;
+ ed.idCmdFirst := idCmdFirst;
+ ed.ipch := pipch;
+ { allocate a wait object so the ST can signal us, it can't be anon
+ since it has to used by OpenEvent() }
+ lstrcpya(@pipch^.SignalEventName, PChar(CreateUID()));
+ { create the wait wait-for-wait object }
+ ed.hWaitFor := CreateEvent(nil, False, False, pipch^.SignalEventName);
+ If ed.hWaitFor <> 0 then
+ begin
+ { enumerate all the top level windows to find all loaded MIRANDANAME
+ classes -- }
+ EnumWindows(@ProcessRequest, lParam(@ed));
+ { close the wait-for-reply object }
+ CloseHandle(ed.hWaitFor);
+ end;
+ { unmap the memory from this address space }
+ UnmapViewOfFile(pipch);
+ end; { if }
+ { close the mapping }
+ CloseHandle(hMap);
+ // use the MSDN recommended way, thou there ain't much difference
+ Result := MAKE_HRESULT(0, 0, (ed.idCmdFirst - Result) + 1);
+ end
+ else
+ begin
+ // the mapping file already exists, which is not good!
+ end;
+ end
+ else
+ begin
+ // same as giving a SEVERITY_SUCCESS, FACILITY_NULL, since that
+ // just clears the higher bits, which is done anyway
+ Result := MAKE_HRESULT(0, 0, 1);
+ end; // if
+end;
+
+function TShlComRec_GetCommandString(Self: PContextMenu3_Interface; idCmd, uType: UINT;
+ pwReserved: PUINT; pszName: PChar; cchMax: UINT): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function ipcGetFiles(pipch: PHeaderIPC; pDataObject: PDataObject_Interface; const hContact: THandle): Integer;
+type
+ TDragQueryFile = function(hDrop: THandle; fileIndex: Integer; FileName: PChar;
+ cbSize: Integer): Integer; stdcall;
+var
+ fet: TFormatEtc;
+ stgm: TStgMedium;
+ pct: PSlotIPC;
+ iFile: Cardinal;
+ iFileMax: Cardinal;
+ hShell: THandle;
+ DragQueryFile: TDragQueryFile;
+ cbSize: Integer;
+ hDrop: THandle;
+begin
+ Result := E_INVALIDARG;
+ hShell := LoadLibrary('shell32.dll');
+ if hShell <> 0 then
+ begin
+ DragQueryFile := GetProcAddress(hShell, 'DragQueryFileA');
+ if @DragQueryFile <> nil then
+ begin
+ fet.cfFormat := CF_HDROP;
+ fet.ptd := nil;
+ fet.dwAspect := DVASPECT_CONTENT;
+ fet.lindex := -1;
+ fet.tymed := TYMED_HGLOBAL;
+ Result := pDataObject^.ptrVTable^.GetData(pDataObject, fet, stgm);
+ if Result = S_OK then
+ begin
+ // FIX, actually lock the global object and get a pointer
+ Pointer(hDrop) := GlobalLock(stgm.hGlobal);
+ if hDrop <> 0 then
+ begin
+ // get the maximum number of files
+ iFileMax := DragQueryFile(stgm.hGlobal, $FFFFFFFF, nil, 0);
+ iFile := 0;
+ while iFile < iFileMax do
+ begin
+ // get the size of the file path
+ cbSize := DragQueryFile(stgm.hGlobal, iFile, nil, 0);
+ // get the buffer
+ pct := ipcAlloc(pipch, cbSize + 1); // including null term
+ // allocated?
+ if pct = nil then
+ break;
+ // store the hContact
+ pct^.hContact := hContact;
+ // copy it to the buffer
+ DragQueryFile(stgm.hGlobal, iFile, PChar(uint_ptr(pct) + sizeof(TSlotIPC)), pct^.cbStrSection);
+ // next file
+ inc(iFile);
+ end; // while
+ // store the number of files
+ pipch^.Slots := iFile;
+ GlobalUnlock(stgm.hGlobal);
+ end; // if hDrop check
+ // release the mediumn the lock may of failed
+ ReleaseStgMedium(stgm);
+ end; // if
+ end; // if
+ // free the dll
+ FreeLibrary(hShell);
+ end; // if
+end;
+
+function RequestTransfer(Self: PShlComRec; idxCmd: Integer): Integer;
+var
+ hMap: THandle;
+ pipch: PHeaderIPC;
+ mii: TMenuItemInfo;
+ hTransfer: THandle;
+ psd: PMenuDrawInfo;
+ hReply: THandle;
+ replyBits: Integer;
+begin
+ Result := E_INVALIDARG;
+ // get the contact information
+ mii.cbSize := sizeof(TMenuItemInfo);
+ mii.fMask := MIIM_ID or MIIM_DATA;
+ if GetMenuItemInfo(Self^.hRootMenu, Self^.idCmdFirst + idxCmd, False, mii) then
+ begin
+ // get the pointer
+ uint_ptr(psd) := mii.dwItemData;
+ // the ID stored in the item pointer and the ID for the menu must match
+ if (psd = nil) or (psd^.wID <> mii.wID) then
+ begin
+ // MessageBox(0,'ptr assocated with menu is NULL','',MB_OK);
+ Exit;
+ end; // if
+ end
+ else
+ begin
+ // MessageBox(0,'GetMenuItemInfo failed?','',MB_OK);
+ // couldn't get the info, can't start the transfer
+ Result := E_INVALIDARG;
+ Exit;
+ end; // if
+ // is there an IDataObject instance?
+ if Self^.pDataObject <> nil then
+ begin
+ // OpenEvent() the work object to see if the instance is still around
+ hTransfer := OpenEvent(EVENT_ALL_ACCESS, False, PChar(CreateProcessUID(psd^.pid)));
+ if hTransfer <> 0 then
+ begin
+ // map the ipc file again
+ hMap := CreateFileMapping(INVALID_HANDLE_VALUE,nil,PAGE_READWRITE,0,IPC_PACKET_SIZE,IPC_PACKET_NAME);
+ if (hMap <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS) then
+ begin
+ // map it to process
+ pipch := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
+ if pipch <> nil then
+ begin
+ // create the name of the object to be signalled by the ST
+ lstrcpya(pipch^.SignalEventName, PChar(CreateUID()));
+ // create it
+ hReply := CreateEvent(nil, False, False, pipch^.SignalEventName);
+ if hReply <> 0 then
+ begin
+ if dtCommand in psd^.fTypes then
+ begin
+ if Assigned(psd^.MenuCommandCallback) then
+ Result := psd^.MenuCommandCallback(pipch, hTransfer, hReply, psd);
+ end
+ else
+ begin
+
+ // prepare the buffer
+ ipcPrepareRequests(IPC_PACKET_SIZE, pipch, REQUEST_XFRFILES);
+ // get all the files into the packet
+ if ipcGetFiles(pipch, Self^.pDataObject, psd^.hContact) = S_OK then
+ begin
+ // need to wait for the ST to open the mapping object
+ // since if we close it before it's opened it the data it
+ // has will be undefined
+ replyBits := ipcSendRequest(hTransfer, hReply, pipch, 200);
+ if replyBits <> REPLY_FAIL then
+ begin
+ // they got the files!
+ Result := S_OK;
+ end; // if
+ end;
+
+ end;
+ // close the work object name
+ CloseHandle(hReply);
+ end; // if
+ // unmap it from this process
+ UnmapViewOfFile(pipch);
+ end; // if
+ // close the map
+ CloseHandle(hMap);
+ end; // if
+ // close the handle to the ST object name
+ CloseHandle(hTransfer);
+ end; // if
+ end // if;
+end;
+
+function TShlComRec_InvokeCommand(Self: PContextMenu3_Interface;
+ var lpici: TCMInvokeCommandInfo): HResult; stdcall;
+begin
+ Result := RequestTransfer(Self^.ptrInstance, LOWORD(uint_ptr(lpici.lpVerb)));
+end;
+
+function TShlComRec_HandleMenuMsgs(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
+ lParam: lParam; pResult: PLResult): HResult;
+const
+ WM_DRAWITEM = $002B;
+ WM_MEASUREITEM = $002C;
+var
+ dwi: PDrawItemStruct;
+ msi: PMeasureItemStruct;
+ psd: PMenuDrawInfo;
+ ncm: TNonClientMetrics;
+ hOldFont: THandle;
+ hFont: THandle;
+ tS: TSize;
+ dx: Integer;
+ hBr: HBRUSH;
+ icorc: TRect;
+ hMemDC: HDC;
+begin
+ pResult^ := Integer(True);
+ if (uMsg = WM_DRAWITEM) and (wParam = 0) then
+ begin
+ // either a main sub menu, a group menu or a contact
+ dwi := PDrawItemStruct(lParam);
+ uint_ptr(psd) := dwi^.itemData;
+ // don't fill
+ SetBkMode(dwi^.HDC, TRANSPARENT);
+ // where to draw the icon?
+ icorc.Left := 0;
+ // center it
+ with dwi^ do
+ icorc.Top := rcItem.Top + ((rcItem.Bottom - rcItem.Top) div 2) - (16 div 2);
+ icorc.Right := icorc.Left + 16;
+ icorc.Bottom := icorc.Top + 16;
+ // draw for groups
+ if (dtGroup in psd^.fTypes) or (dtEntry in psd^.fTypes) then
+ begin
+ hBr := GetSysColorBrush(COLOR_MENU);
+ FillRect(dwi^.HDC, dwi^.rcItem, hBr);
+ DeleteObject(hBr);
+ //
+ if (ODS_SELECTED and dwi^.itemState = ODS_SELECTED) then
+ begin
+ // only do this for entry menu types otherwise a black mask
+ // is drawn under groups
+ hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
+ FillRect(dwi^.HDC, dwi^.rcItem, hBr);
+ DeleteObject(hBr);
+ SetTextColor(dwi^.HDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
+ end; // if
+ // draw icon
+ with dwi^, icorc do
+ begin
+ if (ODS_SELECTED and dwi^.itemState) = ODS_SELECTED then
+ begin
+ hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
+ end
+ else
+ begin
+ hBr := GetSysColorBrush(COLOR_MENU);
+ end; // if
+ DrawIconEx(HDC, Left + 1, Top, psd^.hStatusIcon, 16, 16, // width, height
+ 0, // step
+ hBr, // brush
+ DI_NORMAL);
+ DeleteObject(hBr);
+ end; // with
+ // draw the text
+ with dwi^ do
+ begin
+ inc(rcItem.Left, ((rcItem.Bottom - rcItem.Top) - 2));
+ DrawText(HDC, psd^.szText, psd^.cch, rcItem, DT_NOCLIP or DT_NOPREFIX or
+ DT_SINGLELINE or DT_VCENTER);
+ // draw the name of the database text if it's there
+ if psd^.szProfile <> nil then
+ begin
+ GetTextExtentPoint32(dwi^.HDC, psd^.szText, psd^.cch, tS);
+ inc(rcItem.Left, tS.cx + 8);
+ SetTextColor(HDC, GetSysColor(COLOR_GRAYTEXT));
+ DrawText(HDC, psd^.szProfile, lstrlena(psd^.szProfile), rcItem,
+ DT_NOCLIP or DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER);
+ end; // if
+ end; // with
+ end
+ else
+ begin
+ // it's a contact!
+ hBr := GetSysColorBrush(COLOR_MENU);
+ FillRect(dwi^.HDC, dwi^.rcItem, hBr);
+ DeleteObject(hBr);
+ if ODS_SELECTED and dwi^.itemState = ODS_SELECTED then
+ begin
+ hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
+ FillRect(dwi^.HDC, dwi^.rcItem, hBr);
+ DeleteObject(hBr);
+ SetTextColor(dwi^.HDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
+ end;
+ // draw icon
+ with dwi^, icorc do
+ begin
+ if (ODS_SELECTED and dwi^.itemState) = ODS_SELECTED then
+ begin
+ hBr := GetSysColorBrush(COLOR_HIGHLIGHT);
+ end
+ else
+ begin
+ hBr := GetSysColorBrush(COLOR_MENU);
+ end; // if
+ DrawIconEx(HDC, Left + 2, Top, psd^.hStatusIcon, 16, 16, // width, height
+ 0, // step
+ hBr, // brush
+ DI_NORMAL);
+ DeleteObject(hBr);
+ end; // with
+ // draw the text
+ with dwi^ do
+ begin
+ inc(rcItem.Left, (rcItem.Bottom - rcItem.Top) + 1);
+ DrawText(HDC, psd^.szText, psd^.cch, rcItem, DT_NOCLIP or DT_NOPREFIX or
+ DT_SINGLELINE or DT_VCENTER);
+ end; // with
+ end; // if
+ end
+ else if (uMsg = WM_MEASUREITEM) then
+ begin
+ // don't check if it's really a menu
+ msi := PMeasureItemStruct(lParam);
+ uint_ptr(psd) := msi^.itemData;
+ ncm.cbSize := sizeof(TNonClientMetrics);
+ SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @ncm, 0);
+ // create the font used in menus, this font should be cached somewhere really
+{$IFDEF FPC}
+ hFont := CreateFontIndirect(@ncm.lfMenuFont);
+{$ELSE}
+ hFont := CreateFontIndirect(ncm.lfMenuFont);
+{$ENDIF}
+ hMemDC := Self^.ptrInstance^.hMemDC;
+ // select in the font
+ hOldFont := SelectObject(hMemDC, hFont);
+ // default to an icon
+ dx := 16;
+ // get the size 'n' account for the icon
+ GetTextExtentPoint32(hMemDC, psd^.szText, psd^.cch, tS);
+ inc(dx, tS.cx);
+ // main menu item?
+ if psd^.szProfile <> nil then
+ begin
+ GetTextExtentPoint32(hMemDC, psd^.szProfile, lstrlena(psd^.szProfile), tS);
+ inc(dx, tS.cx);
+ end;
+ // store it
+ msi^.itemWidth := dx + Integer(ncm.iMenuWidth);
+ msi^.itemHeight := Integer(ncm.iMenuHeight) + 2;
+ if tS.cy > msi^.itemHeight then
+ inc(msi^.itemHeight, tS.cy - msi^.itemHeight);
+ // clean up
+ SelectObject(hMemDC, hOldFont);
+ DeleteObject(hFont);
+ end;
+ Result := S_OK;
+end;
+
+function TShlComRec_HandleMenuMsg(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
+ lParam: lParam): HResult; stdcall;
+var
+ Dummy: HResult;
+begin
+ Result := TShlComRec_HandleMenuMsgs(Self, uMsg, wParam, lParam, @Dummy);
+end;
+
+function TShlComRec_HandleMenuMsg2(Self: PContextMenu3_Interface; uMsg: UINT; wParam: wParam;
+ lParam: lParam; PLResult: Pointer { ^LResult } ): HResult; stdcall;
+var
+ Dummy: HResult;
+begin
+ // this will be null if a return value isn't needed.
+ if PLResult = nil then
+ PLResult := @Dummy;
+ Result := TShlComRec_HandleMenuMsgs(Self, uMsg, wParam, lParam, PLResult);
+end;
+
+function TShlComRec_Create: PShlComRec;
+var
+ DC: HDC;
+begin
+ New(Result);
+ { build all the function tables for interfaces }
+ with Result^.ShellExtInit_Interface do
+ begin
+ { this is only owned by us... }
+ ptrVTable := @vTable;
+ { IUnknown }
+ vTable.QueryInterface := @TShlComRec_QueryInterface;
+ vTable.AddRef := @TShlComRec_AddRef;
+ vTable.Release := @TShlComRec_Release;
+ { IShellExtInit }
+ vTable.Initialise := @TShlComRec_Initialise;
+ { instance of a TShlComRec }
+ ptrInstance := Result;
+ end;
+ with Result^.ContextMenu3_Interface do
+ begin
+ ptrVTable := @vTable;
+ { IUnknown }
+ vTable.QueryInterface := @TShlComRec_QueryInterface;
+ vTable.AddRef := @TShlComRec_AddRef;
+ vTable.Release := @TShlComRec_Release;
+ { IContextMenu }
+ vTable.QueryContextMenu := @TShlComRec_QueryContextMenu;
+ vTable.InvokeCommand := @TShlComRec_InvokeCommand;
+ vTable.GetCommandString := @TShlComRec_GetCommandString;
+ { IContextMenu2 }
+ vTable.HandleMenuMsg := @TShlComRec_HandleMenuMsg;
+ { IContextMenu3 }
+ vTable.HandleMenuMsg2 := @TShlComRec_HandleMenuMsg2;
+ { instance data }
+ ptrInstance := Result;
+ end;
+ { initalise variables }
+ Result^.RefCount := 1;
+ Result^.hDllHeap := HeapCreate(0, 0, 0);
+ Result^.hRootMenu := 0;
+ Result^.hRecentMenu := 0;
+ Result^.RecentCount := 0;
+ Result^.idCmdFirst := 0;
+ Result^.pDataObject := nil;
+ Result^.ProtoIcons := nil;
+ Result^.ProtoIconsCount := 0;
+ // create an inmemory DC
+ DC := GetDC(0);
+ Result^.hMemDC := CreateCompatibleDC(DC);
+ ReleaseDC(0, DC);
+ { keep count on the number of objects }
+ inc(dllpublic.ObjectCount);
+end;
+
+{ IClassFactory }
+
+type
+
+ PVTable_IClassFactory = ^TVTable_IClassFactory;
+
+ TVTable_IClassFactory = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: Pointer;
+ Release: Pointer;
+ { IClassFactory }
+ CreateInstance: Pointer;
+ LockServer: Pointer;
+ end;
+
+ PClassFactoryRec = ^TClassFactoryRec;
+
+ TClassFactoryRec = record
+ ptrVTable: PVTable_IClassFactory;
+ vTable: TVTable_IClassFactory;
+ { fields }
+ RefCount: LongInt;
+ end;
+
+function TClassFactoryRec_QueryInterface(Self: PClassFactoryRec; const IID: TIID; var Obj): HResult; stdcall;
+begin
+ Pointer(Obj) := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TClassFactoryRec_AddRef(Self: PClassFactoryRec): LongInt; stdcall;
+begin
+ inc(Self^.RefCount);
+ Result := Self^.RefCount;
+end;
+
+function TClassFactoryRec_Release(Self: PClassFactoryRec): LongInt; stdcall;
+begin
+ dec(Self^.RefCount);
+ Result := Self^.RefCount;
+ if Result = 0 then
+ begin
+ Dispose(Self);
+ dec(dllpublic.FactoryCount);
+ end; { if }
+end;
+
+function TClassFactoryRec_CreateInstance(Self: PClassFactoryRec; unkOuter: Pointer;
+ const IID: TIID; var Obj): HResult; stdcall;
+var
+ ShlComRec: PShlComRec;
+begin
+ Pointer(Obj) := nil;
+ Result := CLASS_E_NOAGGREGATION;
+ if unkOuter = nil then
+ begin
+ { Before Vista, the system queried for a IShell interface then queried for a context menu, Vista now
+ queries for a context menu (or a shell menu) then QI()'s the other interface }
+ if IsEqualIID(IID, IID_IContextMenu) then
+ begin
+ Result := S_OK;
+ ShlComRec := TShlComRec_Create;
+ Pointer(Obj) := @ShlComRec^.ContextMenu3_Interface;
+ end;
+ if IsEqualIID(IID, IID_IShellExtInit) then
+ begin
+ Result := S_OK;
+ ShlComRec := TShlComRec_Create;
+ Pointer(Obj) := @ShlComRec^.ShellExtInit_Interface;
+ end; // if
+ end; // if
+end;
+
+function TClassFactoryRec_LockServer(Self: PClassFactoryRec; fLock: BOOL): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TClassFactoryRec_Create: PClassFactoryRec;
+begin
+ New(Result);
+ Result^.ptrVTable := @Result^.vTable;
+ { IUnknown }
+ Result^.vTable.QueryInterface := @TClassFactoryRec_QueryInterface;
+ Result^.vTable.AddRef := @TClassFactoryRec_AddRef;
+ Result^.vTable.Release := @TClassFactoryRec_Release;
+ { IClassFactory }
+ Result^.vTable.CreateInstance := @TClassFactoryRec_CreateInstance;
+ Result^.vTable.LockServer := @TClassFactoryRec_LockServer;
+ { inital the variables }
+ Result^.RefCount := 1;
+ { count the number of factories }
+ inc(dllpublic.FactoryCount);
+end;
+
+//
+// IPC part
+//
+
+type
+ PFileList = ^TFileList;
+ TFileList = array [0 .. 0] of PChar;
+ PAddArgList = ^TAddArgList;
+
+ TAddArgList = record
+ szFile: PChar; // file being processed
+ cch: Cardinal; // it's length (with space for NULL char)
+ count: Cardinal; // number we have so far
+ files: PFileList;
+ hContact: THandle;
+ hEvent: THandle;
+ end;
+
+function AddToList(var args: TAddArgList): LongBool;
+var
+ attr: Cardinal;
+ p: Pointer;
+ hFind: THandle;
+ fd: TWIN32FINDDATA;
+ szBuf: array [0 .. MAX_PATH] of Char;
+ szThis: PChar;
+ cchThis: Cardinal;
+begin
+ Result := False;
+ attr := GetFileAttributes(args.szFile);
+ if (attr <> $FFFFFFFF) and ((attr and FILE_ATTRIBUTE_HIDDEN) = 0) then
+ begin
+ if args.count mod 10 = 5 then
+ begin
+ if CallService(MS_SYSTEM_TERMINATED, 0, 0) <> 0 then
+ begin
+ Result := True;
+ Exit;
+ end; // if
+ end;
+ if attr and FILE_ATTRIBUTE_DIRECTORY <> 0 then
+ begin
+ // add the directory
+ lstrcpya(szBuf, args.szFile);
+ ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
+ GetMem(p, strlen(szBuf) + 1);
+ lstrcpya(p, szBuf);
+ args.files^[args.count] := p;
+ inc(args.count);
+ // tack on ending search token
+ lstrcata(szBuf, '\*');
+ hFind := FindFirstFile(szBuf, fd);
+ while True do
+ begin
+ if fd.cFileName[0] <> '.' then
+ begin
+ lstrcpya(szBuf, args.szFile);
+ lstrcata(szBuf, '\');
+ lstrcata(szBuf, fd.cFileName);
+ // keep a copy of the current thing being processed
+ szThis := args.szFile;
+ args.szFile := szBuf;
+ cchThis := args.cch;
+ args.cch := strlen(szBuf) + 1;
+ // recurse
+ Result := AddToList(args);
+ // restore
+ args.szFile := szThis;
+ args.cch := cchThis;
+ if Result then
+ break;
+ end; // if
+ if not FindNextFile(hFind, fd) then
+ break;
+ end; // while
+ FindClose(hFind);
+ end
+ else
+ begin
+ // add the file
+ ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
+ GetMem(p, args.cch);
+ lstrcpya(p, args.szFile);
+ args.files^[args.count] := p;
+ inc(args.count);
+ end; // if
+ end;
+end;
+
+procedure MainThreadIssueTransfer(p: PAddArgList); stdcall;
+{$DEFINE SHL_IDC}
+{$DEFINE SHL_KEYS}
+{$INCLUDE shlc.inc}
+{$UNDEF SHL_KEYS}
+{$UNDEF SHL_IDC}
+begin
+ DBWriteContactSettingByte(p^.hContact, SHLExt_Name, SHLExt_MRU, 1);
+ CallService(MS_FILE_SENDSPECIFICFILES, p^.hContact, lParam(p^.files));
+ SetEvent(p^.hEvent);
+end;
+
+function IssueTransferThread(pipch: PHeaderIPC): Cardinal; stdcall;
+var
+ szBuf: array [0 .. MAX_PATH] of Char;
+ pct: PSlotIPC;
+ args: TAddArgList;
+ bQuit: LongBool;
+ j, c: Cardinal;
+ p: Pointer;
+ hMainThread: THandle;
+begin
+ result:=0;
+ Thread_Push(0,nil);
+ hMainThread := THandle(pipch^.Param);
+ GetCurrentDirectory(sizeof(szBuf), szBuf);
+ args.count := 0;
+ args.files := nil;
+ pct := pipch^.DataPtr;
+ bQuit := False;
+ while pct <> nil do
+ begin
+ if (pct^.cbSize <> sizeof(TSlotIPC)) then
+ break;
+ args.szFile := PChar(uint_ptr(pct) + sizeof(TSlotIPC));
+ args.hContact := pct^.hContact;
+ args.cch := pct^.cbStrSection + 1;
+ bQuit := AddToList(args);
+ if bQuit then
+ break;
+ pct := pct^.Next;
+ end; // while
+ if args.files <> nil then
+ begin
+ ReAllocMem(args.files, (args.count + 1) * sizeof(PChar));
+ args.files^[args.count] := nil;
+ inc(args.count);
+ if (not bQuit) then
+ begin
+ args.hEvent := CreateEvent(nil, True, False, nil);
+ QueueUserAPC(@MainThreadIssueTransfer, hMainThread, uint_ptr(@args));
+ while True do
+ begin
+ if WaitForSingleObjectEx(args.hEvent, INFINITE, True) <> WAIT_IO_COMPLETION then
+ break;
+ end;
+ CloseHandle(args.hEvent);
+ end; // if
+ c := args.count - 1;
+ for j := 0 to c do
+ begin
+ p := args.files^[j];
+ if p <> nil then
+ FreeMem(p);
+ end;
+ FreeMem(args.files);
+ end;
+ SetCurrentDirectory(szBuf);
+ FreeMem(pipch);
+ CloseHandle(hMainThread);
+ Thread_Pop();
+ ExitThread(0);
+end;
+
+type
+
+ PSlotInfo = ^TSlotInfo;
+
+ TSlotInfo = record
+ hContact: THandle;
+ hProto: Cardinal;
+ dwStatus: Integer; // will be aligned anyway
+ end;
+
+ TSlotArray = array [0 .. $FFFFFF] of TSlotInfo;
+ PSlotArray = ^TSlotArray;
+
+function SortContact(var Item1, Item2: TSlotInfo): Integer; stdcall;
+begin
+ Result := CallService(MS_CLIST_CONTACTSCOMPARE, Item1.hContact, Item2.hContact);
+end;
+
+// from FP FCL
+
+procedure QuickSort(FList: PSlotArray; L, R: LongInt);
+var
+ i, j: LongInt;
+ p, q: TSlotInfo;
+begin
+ repeat
+ i := L;
+ j := R;
+ p := FList^[(L + R) div 2];
+ repeat
+ while SortContact(p, FList^[i]) > 0 do
+ inc(i);
+ while SortContact(p, FList^[j]) < 0 do
+ dec(j);
+ if i <= j then
+ begin
+ q := FList^[i];
+ FList^[i] := FList^[j];
+ FList^[j] := q;
+ inc(i);
+ dec(j);
+ end; // if
+ until i > j;
+ if L < j then
+ QuickSort(FList, L, j);
+ L := i;
+ until i >= R;
+end;
+
+{$DEFINE SHL_KEYS}
+{$INCLUDE shlc.inc}
+{$UNDEF SHL_KEYS}
+
+procedure ipcGetSkinIcons(ipch: PHeaderIPC);
+var
+ protoCount: Integer;
+ pp: ^PPROTOCOLDESCRIPTOR;
+ spi: TSlotProtoIcons;
+ j: Cardinal;
+ pct: PSlotIPC;
+ szTmp: array [0 .. 63] of Char;
+ dwCaps: Cardinal;
+begin
+ if (CallService(MS_PROTO_ENUMPROTOCOLS, wParam(@protoCount), lParam(@pp)) = 0) and
+ (protoCount <> 0) then
+ begin
+ spi.pid := GetCurrentProcessId();
+ while protoCount > 0 do
+ begin
+ if (pp^._type = PROTOTYPE_PROTOCOL) then
+ begin
+ lstrcpya(szTmp, pp^.szName);
+ lstrcata(szTmp, PS_GETCAPS);
+ dwCaps := CallService(szTmp, PFLAGNUM_1, 0);
+ if (dwCaps and PF1_FILESEND) <> 0 then
+ begin
+ pct := ipcAlloc(ipch, sizeof(TSlotProtoIcons));
+ if pct <> nil then
+ begin
+ // capture all the icons!
+ spi.hProto := StrHash(pp^.szName);
+ for j := 0 to 9 do
+ begin
+ spi.hIcons[j] := LoadSkinnedProtoIcon(pp^.szName, ID_STATUS_OFFLINE + j);
+ end; // for
+ pct^.fType := REQUEST_NEWICONS;
+ CopyMemory(Pointer(uint_ptr(pct) + sizeof(TSlotIPC)), @spi, sizeof(TSlotProtoIcons));
+ if ipch^.NewIconsBegin = nil then
+ ipch^.NewIconsBegin := pct;
+ end; // if
+ end; // if
+ end; // if
+ inc(pp);
+ dec(protoCount);
+ end; // while
+ end; // if
+ // add Miranda icon
+ pct := ipcAlloc(ipch, sizeof(TSlotProtoIcons));
+ if pct <> nil then
+ begin
+ ZeroMemory(@spi.hIcons, sizeof(spi.hIcons));
+ spi.hProto := 0; // no protocol
+ spi.hIcons[0] := LoadSkinnedIcon(SKINICON_OTHER_MIRANDA);
+ pct^.fType := REQUEST_NEWICONS;
+ CopyMemory(Pointer(uint_ptr(pct) + sizeof(TSlotIPC)), @spi, sizeof(TSlotProtoIcons));
+ if ipch^.NewIconsBegin = nil then
+ ipch^.NewIconsBegin := pct;
+ end; // if
+end;
+
+function ipcGetSortedContacts(ipch: PHeaderIPC; pSlot: pint; bGroupMode: Boolean): Boolean;
+var
+ dwContacts: Cardinal;
+ pContacts: PSlotArray;
+ hContact: THandle;
+ i: Integer;
+ dwOnline: Cardinal;
+ szProto: PChar;
+ dwStatus: Integer;
+ pct: PSlotIPC;
+ szContact: PChar;
+ dbv: TDBVariant;
+ bHideOffline: Boolean;
+ szTmp: array [0 .. 63] of Char;
+ dwCaps: Cardinal;
+ szSlot: PChar;
+ n, rc, cch: Cardinal;
+begin
+ Result := False;
+ // hide offliners?
+ bHideOffline := DBGetContactSettingByte(0, 'CList', 'HideOffline', 0) = 1;
+ // do they wanna hide the offline people anyway?
+ if DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoOffline, 0) = 1 then
+ begin
+ // hide offline people
+ bHideOffline := True;
+ end;
+ // get the number of contacts
+ dwContacts := CallService(MS_DB_CONTACT_GETCOUNT, 0, 0);
+ if dwContacts = 0 then
+ Exit;
+ // get the contacts in the array to be sorted by status, trim out anyone
+ // who doesn't wanna be seen.
+ GetMem(pContacts, (dwContacts + 2) * sizeof(TSlotInfo));
+ i := 0;
+ dwOnline := 0;
+ hContact := CallService(MS_DB_CONTACT_FINDFIRST, 0, 0);
+ while (hContact <> 0) do
+ begin
+ if i >= dwContacts then
+ break;
+ (* do they have a running protocol? *)
+ uint_ptr(szProto) := CallService(MS_PROTO_GETCONTACTBASEPROTO, hContact, 0);
+ if szProto <> nil then
+ begin
+ (* does it support file sends? *)
+ lstrcpya(szTmp, szProto);
+ lstrcata(szTmp, PS_GETCAPS);
+ dwCaps := CallService(szTmp, PFLAGNUM_1, 0);
+ if (dwCaps and PF1_FILESEND) = 0 then
+ begin
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ continue;
+ end;
+ dwStatus := DBGetContactSettingWord(hContact, szProto, 'Status', ID_STATUS_OFFLINE);
+ if dwStatus <> ID_STATUS_OFFLINE then
+ inc(dwOnline)
+ else if bHideOffline then
+ begin
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ continue;
+ end; // if
+ // is HIT on?
+ if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHITContacts,
+ BST_UNCHECKED) then
+ begin
+ // don't show people who are "Hidden" "NotOnList" or Ignored
+ if (DBGetContactSettingByte(hContact, 'CList', 'Hidden', 0) = 1) or
+ (DBGetContactSettingByte(hContact, 'CList', 'NotOnList', 0) = 1) or
+ (CallService(MS_IGNORE_ISIGNORED, hContact, IGNOREEVENT_MESSAGE or
+ IGNOREEVENT_URL or IGNOREEVENT_FILE) <> 0) then
+ begin
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ continue;
+ end; // if
+ end; // if
+ // is HIT2 off?
+ if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHIT2Contacts,
+ BST_UNCHECKED) then
+ begin
+ if DBGetContactSettingWord(hContact, szProto, 'ApparentMode', 0) = ID_STATUS_OFFLINE
+ then
+ begin
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ continue;
+ end; // if
+ end; // if
+ // store
+ pContacts^[i].hContact := hContact;
+ pContacts^[i].dwStatus := dwStatus;
+ pContacts^[i].hProto := StrHash(szProto);
+ inc(i);
+ end
+ else
+ begin
+ // contact has no protocol!
+ end; // if
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ end; // while
+ // if no one is online and the CList isn't showing offliners, quit
+ if (dwOnline = 0) and (bHideOffline) then
+ begin
+ FreeMem(pContacts);
+ Exit;
+ end; // if
+ dwContacts := i;
+ i := 0;
+ // sort the array
+ QuickSort(pContacts, 0, dwContacts - 1);
+ // create an IPC slot for each contact and store display name, etc
+ while i < dwContacts do
+ begin
+ uint_ptr(szContact) := CallService(MS_CLIST_GETCONTACTDISPLAYNAME,pContacts^[i].hContact, 0);
+ if (szContact <> nil) then
+ begin
+ n := 0;
+ rc := 1;
+ if bGroupMode then
+ begin
+ rc := DBGetContactSetting(pContacts^[i].hContact, 'CList', 'Group', @dbv);
+ if rc = 0 then
+ begin
+ n := lstrlena(dbv.szVal.a) + 1;
+ end;
+ end; // if
+ cch := lstrlena(szContact) + 1;
+ pct := ipcAlloc(ipch, cch + 1 + n);
+ if pct = nil then
+ begin
+ DBFreeVariant(@dbv);
+ break;
+ end;
+ // lie about the actual size of the TSlotIPC
+ pct^.cbStrSection := cch;
+ szSlot := PChar(uint_ptr(pct) + sizeof(TSlotIPC));
+ lstrcpya(szSlot, szContact);
+ pct^.fType := REQUEST_CONTACTS;
+ pct^.hContact := pContacts^[i].hContact;
+ pct^.Status := pContacts^[i].dwStatus;
+ pct^.hProto := pContacts^[i].hProto;
+ pct^.MRU := DBGetContactSettingByte(pct^.hContact, SHLExt_Name, SHLExt_MRU, 0);
+ if ipch^.ContactsBegin = nil then
+ ipch^.ContactsBegin := pct;
+ inc(szSlot, cch + 1);
+ if rc = 0 then
+ begin
+ pct^.hGroup := StrHash(dbv.szVal.a);
+ lstrcpya(szSlot, dbv.szVal.a);
+ DBFreeVariant(@dbv);
+ end
+ else
+ begin
+ pct^.hGroup := 0;
+ szSlot^ := #0;
+ end;
+ inc(pSlot^);
+ end; // if
+ inc(i);
+ end; // while
+ FreeMem(pContacts);
+ //
+ Result := True;
+end;
+
+// worker thread to clear MRU, called by the IPC bridge
+function ClearMRUThread(notused: Pointer): Cardinal; stdcall;
+{$DEFINE SHL_IDC}
+{$DEFINE SHL_KEYS}
+{$INCLUDE shlc.inc}
+{$UNDEF SHL_KEYS}
+{$UNDEF SHL_IDC}
+var
+ hContact: THandle;
+begin
+ result:=0;
+ Thread_Push(0,nil);
+
+ begin
+ hContact := CallService(MS_DB_CONTACT_FINDFIRST, 0, 0);
+ while hContact <> 0 do
+ begin
+ if DBGetContactSettingByte(hContact, SHLExt_Name, SHLExt_MRU, 0) > 0 then
+ begin
+ DBWriteContactSettingByte(hContact, SHLExt_Name, SHLExt_MRU, 0);
+ end;
+ hContact := CallService(MS_DB_CONTACT_FINDNEXT, hContact, 0);
+ end;
+ end;
+ Thread_Pop();
+ ExitThread(0);
+end;
+
+// this function is called from an APC into the main thread
+procedure ipcService(dwParam: DWORD); stdcall;
+label
+ Reply;
+var
+ hMap: THandle;
+ pMMT: PHeaderIPC;
+ hSignal: THandle;
+ pct: PSlotIPC;
+ szBuf: PChar;
+ iSlot: Integer;
+ szGroupStr: array [0 .. 31] of Char;
+ dbv: TDBVariant;
+ bits: pint;
+ bGroupMode: Boolean;
+ tid: Cardinal;
+ cloned: PHeaderIPC;
+ szMiranda: PChar;
+begin
+ { try to open the file mapping object the caller must make sure no other
+ running instance is using this file }
+ hMap := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, IPC_PACKET_NAME);
+ If hMap <> 0 then
+ begin
+ { map the file to this process }
+ pMMT := MapViewOfFile(hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0);
+ { if it fails the caller should of had some timeout in wait }
+ if (pMMT <> nil) and (pMMT^.cbSize = sizeof(THeaderIPC)) and
+ (pMMT^.dwVersion = PLUGIN_MAKE_VERSION(2, 0, 1, 2)) then
+ begin
+ // toggle the right bits
+ bits := @pMMT^.fRequests;
+ // jump right to a worker thread for file processing?
+ if (bits^ and REQUEST_XFRFILES) = REQUEST_XFRFILES then
+ begin
+ GetMem(cloned, IPC_PACKET_SIZE);
+ // translate from client space to cloned heap memory
+ pMMT^.pServerBaseAddress := pMMT^.pClientBaseAddress;
+ pMMT^.pClientBaseAddress := cloned;
+ CopyMemory(cloned, pMMT, IPC_PACKET_SIZE);
+ ipcFixupAddresses(True, cloned);
+ DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(),
+ @cloned^.Param, THREAD_SET_CONTEXT, False, 0);
+ CloseHandle(CreateThread(nil, 0, @IssueTransferThread, cloned, 0, tid));
+ goto Reply;
+ end;
+ // the request was to clear the MRU entries, we have no return data
+ if (bits^ and REQUEST_CLEARMRU) = REQUEST_CLEARMRU then
+ begin
+ CloseHandle(CreateThread(nil, 0, @ClearMRUThread, nil, 0, tid));
+ goto Reply;
+ end;
+ // the IPC header may have pointers that need to be translated
+ // in either case the supplied data area pointers has to be
+ // translated to this address space.
+ // the server base address is always removed to get an offset
+ // to which the client base is added, this is what ipcFixupAddresses() does
+ pMMT^.pServerBaseAddress := pMMT^.pClientBaseAddress;
+ pMMT^.pClientBaseAddress := pMMT;
+ // translate to the server space map
+ ipcFixupAddresses(True, pMMT);
+ // store the address map offset so the caller can retranslate
+ pMMT^.pServerBaseAddress := pMMT;
+ // return some options to the client
+ if DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoIcons, 0) <> 0 then
+ begin
+ pMMT^.dwFlags := HIPC_NOICONS;
+ end;
+ // see if we have a custom string for 'Miranda'
+ szMiranda := Translate('Miranda');
+ lstrcpyn(pMMT^.MirandaName, szMiranda, sizeof(pMMT^.MirandaName) - 1);
+
+ // for the MRU menu
+ szBuf := Translate('Recently');
+ lstrcpyn(pMMT^.MRUMenuName, szBuf, sizeof(pMMT^.MRUMenuName) - 1);
+
+ // and a custom string for "clear entries"
+ szBuf := Translate('Clear entries');
+ lstrcpyn(pMMT^.ClearEntries, szBuf, sizeof(pMMT^.ClearEntries) - 1);
+
+ // if the group mode is on, check if they want the CList setting
+ bGroupMode := BST_CHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseGroups,
+ BST_UNCHECKED);
+ if bGroupMode and (BST_CHECKED = DBGetContactSettingByte(0, SHLExt_Name,
+ SHLExt_UseCListSetting, BST_UNCHECKED)) then
+ begin
+ bGroupMode := 1 = DBGetContactSettingByte(0, 'CList', 'UseGroups', 0);
+ end;
+ iSlot := 0;
+ // return profile if set
+ if BST_UNCHECKED = DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoProfile,
+ BST_UNCHECKED) then
+ begin
+ pct := ipcAlloc(pMMT, 50);
+ if pct <> nil then
+ begin
+ // will actually return with .dat if there's space for it, not what the docs say
+ pct^.Status := STATUS_PROFILENAME;
+ CallService(MS_DB_GETPROFILENAME, 49, uint_ptr(pct) + sizeof(TSlotIPC));
+ end; // if
+ end; // if
+ if (bits^ and REQUEST_NEWICONS) = REQUEST_NEWICONS then
+ begin
+ ipcGetSkinIcons(pMMT);
+ end;
+ if (bits^ and REQUEST_GROUPS = REQUEST_GROUPS) then
+ begin
+ // return contact's grouping if it's present
+ while bGroupMode do
+ begin
+ str(iSlot, szGroupStr);
+ if DBGetContactSetting(0, 'CListGroups', szGroupStr, @dbv) <> 0 then
+ break;
+ pct := ipcAlloc(pMMT, lstrlena(dbv.szVal.a + 1) + 1);
+ // first byte has flags, need null term
+ if pct <> nil then
+ begin
+ if pMMT^.GroupsBegin = nil then
+ pMMT^.GroupsBegin := pct;
+ pct^.fType := REQUEST_GROUPS;
+ pct^.hContact := 0;
+ uint_ptr(szBuf) := uint_ptr(pct) + sizeof(TSlotIPC); // get the end of the slot
+ lstrcpya(szBuf, dbv.szVal.a + 1);
+ pct^.hGroup := 0;
+ DBFreeVariant(@dbv); // free the string
+ end
+ else
+ begin
+ // outta space
+ DBFreeVariant(@dbv);
+ break;
+ end; // if
+ inc(iSlot);
+ end; { while }
+ // if there was no space left, it'll end on null
+ if pct = nil then
+ bits^ := (bits^ or GROUPS_NOTIMPL) and not REQUEST_GROUPS;
+ end; { if: group request }
+ // SHOULD check slot space.
+ if (bits^ and REQUEST_CONTACTS = REQUEST_CONTACTS) then
+ begin
+ if not ipcGetSortedContacts(pMMT, @iSlot, bGroupMode) then
+ begin
+ // fail if there were no contacts AT ALL
+ bits^ := (bits^ or CONTACTS_NOTIMPL) and not REQUEST_CONTACTS;
+ end; // if
+ end; // if:contact request
+ // store the number of slots allocated
+ pMMT^.Slots := iSlot;
+ Reply:
+ { get the handle the caller wants to be signalled on }
+ hSignal := OpenEvent(EVENT_ALL_ACCESS, False, pMMT^.SignalEventName);
+ { did it open? }
+ If hSignal <> 0 then
+ begin
+ { signal and close }
+ SetEvent(hSignal);
+ CloseHandle(hSignal);
+ end;
+ { unmap the shared memory from this process }
+ UnmapViewOfFile(pMMT);
+ end;
+ { close the map file }
+ CloseHandle(hMap);
+ end; { if }
+ //
+end;
+
+function ThreadServer(hMainThread: Pointer): Cardinal;
+{$IFDEF FPC}
+stdcall;
+{$ENDIF}
+var
+ hEvent: THandle;
+begin
+ result:=0;
+ Thread_Push(0,nil);
+ hEvent := CreateEvent(nil, False, False, PChar(CreateProcessUID(GetCurrentProcessId())));
+ while True do
+ begin
+ Result := WaitForSingleObjectEx(hEvent, INFINITE, True);
+ if Result = WAIT_OBJECT_0 then
+ begin
+ QueueUserAPC(@ipcService, THandle(hMainThread), 0);
+ end; // if
+ if CallService(MS_SYSTEM_TERMINATED, 0, 0) = 1 then
+ break;
+ end; // while
+ CloseHandle(hEvent);
+ CloseHandle(THandle(hMainThread));
+ Thread_Pop();
+ ExitThread(0);
+end;
+
+procedure InvokeThreadServer;
+var
+{$IFDEF FPC}
+ tid: LongWord;
+{$ELSE}
+ tid: Cardinal;
+{$ENDIF}
+var
+ hMainThread: THandle;
+begin
+ hMainThread := 0;
+ DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), @hMainThread,
+ THREAD_SET_CONTEXT, False, 0);
+ if hMainThread <> 0 then
+ begin
+{$IFDEF FPC}
+ CloseHandle(CreateThread(nil, 0, @ThreadServer, Pointer(hMainThread), 0, tid));
+{$ELSE}
+ CloseHandle(BeginThread(nil, 0, @ThreadServer, Pointer(hMainThread), 0, tid));
+{$ENDIF}
+ end; // if
+end;
+
+{ exported functions }
+
+function DllGetClassObject(const CLSID: TCLSID; const IID: TIID; var Obj): HResult; stdcall;
+begin
+ Pointer(Obj) := nil;
+ Result := CLASS_E_CLASSNOTAVAILABLE;
+ if (IsEqualCLSID(CLSID, CLSID_ISHLCOM)) and (IsEqualIID(IID, IID_IClassFactory)) and
+ (FindWindow(MirandaName, nil) <> 0) then
+ begin
+ Pointer(Obj) := TClassFactoryRec_Create;
+ Result := S_OK;
+ end; // if
+end;
+
+function DllCanUnloadNow: HResult;
+begin
+ if ((dllpublic.FactoryCount = 0) and (dllpublic.ObjectCount = 0)) then
+ begin
+ Result := S_OK;
+ end
+ else
+ begin
+ Result := S_FALSE;
+ end; // if
+end;
+
+{ helper functions }
+
+type
+
+ PSHELLEXECUTEINFO = ^TSHELLEXECUTEINFO;
+
+ TSHELLEXECUTEINFO = record
+ cbSize: DWORD;
+ fMask: LongInt;
+ hwnd: THandle;
+ lpVerb: PChar;
+ lpFile: PChar;
+ lpParameters: PChar;
+ lpDirectory: PChar;
+ nShow: Integer;
+ hInstApp: THandle;
+ lpIDLIst: Pointer;
+ lpClass: PChar;
+ HKEY: THandle;
+ dwHotkey: DWORD;
+ HICON: THandle; // is union
+ hProcess: THandle;
+ end;
+
+function ShellExecuteEx(var se: TSHELLEXECUTEINFO): Boolean; stdcall;
+ external 'shell32.dll' name 'ShellExecuteExA';
+
+function wsprintfs(lpOut, lpFmt: PChar; args: PChar): Integer; cdecl;
+ external 'user32.dll' name 'wsprintfA';
+
+function RemoveCOMRegistryEntries: HResult;
+var
+ hRootKey: HKEY;
+begin
+ if RegOpenKeyEx(HKEY_CLASSES_ROOT, 'miranda.shlext', 0, KEY_READ, hRootKey) = ERROR_SUCCESS
+ then
+ begin
+ (* need to delete the subkey before the parent key is deleted under NT/2000/XP *)
+ RegDeleteKey(hRootKey, 'CLSID');
+ (* close the key *)
+ RegCloseKey(hRootKey);
+ (* delete it *)
+ if RegDeleteKey(HKEY_CLASSES_ROOT, 'miranda.shlext') <> ERROR_SUCCESS then
+ begin
+ MessageBox(0,
+ 'Unable to delete registry key for "shlext COM", this key may already be deleted or you may need admin rights.',
+ 'Problem', MB_ICONERROR);
+ end; // if
+ end; // if
+ if RegOpenKeyEx(HKEY_CLASSES_ROOT, '\*\shellex\ContextMenuHandlers', 0, KEY_ALL_ACCESS,
+ hRootKey) = ERROR_SUCCESS then
+ begin
+ if RegDeleteKey(hRootKey, 'miranda.shlext') <> ERROR_SUCCESS then
+ begin
+ MessageBox(0,
+ 'Unable to delete registry key for "File context menu handlers", this key may already be deleted or you may need admin rights.',
+ 'Problem', MB_ICONERROR);
+ end; // if
+ RegCloseKey(hRootKey);
+ end; // if
+ if RegOpenKeyEx(HKEY_CLASSES_ROOT, 'Directory\shellex\ContextMenuHandlers', 0, KEY_ALL_ACCESS,
+ hRootKey) = ERROR_SUCCESS then
+ begin
+ if RegDeleteKey(hRootKey, 'miranda.shlext') <> ERROR_SUCCESS then
+ begin
+ MessageBox(0,
+ 'Unable to delete registry key for "Directory context menu handlers", this key may already be deleted or you may need admin rights.',
+ 'Problem', MB_ICONERROR);
+ end; // if
+ RegCloseKey(hRootKey);
+ end; // if
+ if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE,
+ 'Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', 0, KEY_ALL_ACCESS,
+ hRootKey) then
+ begin
+ if RegDeleteValue(hRootKey, '{72013A26-A94C-11d6-8540-A5E62932711D}') <> ERROR_SUCCESS then
+ begin
+ MessageBox(0,
+ 'Unable to delete registry entry for "Approved context menu handlers", this key may already be deleted or you may need admin rights.',
+ 'Problem', MB_ICONERROR);
+ end; // if
+ RegCloseKey(hRootKey);
+ end; // if
+ Result := S_OK;
+end;
+
+{ called by the options code to remove COM entries, and before that, get permission, if required.
+}
+
+procedure CheckUnregisterServer;
+var
+ sei: TSHELLEXECUTEINFO;
+ szBuf: array [0 .. MAX_PATH * 2] of Char;
+ szFileName: array [0 .. MAX_PATH] of Char;
+begin
+ if not VistaOrLater then
+ begin
+ RemoveCOMRegistryEntries();
+ Exit;
+ end;
+ // launches regsvr to remove the dll under admin.
+ GetModuleFileName(System.hInstance, szFileName, sizeof(szFileName));
+ wsprintfs(szBuf, '/s /u "%s"', szFileName);
+ ZeroMemory(@sei, sizeof(sei));
+ sei.cbSize := sizeof(sei);
+ sei.lpVerb := 'runas';
+ sei.lpFile := 'regsvr32';
+ sei.lpParameters := szBuf;
+ ShellExecuteEx(sei);
+ Sleep(1000);
+ RemoveCOMRegistryEntries();
+end;
+
+{ Wow, I can't believe there isn't a direct API for this - 'runas' will invoke the UAC and ask
+ for permission before installing the shell extension. note the filepath arg has to be quoted }
+procedure CheckRegisterServer;
+var
+ hRegKey: HKEY;
+ sei: TSHELLEXECUTEINFO;
+ szBuf: array [0 .. MAX_PATH * 2] of Char;
+ szFileName: array [0 .. MAX_PATH] of Char;
+begin
+ if ERROR_SUCCESS = RegOpenKeyEx(HKEY_CLASSES_ROOT, 'miranda.shlext', 0, KEY_READ, hRegKey)
+ then
+ begin
+ RegCloseKey(hRegKey);
+ end
+ else
+ begin
+ if VistaOrLater then
+ begin
+ MessageBox(0,
+ 'Shell context menus requires your permission to register with Windows Explorer (one time only).',
+ 'Miranda IM - Shell context menus (shlext.dll)', MB_OK or MB_ICONINFORMATION);
+ // /s = silent
+ GetModuleFileName(System.hInstance, szFileName, sizeof(szFileName));
+ wsprintfs(szBuf, '/s "%s"', szFileName);
+ ZeroMemory(@sei, sizeof(sei));
+ sei.cbSize := sizeof(sei);
+ sei.lpVerb := 'runas';
+ sei.lpFile := 'regsvr32';
+ sei.lpParameters := szBuf;
+ ShellExecuteEx(sei);
+ end;
+ end;
+end;
+
+initialization
+
+begin
+ FillChar(dllpublic, sizeof(dllpublic), 0);
+ IsMultiThread := True;
+ VistaOrLater := GetProcAddress(GetModuleHandle('kernel32'), 'GetProductInfo') <> nil;
+end;
+
+end. diff --git a/plugins/!NotAdopted/ShlExt/shldlgs.rc b/plugins/!NotAdopted/ShlExt/shldlgs.rc new file mode 100644 index 0000000000..0e9cd82b04 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shldlgs.rc @@ -0,0 +1,93 @@ +#include "resource.h" +//#include "afxres.h" +#define WS_POPUP 0x80000000L +#define WS_CHILD 0x40000000L +#define BS_AUTOCHECKBOX 0x00000003L +#define WS_TABSTOP 0x00010000L +#define SS_ETCHEDHORZ 0x00000010L +#define WS_GROUP 0x00020000L +#ifndef IDC_STATIC +#define IDC_STATIC (-1) +#endif + +///////////////////////////////////////////////////////////////////////////// +// +// Dialog +// + +IDD_SHLOPTS DIALOG DISCARDABLE 0, 0, 312, 238 +STYLE WS_POPUP +FONT 8, "MS Shell Dlg" +BEGIN + CONTROL "Display contacts in their assigned groups (if any)", + IDC_USEGROUPS,"Button",BS_AUTOCHECKBOX | WS_TABSTOP,15, + 35,281,8 + CONTROL "Only if/when the contact list is using them", + IDC_CLISTGROUPS,"Button",BS_AUTOCHECKBOX | WS_TABSTOP,29, + 50,267,8 + CONTROL "Display hidden, ignored or temporary contacts", + IDC_SHOWFULL,"Button",BS_AUTOCHECKBOX | WS_TABSTOP,15,65, + 281,8 + CONTROL "",IDC_STATIC,"Static",SS_ETCHEDHORZ,26,21,192,1 + LTEXT "Menus",IDC_CAPMENUS,10,17,24,8 + LTEXT "",IDC_STATIC,214,16,10,11,NOT WS_GROUP + CONTROL "",IDC_STATIC,"Static",SS_ETCHEDHORZ,34,145,183,1 + LTEXT "Shell Status",IDC_CAPSHLSTATUS,10,141,43,8 + LTEXT "",IDC_STATIC,214,111,10,11,NOT WS_GROUP + LTEXT "...",IDC_STATUS,15,154,253,12 + GROUPBOX "Shell context menus",IDC_STATIC,0,0,311,238 + CONTROL "Do not display the profile name in use",IDC_NOPROF, + "Button",BS_AUTOCHECKBOX | WS_TABSTOP,15,80,285,8 + CONTROL "Show contacts that you have set privacy rules for", + IDC_SHOWINVISIBLES,"Button",BS_AUTOCHECKBOX | WS_TABSTOP, + 15,110,290,8 + PUSHBUTTON "Remove",IDC_REMOVE,14,173,42,14 + CONTROL "Do not show status icons in menus",IDC_USEOWNERDRAW, + "Button",BS_AUTOCHECKBOX | WS_TABSTOP,15,95,290,8 + LTEXT "",IDC_STATIC,214,136,10,11,NOT WS_GROUP + CONTROL "Do not show contacts that are offline, even if my contact list does",IDC_HIDEOFFLINE, + "Button",BS_AUTOCHECKBOX | WS_TABSTOP,15,125,290,8 +END + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 1,0,6,6 + PRODUCTVERSION 1,0,6,6 + FILEFLAGSMASK 0x3fL +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "080904b0" + BEGIN + VALUE "Comments", "\0" + VALUE "CompanyName", "\0" + VALUE "FileDescription", "'Click ''n'' send support from Explorer/Common dialogs/Desktop, Right click on a file/folder to be presented with all your Miranda contact lists and then select the profile/contact you want to send to.\0" + VALUE "FileVersion", "1, 0, 6, 6\0" + VALUE "InternalName", "shlext\0" + VALUE "LegalCopyright", "\0" + VALUE "LegalTrademarks", "\0" + VALUE "OriginalFilename", "shlext.dll\0" + VALUE "PrivateBuild", "\0" + VALUE "ProductName", "\0" + VALUE "ProductVersion", "1, 0, 6, 6\0" + VALUE "SpecialBuild", "\0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x809, 1200 + END +END + diff --git a/plugins/!NotAdopted/ShlExt/shldlgs.res b/plugins/!NotAdopted/ShlExt/shldlgs.res Binary files differnew file mode 100644 index 0000000000..3de576e992 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shldlgs.res diff --git a/plugins/!NotAdopted/ShlExt/shlext.dpr b/plugins/!NotAdopted/ShlExt/shlext.dpr new file mode 100644 index 0000000000..d8745532f2 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shlext.dpr @@ -0,0 +1,397 @@ +{$IFDEF FPC} +{$PACKRECORDS 4}
+{$MODE Delphi}
+{$ASMMODE intel}
+{$INLINE ON}
+{$MACRO ON}
+{$APPTYPE GUI}
+{$IMAGEBASE $49ac0000}
+{$ELSE}
+{$IMAGEBASE $49ac0000} // this is ignored with FPC, must be set via the command line
+{$ENDIF}
+library shlext;
+
+uses
+ Windows, shlcom, shlipc, m_api;
+
+// use the registry to store the COM information needed by the shell
+
+function DllRegisterServer: HResult; stdcall;
+var
+ szData: PChar;
+ hRegKey: HKEY;
+begin
+
+{$IFDEF INSTALLER_REGISTER}
+ Result := S_OK;
+{$ELSE}
+ // progID
+ szData := 'shlext (1.0.6.6) - shell context menu support for Miranda v0.3.0.0+';
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT, 'miranda.shlext', REG_SZ, szData, Length(szData)) then
+ begin
+ // CLSID related to ProgID
+ szData := '{72013A26-A94C-11d6-8540-A5E62932711D}';
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT, 'miranda.shlext\CLSID', REG_SZ, szData, Length(szData)) then
+ begin
+ // CLSID link back to progID
+ szData := 'miranda.shlext';
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT,
+ 'CLSID\{72013A26-A94C-11d6-8540-A5E62932711D}', REG_SZ, szData, Length(szData)) then
+ begin
+ // CLSID link back to ProgID under \ProgID again?
+ szData := 'miranda.shlext';
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT,
+ 'CLSID\{72013A26-A94C-11d6-8540-A5E62932711D}\ProgID', REG_SZ, szData, Length(szData)) then
+ begin
+ GetMem(szData, MAX_PATH);
+ GetModuleFileName(hInstance, szData, MAX_PATH - 1);
+ Result := RegSetValue(HKEY_CLASSES_ROOT,
+ 'CLSID\{72013A26-A94C-11d6-8540-A5E62932711D}\InprocServer32', REG_SZ, szData, Length(szData));
+ FreeMem(szData);
+ if Result = ERROR_SUCCESS then
+ begin
+ // have to add threading model
+ szData := 'CLSID\{72013A26-A94C-11d6-8540-A5E62932711D}\InprocServer32';
+ Result := RegCreateKeyEx(HKEY_CLASSES_ROOT, szData, 0, nil, 0,
+ KEY_SET_VALUE or KEY_CREATE_SUB_KEY, nil, hRegKey, nil);
+ if Result = ERROR_SUCCESS then
+ begin
+ szData := 'Apartment';
+ RegSetValueEx(hRegKey, 'ThreadingModel', 0, REG_SZ, PByte(szData), Length(szData) + 1);
+ RegCloseKey(hRegKey);
+ // write which file types to show under
+ szData := '{72013A26-A94C-11d6-8540-A5E62932711D}';
+ // note that *\ should use AllFilesystemObjects for 4.71+
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT,
+ '*\shellex\ContextMenuHandlers\miranda.shlext', REG_SZ, szData, Length(szData)) then
+ begin
+ // don't support directories
+ if ERROR_SUCCESS = RegSetValue(HKEY_CLASSES_ROOT,
+ 'Directory\shellex\ContextMenuHandlers\miranda.shlext', REG_SZ, szData,
+ Length(szData)) then
+ begin
+ Result := S_OK;
+ // have to add to the approved list under NT/2000/XP with {CLSID}="<description>"
+ szData := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved';
+ Result := RegCreateKeyEx(HKEY_LOCAL_MACHINE, szData, 0, nil, 0,
+ KEY_SET_VALUE or KEY_CREATE_SUB_KEY, nil, hRegKey, nil);
+ if Result = ERROR_SUCCESS then
+ begin
+ szData := 'shlext (1.0.6.6) - context menu support for Miranda v0.3.0.0+';
+ RegSetValueEx(hRegKey, '{72013A26-A94C-11d6-8540-A5E62932711D}', 0, REG_SZ,
+ PByte(szData), Length(szData) + 1);
+ RegCloseKey(hRegKey);
+ end; // if
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ end
+ else
+ Result := E_FAIL;
+ //
+{$ENDIF}
+end;
+
+function DllUnregisterServer: HResult; stdcall;
+begin
+ Result := RemoveCOMRegistryEntries();
+end;
+
+// - miranda section ----
+
+const
+
+ COMREG_UNKNOWN = $00000000;
+ COMREG_OK = $00000001;
+ COMREG_APPROVED = $00000002;
+
+function IsCOMRegistered: Integer;
+var
+ hRegKey: HKEY;
+ lpType: Integer;
+begin
+ Result := 0;
+ // these arent the BEST checks in the world
+ if ERROR_SUCCESS = RegOpenKeyEx(HKEY_CLASSES_ROOT, 'miranda.shlext', 0, KEY_READ, hRegKey)
+ then
+ begin
+ Result := Result or COMREG_OK;
+ RegCloseKey(hRegKey);
+ end; // if
+ lpType := REG_SZ;
+ if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE,
+ 'Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', 0, KEY_READ, hRegKey)
+ then
+ begin
+ if ERROR_SUCCESS = RegQueryValueEx(hRegKey, '{72013A26-A94C-11d6-8540-A5E62932711D}', nil,
+ @lpType, nil, nil) then
+ begin
+ Result := Result or COMREG_APPROVED;
+ end; // if
+ RegCloseKey(hRegKey);
+ end; // if
+end;
+
+procedure AutoSize(hwnd: THandle);
+var
+ szBuf: array [0 .. MAX_PATH] of Char;
+ DC: HDC;
+ tS: TSize;
+ i: Integer;
+ hFont, hOldFont: THandle;
+begin
+ DC := GetDC(hwnd);
+ hFont := GetStockObject(DEFAULT_GUI_FONT);
+ hOldFont := SelectObject(DC, hFont);
+ i := GetWindowText(hwnd, szBuf, MAX_PATH);
+ GetTextExtentPoint32(DC, szBuf, i, tS);
+ SelectObject(DC, hOldFont);
+ DeleteObject(hFont);
+ ReleaseDC(hwnd, DC);
+ SetWindowPos(hwnd, HWND_BOTTOM, 0, 0, tS.cx + 10, tS.cy, SWP_NOMOVE or SWP_FRAMECHANGED);
+end;
+
+function OptDialogProc(hwndDlg: THandle; wMsg: Integer; wParam: wParam; lParam: lParam): BOOL; stdcall;
+// don't wanna bring in CommCtrl just for a few constants
+const
+{$IFNDEF FPC}
+ WM_INITDIALOG = $0110;
+ WM_COMMAND = $0111;
+ WM_USER = $0400;
+ WM_NOTIFY = $004E;
+{$ENDIF}
+ { propsheet notifications/msessages }
+ // PSN_APPLY = (-200) - 2;
+ PSM_CHANGED = WM_USER + 104;
+ { button styles }
+ BCM_SETSHIELD = ( { BCM_FIRST } $1600 + $000C);
+ { hotkey }
+ // bring in the IDC's and storage key names
+{$DEFINE SHL_IDC}
+{$DEFINE SHL_KEYS}
+{$INCLUDE shlc.inc}
+{$UNDEF SHL_KEYS}
+{$UNDEF SHL_IDC}
+const
+ COM_OKSTR: array [Boolean] of PChar = ('Problem, registration missing/deleted.',
+ 'Successfully created shell registration.');
+ COM_APPROVEDSTR: array [Boolean] of PChar = ('Not Approved', 'Approved');
+var
+ comReg: Integer;
+ iCheck: Integer;
+ szBuf: array [0 .. MAX_PATH] of Char;
+ cgs: TDBCONTACTGETSETTING;
+begin
+ Result := wMsg = WM_INITDIALOG;
+ case wMsg of
+ WM_NOTIFY:
+ begin
+ { * FP 2.2.2 seems to have a bug, 'Code' is supposed to be signed
+ but isn't signed, so when comparing -202 (=PSN_APPLY) It doesn't work
+ so here, -202 is converted into hex, what you are looking at is the
+ code == PSN_APPLY check. * }
+ if $FFFFFF36 = pNMHDR(lParam)^.code then
+ begin
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_UseGroups,
+ IsDlgButtonChecked(hwndDlg, IDC_USEGROUPS));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_UseCListSetting,
+ IsDlgButtonChecked(hwndDlg, IDC_CLISTGROUPS));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoProfile,
+ IsDlgButtonChecked(hwndDlg, IDC_NOPROF));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_UseHITContacts,
+ IsDlgButtonChecked(hwndDlg, IDC_SHOWFULL));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_UseHIT2Contacts,
+ IsDlgButtonChecked(hwndDlg, IDC_SHOWINVISIBLES));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoIcons,
+ IsDlgButtonChecked(hwndDlg, IDC_USEOWNERDRAW));
+ DBWriteContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoOffline,
+ IsDlgButtonChecked(hwndDlg, IDC_HIDEOFFLINE));
+ end; // if
+ end;
+ WM_INITDIALOG:
+ begin
+ TranslateDialogDefault(hwndDlg);
+ comReg := IsCOMRegistered();
+ FillChar(szBuf, MAX_PATH, 0);
+ lstrcat(szBuf, Translate(COM_OKSTR[comReg and COMREG_OK = COMREG_OK]));
+ lstrcat(szBuf, ' (');
+ lstrcat(szBuf, Translate(COM_APPROVEDSTR[comReg and
+ COMREG_APPROVED = COMREG_APPROVED]));
+ lstrcat(szBuf, ')');
+ SetWindowText(GetDlgItem(hwndDlg, IDC_STATUS), szBuf);
+ // auto size the static windows to fit their text
+ // they're rendering in a font not selected into the DC.
+ AutoSize(GetDlgItem(hwndDlg, IDC_CAPMENUS));
+ AutoSize(GetDlgItem(hwndDlg, IDC_CAPSTATUS));
+ AutoSize(GetDlgItem(hwndDlg, IDC_CAPSHLSTATUS));
+ // show all the options
+ iCheck := DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseGroups, BST_UNCHECKED);
+ CheckDlgButton(hwndDlg, IDC_USEGROUPS, iCheck);
+ EnableWindow(GetDlgItem(hwndDlg, IDC_CLISTGROUPS), iCheck = BST_CHECKED);
+ CheckDlgButton(hwndDlg, IDC_CLISTGROUPS,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseCListSetting, BST_UNCHECKED));
+ CheckDlgButton(hwndDlg, IDC_NOPROF,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoProfile, BST_UNCHECKED));
+ CheckDlgButton(hwndDlg, IDC_SHOWFULL,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHITContacts, BST_UNCHECKED));
+ CheckDlgButton(hwndDlg, IDC_SHOWINVISIBLES,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_UseHIT2Contacts, BST_UNCHECKED));
+ CheckDlgButton(hwndDlg, IDC_USEOWNERDRAW,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoIcons, BST_UNCHECKED));
+ CheckDlgButton(hwndDlg, IDC_HIDEOFFLINE,
+ DBGetContactSettingByte(0, SHLExt_Name, SHLExt_ShowNoOffline, BST_UNCHECKED));
+ // give the Remove button a Vista icon
+ SendMessage(GetDlgItem(hwndDlg, IDC_REMOVE), BCM_SETSHIELD, 0, 1);
+ end;
+ WM_COMMAND:
+ begin
+ // don't send the changed message if remove is clicked
+ if LOWORD(wParam) <> IDC_REMOVE then
+ begin
+ SendMessage(GetParent(hwndDlg), PSM_CHANGED, 0, 0);
+ end; // if
+ case LOWORD(wParam) of
+ IDC_USEGROUPS:
+ begin
+ EnableWindow(GetDlgItem(hwndDlg, IDC_CLISTGROUPS),
+ BST_CHECKED = IsDlgButtonChecked(hwndDlg, IDC_USEGROUPS));
+ end; // if
+ IDC_REMOVE:
+ begin
+ if IDYES = MessageBoxW(0,
+ TranslateW(
+ 'Are you sure? this will remove all the settings stored in your database and all registry entries created for shlext to work with Explorer'),
+ TranslateW('Disable/Remove shlext'), MB_YESNO or MB_ICONQUESTION) then
+ begin
+ cgs.szModule := SHLExt_Name;
+
+ cgs.szSetting := SHLExt_UseGroups;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_UseCListSetting;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_UseHITContacts;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_UseHIT2Contacts;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_ShowNoProfile;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_ShowNoIcons;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ cgs.szSetting := SHLExt_ShowNoOffline;
+ CallService(MS_DB_CONTACT_DELETESETTING, 0, TLPARAM(@cgs));
+
+ (* remove from Explorer *)
+ // DllUnregisterServer();
+ CheckUnregisterServer();
+ (* show all the settings have gone... *)
+ SendMessage(hwndDlg, WM_INITDIALOG, 0, 0);
+ end; // if
+ end; // if
+ end; // case
+ // LOWORD(wParam) == IDC_*
+ end; { outercase }
+ end; // case
+end;
+
+function InitialiseOptionPages(wParam: wParam; lParam: lParam): int; cdecl;
+const
+ IDD_SHLOPTS = 101;
+var
+ optDialog: TOPTIONSDIALOGPAGE;
+begin
+ Result := 0;
+ FillChar(optDialog, sizeof(TOPTIONSDIALOGPAGE), 0);
+ optDialog.cbSize := sizeof(TOPTIONSDIALOGPAGE);
+ optDialog.flags := ODPF_BOLDGROUPS;
+ optDialog.groupPosition := 0;
+ optDialog.szGroup.a := 'Plugins';
+ optDialog.position := -1066;
+ optDialog.szTitle.a := Translate('Shell context menus');
+ optDialog.pszTemplate := MAKEINTRESOURCE(IDD_SHLOPTS);
+{$IFDEF VER140}
+ optDialog.hInstance := hInstance;
+{$ELSE}
+ optDialog.hInstance := System.hInstance;
+{$ENDIF}
+ optDialog.pfnDlgProc := @OptDialogProc;
+
+ Options_AddPage(wParam,@optDialog);
+end;
+
+function MirandaPluginInfoEx(mirandaVersion: DWORD): PPLUGININFOEX; cdecl;
+begin
+ Result := nil;
+ { fill in plugininfo }
+ PluginInfo.cbSize := sizeof(PluginInfo);
+ PluginInfo.shortName := 'Shell context menus for transfers';
+ PluginInfo.version := PLUGIN_MAKE_VERSION(2, 0, 1, 2);
+{$IFDEF FPC}
+ PluginInfo.description :=
+ 'Click ''n'' send support from Explorer/Common dialogs/Desktop, Right click on a file/folder to be presented with all your Miranda contact lists and then select the profile/contact you want to send to. Built on ' +
+ {$I %DATE%} +' at ' + {$I %TIME%} +' with FPC ' + {$I %FPCVERSION%};
+{$ELSE}
+ PluginInfo.description := '';
+{$ENDIF}
+ PluginInfo.author := 'egoDust';
+ PluginInfo.authorEmail := 'egodust@users.sourceforge.net';
+ PluginInfo.copyright := '(c) 2009 Sam Kothari (egoDust)';
+ PluginInfo.homePage := 'http://addons.miranda-im.org/details.php?action=viewfile&id=534';
+ PluginInfo.flags := 0;
+ { This UUID is fetched twice }
+ CopyMemory(@PluginInfo.uuid, @CLSID_ISHLCOM, sizeof(TMUUID));
+ { return info }
+ Result := @PluginInfo;
+end;
+
+function Load(): int; cdecl;
+begin
+ Result := 0;
+ InvokeThreadServer;
+ HookEvent(ME_OPT_INITIALISE, InitialiseOptionPages);
+ DllRegisterServer();
+ CheckRegisterServer();
+ // DisableThreadLibraryCalls(System.hInstance);
+end;
+
+function Unload: int; cdecl;
+begin
+ Result := 0;
+end;
+
+{$R shldlgs.res}
+
+exports
+
+ MirandaPluginInfoEx, Load, Unload;
+
+exports
+
+ DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer;
+
+begin
+
+end. diff --git a/plugins/!NotAdopted/ShlExt/shlicons.pas b/plugins/!NotAdopted/ShlExt/shlicons.pas new file mode 100644 index 0000000000..195033ae8d --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shlicons.pas @@ -0,0 +1,168 @@ +unit shlicons; +
+interface
+
+uses
+ Windows;
+
+type
+
+ PVTable_IWICBitmap = ^TVTable_IWICBitmap;
+
+ TVTable_IWICBitmap = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: function(Self: Pointer): Cardinal; stdcall;
+ Release: function(Self: Pointer): Cardinal; stdcall;
+ { IWICBitmapSource }
+ GetSize: function(Self: Pointer; var Width, Height: LongInt): HResult; stdcall;
+ GetPixelFormat: Pointer;
+ GetResolution: Pointer;
+ CopyPalette: Pointer;
+ CopyPixels: function(Self: Pointer; prc: Pointer; cbStride, cbBufferSize: LongWord;
+ pbBuffer: PByte): HResult; stdcall;
+ { IWICBitmap }
+ // .... not used
+
+ end;
+
+ PWICBitmap_Interface = ^TWICBitmap_Interface;
+
+ TWICBitmap_Interface = record
+ ptrVTable: PVTable_IWICBitmap;
+ end;
+
+ // bare minmum interface to ImagingFactory
+
+ PVTable_ImagingFactory = ^TVTable_ImagingFactory;
+
+ TVTable_ImagingFactory = record
+ { IUnknown }
+ QueryInterface: Pointer;
+ AddRef: function(Self: Pointer): Cardinal; stdcall;
+ Release: function(Self: Pointer): Cardinal; stdcall;
+ { ImagingFactory }
+ CreateDecoderFromFilename: Pointer;
+ CreateDecoderFromStream: Pointer;
+ CreateDecoderFromFileHandle: Pointer;
+ CreateComponentInfo: Pointer;
+ CreateDecoder: Pointer;
+ CreateEncoder: Pointer;
+ CreatePalette: Pointer;
+ CreateFormatConverter: Pointer;
+ CreateBitmapScaler: Pointer;
+ CreateBitmapClipper: Pointer;
+ CreateBitmapFlipRotator: Pointer;
+ CreateStream: Pointer;
+ CreateColorContext: Pointer;
+ CreateColorTransformer: Pointer;
+ CreateBitmap: Pointer;
+ CreateBitmapFromSource: Pointer;
+ CreateBitmapFromSourceRect: Pointer;
+ CreateBitmapFromMemory: Pointer;
+ CreateBitmapFromHBITMAP: Pointer;
+ CreateBitmapFromHICON: function(Self: Pointer; hIcon: Windows.hIcon; var foo: Pointer)
+ : HResult; stdcall;
+ { rest ommited }
+ end;
+
+ PImageFactory_Interface = ^TImageFactory_Interface;
+
+ TImageFactory_Interface = record
+ ptrVTable: PVTable_ImagingFactory;
+ end;
+
+function ARGB_GetWorker: PImageFactory_Interface;
+
+function ARGB_BitmapFromIcon(Factory: PImageFactory_Interface; hdc: Windows.hdc; hIcon: hIcon): HBitmap;
+
+implementation
+
+{$DEFINE SHLCOM}
+{$DEFINE COM_STRUCTS}
+{$DEFINE COMAPI}
+{$INCLUDE shlc.inc}
+{$UNDEF SHLCOM}
+{$UNDEF COM_STRUCTS}
+{$UNDEF COMAPI}
+{
+ The following implementation has been ported from:
+
+ http://web.archive.org/web/20080121112802/http://shellrevealed.com/blogs/shellblog/archive/2007/02/06/Vista-Style-Menus_2C00_-Part-1-_2D00_-Adding-icons-to-standard-menus.aspx
+
+ It uses WIC (Windows Imaging Codec) to convert the given Icon into a bitmap in ARGB format, this is required
+ by Windows for use as an icon (but in bitmap format), so that Windows draws everything (including theme)
+ so we don't have to.
+
+ Why didn't they just do this themselves? ...
+}
+
+{
+ The object returned from this function has to be released using the QI COM interface, don't forget.
+ Note this function won't work on anything where WIC isn't installed (XP can have it installed, but not by default)
+ anything less won't work.
+}
+function ARGB_GetWorker: PImageFactory_Interface;
+var
+ hr: HResult;
+begin
+ hr := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER,
+ IID_WICImagingFactory, Result);
+end;
+
+function ARGB_BitmapFromIcon(Factory: PImageFactory_Interface; hdc: Windows.hdc; hIcon: hIcon): HBitmap;
+var
+ bmi: BITMAPINFO;
+ hr: HResult;
+ bitmap: PWICBitmap_Interface;
+ cx, cy: LongInt;
+ pbBuffer: PByte;
+ hBmp: HBitmap;
+ cbStride, cbBuffer: LongInt;
+begin
+ { This code gives an icon to WIC and gets a bitmap object in return, it then creates a DIB section
+ which is 32bits and the same H*W as the icon. It then asks the bitmap object to copy itself into the DIB }
+ Result := 0;
+ ZeroMemory(@bmi, sizeof(bmi));
+ bmi.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
+ bmi.bmiHeader.biPlanes := 1;
+ bmi.bmiHeader.biCompression := BI_RGB;
+
+ bmi.bmiHeader.biBitCount := 32;
+
+ hr := Factory^.ptrVTable^.CreateBitmapFromHICON(Factory, hIcon, pointer(bitmap));
+ if hr = S_OK then
+ begin
+ hr := bitmap^.ptrVTable^.GetSize(bitmap, cx, cy);
+ if hr = S_OK then
+ begin
+
+ bmi.bmiHeader.biWidth := cx;
+ bmi.bmiHeader.biHeight := -cy;
+
+ hBmp := CreateDIBSection(hdc, bmi, DIB_RGB_COLORS, pointer(pbBuffer), 0, 0);
+ if hBmp <> 0 then
+ begin
+ cbStride := cx * sizeof(DWORD); // ARGB = DWORD
+ cbBuffer := cy * cbStride;
+ // note: the pbBuffer memory is owned by the DIB and will be freed when the bitmap is released
+ hr := bitmap^.ptrVTable^.CopyPixels(bitmap, nil, cbStride, cbBuffer, pbBuffer);
+ if hr = S_OK then
+ begin
+ Result := hBmp;
+ end
+ else
+ begin
+ // the copy failed, delete the DIB
+ DeleteObject(hBmp);
+ end;
+ end;
+ end;
+ // release the bitmap object now
+ bitmap^.ptrVTable^.Release(bitmap);
+ bitmap := nil;
+ end;
+
+end;
+
+end. diff --git a/plugins/!NotAdopted/ShlExt/shlipc.pas b/plugins/!NotAdopted/ShlExt/shlipc.pas new file mode 100644 index 0000000000..17ab511e52 --- /dev/null +++ b/plugins/!NotAdopted/ShlExt/shlipc.pas @@ -0,0 +1,394 @@ +unit shlIPC; +
+interface
+
+uses
+
+ m_api, Windows;
+
+const
+
+ REPLY_FAIL = $88888888;
+ REPLY_OK = $00000000;
+
+ REQUEST_ICONS = 1;
+ REQUEST_GROUPS = (REQUEST_ICONS) shl 1;
+ REQUEST_CONTACTS = (REQUEST_GROUPS) shl 1;
+ REQUEST_XFRFILES = (REQUEST_CONTACTS) shl 1;
+ REQUEST_NEWICONS = (REQUEST_XFRFILES) shl 1;
+ REQUEST_CLEARMRU = (REQUEST_NEWICONS) shl 1;
+
+ ICONS_NOTIMPL = $00000008;
+ GROUPS_NOTIMPL = $00000080;
+ CONTACTS_NOTIMPL = $00000800;
+
+ STATUS_PROFILENAME = 2;
+
+
+ // there maybe more than one reason why any request type wasn't returned
+
+type
+
+ { this can be a group entry, if it is, hContact = <index>
+ the string contains the full group path }
+
+ PSlotIPC = ^TSlotIPC;
+
+ TSlotIPC = packed record
+ cbSize: Byte;
+ fType: int; // a REQUEST_* type
+ Next: PSlotIPC;
+ hContact: THandle;
+ hProto: Cardinal; // hash of the protocol the user is on
+ hGroup: Cardinal; // hash of the entire path (not defined for REQUEST_GROUPS slots)
+ Status: Word;
+ // only used for contacts -- can be STATUS_PROFILENAME -- but that is because returning the profile name is optional
+ MRU: Byte; // if set, contact has been recently used
+ cbStrSection: int;
+ end;
+
+ // if the slot contains a nickname, after the NULL, there is another NULL or a group path string
+
+ PSlotProtoIcons = ^TSlotProtoIcons;
+
+ TSlotProtoIcons = packed record
+ pid: Cardinal; // pid of Miranda this protocol was on
+ hProto: Cardinal; // hash of the protocol
+ hIcons: array [0 .. 9] of HICON; // each status in order of ID_STATUS_*
+ hBitmaps: array [0 .. 9] of HBITMAP; // each status "icon" as a bitmap
+ end;
+
+ TSlotProtoIconsArray = array [0 .. 0] of TSlotProtoIcons;
+ // the process space the thread is running in WILL use a different mapping
+ // address than the client's process space, addresses need to be adjusted
+ // to the client's process space.. this is done by the following means :
+
+ //
+ // new_addr := (old_address - serverbase) + client base
+ //
+ // this isn't the best of solutions, the link list should be a variant array
+ // without random access, which would mean each element's different
+ // size would need to be computed each time it is accessed or read past
+
+ PHeaderIPC = ^THeaderIPC;
+
+ THeaderIPC = record
+ cbSize: Cardinal;
+ dwVersion: Cardinal;
+ pServerBaseAddress: Pointer;
+ pClientBaseAddress: Pointer;
+ fRequests: Cardinal;
+ dwFlags: Cardinal;
+ Slots: Cardinal;
+ Param: Cardinal;
+ SignalEventName: array [0 .. 63] of Char;
+ // Translate() won't work via Explorer
+ MirandaName: array [0 .. 63] of Char;
+ MRUMenuName: array [0 .. 63] of Char; // for the MRU menu itself
+ ClearEntries: array [0 .. 63] of Char; // for the "clear entries"
+ IconsBegin: PSlotIPC;
+ ContactsBegin: PSlotIPC;
+ GroupsBegin: PSlotIPC;
+ NewIconsBegin: PSlotIPC;
+ // start of an flat memory stack, which is referenced as a linked list
+ DataSize: int;
+ DataPtr: PSlotIPC;
+ DataPtrEnd: PSlotIPC;
+ DataFramePtr: Pointer;
+ end;
+
+const
+ HIPC_NOICONS = 1;
+
+procedure ipcPrepareRequests(ipcPacketSize: int; pipch: PHeaderIPC; fRequests: Cardinal);
+function ipcSendRequest(hSignal, hWaitFor: THandle; pipch: PHeaderIPC; dwTimeoutMsecs: DWORD): Cardinal;
+function ipcAlloc(pipch: PHeaderIPC; nSize: Integer): PSlotIPC;
+procedure ipcFixupAddresses(FromServer: LongBool; pipch: PHeaderIPC);
+
+type
+
+ TStrTokRec = record
+ szStr: PChar;
+ szSet: set of Char;
+ // need a delimiter after the token too?, e.g. FOO^BAR^ if FOO^BAR
+ // is the string then only FOO^ is returned, could cause infinite loops
+ // if the condition isn't accounted for thou.
+ bSetTerminator: Boolean;
+ end;
+
+function StrTok(var strr: TStrTokRec): PChar;
+
+type
+
+ PGroupNode = ^TGroupNode;
+
+ TGroupNode = record
+ Left, Right, _prev, _next: PGroupNode;
+ Depth: Cardinal;
+ Hash: Cardinal; // hash of the group name alone
+ szGroup: PChar;
+ cchGroup: Integer;
+ hMenu: THandle;
+ hMenuGroupID: Integer;
+ dwItems: Cardinal;
+ end;
+
+ PGroupNodeList = ^TGroupNodeList;
+
+ TGroupNodeList = record
+ First, Last: PGroupNode;
+ end;
+
+function AllocGroupNode(list: PGroupNodeList; Root: PGroupNode; Depth: Integer): PGroupNode;
+function FindGroupNode(P: PGroupNode; const Hash, Depth: dword): PGroupNode;
+
+type
+
+ // a contact can never be a submenu too.
+ TSlotDrawType = (dtEntry, dtGroup, dtContact, dtCommand);
+ TSlotDrawTypes = set of TSlotDrawType;
+
+ PMenuDrawInfo = ^TMenuDrawInfo;
+
+ TMenuCommandCallback = function(pipch: PHeaderIPC; // IPC header info, already mapped
+ hWorkThreadEvent: THandle; // event object being waited on on miranda thread
+ hAckEvent: THandle; // ack event object that has been created
+ psd: PMenuDrawInfo // command/draw info
+ ): Integer; stdcall;
+
+ TMenuDrawInfo = record
+ szText: PChar;
+ szProfile: PChar;
+ cch: Integer;
+ wID: Integer; // should be the same as the menu item's ID
+ fTypes: TSlotDrawTypes;
+ hContact: THandle;
+ hStatusIcon: THandle;
+ // HICON from Self^.ProtoIcons[index].hIcons[status]; Do not DestroyIcon()
+ hStatusBitmap: THandle; // HBITMAP, don't free.
+ pid: Integer;
+ MenuCommandCallback: TMenuCommandCallback; // dtCommand must be set also.
+ end;
+
+implementation
+
+function FindGroupNode(P: PGroupNode; const Hash, Depth: dword): PGroupNode;
+begin
+ Result := P;
+ while Result <> nil do
+ begin
+ if (Result^.Hash = Hash) and (Result^.Depth = Depth) then
+ Exit;
+ If Result^.Left <> nil then
+ begin
+ P := Result;
+ Result := FindGroupNode(Result^.Left, Hash, Depth);
+ If Result <> nil then
+ Exit;
+ Result := P;
+ end;
+ Result := Result^.Right;
+ end; // while
+end;
+
+function AllocGroupNode(list: PGroupNodeList; Root: PGroupNode; Depth: Integer): PGroupNode;
+begin
+ New(Result);
+ Result^.Left := nil;
+ Result^.Right := nil;
+ Result^.Depth := Depth;
+ if Depth > 0 then
+ begin
+ if Root^.Left = nil then
+ Root^.Left := Result
+ else
+ begin
+ Root := Root^.Left;
+ while Root^.Right <> nil do
+ Root := Root^.Right;
+ Root^.Right := Result;
+ end;
+ end
+ else
+ begin
+ if list^.First = nil then
+ list^.First := Result;
+ if list^.Last <> nil then
+ list^.Last^.Right := Result;
+ list^.Last := Result;
+ end; // if
+end;
+
+procedure ipcPrepareRequests(ipcPacketSize: int; pipch: PHeaderIPC; fRequests: Cardinal);
+begin
+ // some fields may already have values like the event object name to open
+ pipch^.cbSize := sizeof(THeaderIPC);
+ pipch^.dwVersion := PLUGIN_MAKE_VERSION(2, 0, 1, 2);
+ pipch^.dwFlags := 0;
+ pipch^.pServerBaseAddress := nil;
+ pipch^.pClientBaseAddress := pipch;
+ pipch^.fRequests := fRequests;
+ pipch^.Slots := 0;
+ pipch^.IconsBegin := nil;
+ pipch^.ContactsBegin := nil;
+ pipch^.GroupsBegin := nil;
+ pipch^.NewIconsBegin := nil;
+ pipch^.DataSize := ipcPacketSize - pipch^.cbSize;
+ // the server side will adjust these pointers as soon as it opens
+ // the mapped file to it's base address, these are set 'ere because ipcAlloc()
+ // maybe used on the client side and are translated by the server side.
+ // ipcAlloc() is used on the client side when transferring filenames
+ // to the ST thread.
+ uint_ptr(pipch^.DataPtr) := uint_ptr(pipch) + sizeof(THeaderIPC);
+ uint_ptr(pipch^.DataPtrEnd) := uint_ptr(pipch^.DataPtr) + pipch^.DataSize;
+ pipch^.DataFramePtr := pipch^.DataPtr;
+ // fill the data area
+ FillChar(pipch^.DataPtr^, pipch^.DataSize, 0);
+end;
+
+function ipcSendRequest(hSignal, hWaitFor: THandle; pipch: PHeaderIPC; dwTimeoutMsecs: DWORD): Cardinal;
+begin
+ { signal ST to work }
+ SetEvent(hSignal);
+ { wait for reply, it should open a handle to hWaitFor... }
+ while True do
+ begin
+ Result := WaitForSingleObjectEx(hWaitFor, dwTimeoutMsecs, True);
+ if Result = WAIT_OBJECT_0 then
+ begin
+ Result := pipch^.fRequests;
+ break;
+ end
+ else if Result = WAIT_IO_COMPLETION then
+ begin
+ (* APC call... *)
+ end
+ else
+ begin
+ Result := REPLY_FAIL;
+ break;
+ end; // if
+ end; // while
+end;
+
+function ipcAlloc(pipch: PHeaderIPC; nSize: Integer): PSlotIPC;
+var
+ PSP: uint_ptr;
+begin
+ Result := nil;
+ { nSize maybe zero, in that case there is no string section --- }
+ PSP := uint_ptr(pipch^.DataFramePtr) + sizeof(TSlotIPC) + nSize;
+ { is it past the end? }
+ If PSP >= uint_ptr(pipch^.DataPtrEnd) then
+ Exit;
+ { return the pointer }
+ Result := pipch^.DataFramePtr;
+ { set up the item }
+ Result^.cbSize := sizeof(TSlotIPC);
+ Result^.cbStrSection := nSize;
+ { update the frame ptr }
+ pipch^.DataFramePtr := Pointer(PSP);
+ { let this item jump to the next yet-to-be-allocated-item which should be null anyway }
+ Result^.Next := Pointer(PSP);
+end;
+
+procedure ipcFixupAddresses(FromServer: LongBool; pipch: PHeaderIPC);
+var
+ pct: PSlotIPC;
+ q: ^PSlotIPC;
+ iServerBase: int_ptr;
+ iClientBase: int_ptr;
+begin
+ if pipch^.pServerBaseAddress = pipch^.pClientBaseAddress then
+ Exit;
+ iServerBase := int_ptr(pipch^.pServerBaseAddress);
+ iClientBase := int_ptr(pipch^.pClientBaseAddress);
+ // fix up all the pointers in the header
+ if pipch^.IconsBegin <> nil then
+ begin
+ uint_ptr(pipch^.IconsBegin) := (uint_ptr(pipch^.IconsBegin) - iServerBase) + iClientBase;
+ end; // if
+
+ if pipch^.ContactsBegin <> nil then
+ begin
+ uint_ptr(pipch^.ContactsBegin) := (uint_ptr(pipch^.ContactsBegin) - iServerBase) + iClientBase;
+ end; // if
+
+ if pipch^.GroupsBegin <> nil then
+ begin
+ uint_ptr(pipch^.GroupsBegin) := (uint_ptr(pipch^.GroupsBegin) - iServerBase) + iClientBase;
+ end; // if
+
+ if pipch^.NewIconsBegin <> nil then
+ begin
+ uint_ptr(pipch^.NewIconsBegin) := (uint_ptr(pipch^.NewIconsBegin) - iServerBase) +
+ iClientBase;
+ end;
+ uint_ptr(pipch^.DataPtr) := (uint_ptr(pipch^.DataPtr) - iServerBase) + iClientBase;
+ uint_ptr(pipch^.DataPtrEnd) := (uint_ptr(pipch^.DataPtrEnd) - iServerBase) + iClientBase;
+ uint_ptr(pipch^.DataFramePtr) := (uint_ptr(pipch^.DataFramePtr) - iServerBase) + iClientBase;
+ // and the link list
+ pct := pipch^.DataPtr;
+ while (pct <> nil) do
+ begin
+ // the first pointer is already fixed up, have to get a pointer
+ // to the next pointer and modify where it jumps to
+ q := @pct^.Next;
+ if q^ <> nil then
+ begin
+ uint_ptr(q^) := (uint_ptr(q^) - iServerBase) + iClientBase;
+ end; // if
+ pct := q^;
+ end; // while
+end;
+
+function StrTok(var strr: TStrTokRec): PChar;
+begin
+ Result := nil;
+ { don't allow #0's in sets or null strings }
+ If (strr.szStr = nil) or (#0 in strr.szSet) then
+ Exit;
+ { strip any leading delimiters }
+ while strr.szStr^ in strr.szSet do
+ Inc(strr.szStr);
+ { end on null? full of delimiters }
+ If strr.szStr^ = #0 then
+ begin
+ // wipe out the pointer
+ strr.szStr := nil;
+ Exit;
+ end;
+ { store the start of the token }
+ Result := strr.szStr;
+ { process til start of another delim }
+ while not(strr.szStr^ in strr.szSet) do
+ begin
+ { don't process past the real null, is a delimter required to cap the token? }
+ If strr.szStr^ = #0 then
+ break;
+ Inc(strr.szStr);
+ end;
+ { if we end on a null stop reprocessin' }
+ If strr.szStr^ = #0 then
+ begin
+ // no more tokens can be read
+ strr.szStr := nil;
+ // is a ending delimiter required?
+ If strr.bSetTerminator then
+ begin
+ // rollback
+ strr.szStr := Result;
+ Result := nil;
+ end;
+ //
+ end
+ else
+ begin
+ { mark the end of the token, may AV if a constant pchar is passed }
+ strr.szStr^ := #0;
+ { skip past this fake null for next time }
+ Inc(strr.szStr);
+ end;
+end;
+
+end. |
