[sword-cvs] sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls ActiveIMM_TLB.pas,NONE,1.1 Compilers.inc,NONE,1.1 ConvertUTF7.pas,NONE,1.1 TntButtons.pas,NONE,1.1 TntCheckLst.pas,NONE,1.1 TntExtCtrls.pas,NONE,1.1 TntGraphics.pas,NONE,1.1 TntGrids.pas,NONE,1.1 TntMenus.pas,NONE,1.1 TntThemeMgr.pas,NONE,1.1 TntWideStrPropHelper.pas,NONE,1.1 Readme.txt,1.1,1.2 TntClasses.pas,1.1,1.2 TntComCtrls.pas,1.1,1.2 TntControls.pas,1.1,1.2 TntForms.pas,1.1,1.2 TntStdCtrls.pas,1.1,1.2 Unicode.pas,1.1,1.2 ExampleUnicode.dof,1.1,NONE ExampleUnicode.dpr,1.1,NONE ExampleUnicode.res,1.1,NONE MainFrm.pas,1.1,NONE TntComCtrls.dcr,1.1,NONE TntDBCtrls.dcr,1.1,NONE TntDBCtrls.pas,1.1,NONE TntForms.dfm,1.1,NONE TntForms_Design.pas,1.1,NONE TntStdCtrls.dcr,1.1,NONE TntUnicodeVcl_D50.dof,1.1,NONE TntUnicodeVcl_D50.dpk,1.1,NONE TntUnicodeVcl_D50.res,1.1,NONE TntUnicodeVcl_D60.dof,1.1,NONE
sword@www.crosswire.org
sword@www.crosswire.org
Wed, 22 Jan 2003 17:02:46 -0700
- Previous message: [sword-cvs] sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/Example ExampleUnicode.cfg,NONE,1.1 ExampleUnicode.dof,NONE,1.1 ExampleUnicode.dpr,NONE,1.1 ExampleUnicode.res,NONE,1.1 MainFrm.dfm,NONE,1.1 MainFrm.pas,NONE,1.1
- Next message: [sword-cvs] sword/ideproj - New directory
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]
Update of /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls
In directory www:/tmp/cvs-serv22744/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls
Modified Files:
Readme.txt TntClasses.pas TntComCtrls.pas TntControls.pas
TntForms.pas TntStdCtrls.pas Unicode.pas
Added Files:
ActiveIMM_TLB.pas Compilers.inc ConvertUTF7.pas TntButtons.pas
TntCheckLst.pas TntExtCtrls.pas TntGraphics.pas TntGrids.pas
TntMenus.pas TntThemeMgr.pas TntWideStrPropHelper.pas
Removed Files:
ExampleUnicode.dof ExampleUnicode.dpr ExampleUnicode.res
MainFrm.pas TntComCtrls.dcr TntDBCtrls.dcr TntDBCtrls.pas
TntForms.dfm TntForms_Design.pas TntStdCtrls.dcr
TntUnicodeVcl_D50.dof TntUnicodeVcl_D50.dpk
TntUnicodeVcl_D50.res TntUnicodeVcl_D60.dof
Log Message:
Update TntUnicodeControls to that of January 18 2003
includes bcb projects for BCB5 and BCB6 that should be added to the respective sword workspaces
removed files that weren't need any more
needs tested for BCB5
updated BCB6 project that actually works will follow asap
--- NEW FILE: ActiveIMM_TLB.pas ---
unit ActiveIMM_TLB;
// ************************************************************************ //
// 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
[...1318 lines suppressed...]
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.
--- NEW FILE: Compilers.inc ---
//----------------------------------------------------------------------------------------------------------------------
// 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.
//
// 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 VER150}
{$define COMPILER_7}
{$define DELPHI}
{$define DELPHI_7}
{$endif}
{$ifdef VER140}
{$define COMPILER_6}
{$define DELPHI}
{$define DELPHI_6}
{$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 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_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}
//----------------------------------------------------------------------------------------------------------------------
--- NEW FILE: ConvertUTF7.pas ---
{*******************************************************}
{ The Delphi Unicode Controls Project }
{ }
{ http://home.ccci.org/wolbrink }
{ }
{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) }
{ }
{ Thanks to Francisco Leong for providing the Pascal }
{ conversion of ConvertUTF7.c (by David B. Goldsmith) }
{ }
{*******************************************************}
unit ConvertUTF7;
interface
function WideStringToUTF7(const W: WideString): AnsiString;
function UTF7ToWideString(const S: AnsiString; AllowInvalid: Boolean = False): WideString;
implementation
uses SysUtils;
resourcestring
SBufferOverflow = 'Buffer overflow';
SInvalidUTF7 = 'Invalid UTF7';
function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar;
var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean;
verbose: Boolean): Integer; forward;
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 Exception.Create(SBufferOverflow);
SetLength(Result, TargetStart - PAnsiChar(@Result[1]));
end;
end;
function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar;
var targetStart: PWideChar; targetEnd: PWideChar): Integer; forward;
function UTF7ToWideString(const S: AnsiString; AllowInvalid: Boolean = False): 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: if not AllowInvalid then
raise Exception.Create(SInvalidUTF7);
2: raise Exception.Create(SBufferOverflow);
end;
SetLength(Result, TargetStart - PWideChar(@Result[1]));
end;
end;
{ ======================================================= }
{ Translated by: CtoP version 1.2b }
{ }
{ From: Knowledge Software Ltd }
{ 32 Cove Rd, Farnborough, Hants, GU14 0EN, England }
{ }
{ Specialists in language translators and code generators }
{ }
{ cvtutf7.c 18:01:48 6 Jul 2001 }
{ ======================================================= }
{ ======================================================================= }
{ }
{ 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 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
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
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 }
initialization { cvtutf7 }
base64 := PAnsiChar(_base64);
direct := PAnsiChar(_direct);
optional := PAnsiChar(_optional);
spaces := PAnsiChar(_spaces);
end.
--- NEW FILE: TntButtons.pas ---
unit TntButtons;
interface
uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
ExtCtrls, CommCtrl, Buttons,
TntWideStrPropHelper, TntForms, TntControls, TntStdCtrls;
type
{TNT-WARN TSpeedButton}
TTntSpeedButton = class(TSpeedButton{TNT-ALLOW TSpeedButton})
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;
procedure UpdateInternalGlyphList;
protected
procedure Paint; override;
procedure DefineProperties(Filer: TFiler); 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})
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 DrawItem(const DrawItemStruct: TDrawItemStruct);
procedure UpdateInternalGlyphList;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
protected
procedure CreateWindowHandle(const Params: TCreateParams); override;
procedure DefineProperties(Filer: TFiler); 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);
implementation
uses SysUtils, TypInfo, {$IFDEF VER130} Consts, {$ELSE} RTLConsts, {$ENDIF}
{$IFDEF VER150} Themes, {$ENDIF} TntClasses, TntGraphics;
// 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_D5_D6_D7 = class
protected
FOriginal: TBitmap;
FGlyphList: TImageList;
FIndexs: array[TButtonState] of Integer;
FxxxxTransparentColor: TColor;
FNumGlyphs: TNumGlyphs;
end;
THackBitBtn_D5_D6_D7 = class(TButton{TNT-ALLOW TButton})
protected
FCanvas: TCanvas;
FGlyph: Pointer;
FxxxxStyle: TButtonStyle;
FxxxxKind: TBitBtnKind;
FxxxxLayout: TButtonLayout;
FxxxxSpacing: Integer;
FxxxxMargin: Integer;
IsFocused: Boolean;
end;
THackSpeedButton_D5_D6_D7 = class(TGraphicControl)
protected
FxxxxGroupIndex: Integer;
FGlyph: Pointer;
FxxxxDown: Boolean;
FDragging: Boolean;
end;
{$IFDEF VER130} // Delphi 5
THackButtonGlyph = THackButtonGlyph_D5_D6_D7;
THackBitBtn = THackBitBtn_D5_D6_D7;
THackSpeedButton = THackSpeedButton_D5_D6_D7;
{$ENDIF}
{$IFDEF VER140} // Delphi 6
THackButtonGlyph = THackButtonGlyph_D5_D6_D7;
THackBitBtn = THackBitBtn_D5_D6_D7;
THackSpeedButton = THackSpeedButton_D5_D6_D7;
{$ENDIF}
{$IFDEF VER150} // Delphi 7
THackButtonGlyph = THackButtonGlyph_D5_D6_D7;
THackBitBtn = THackBitBtn_D5_D6_D7;
THackSpeedButton = THackSpeedButton_D5_D6_D7;
{$ENDIF}
function GetButtonGlyphObject(Control: TControl): THackButtonGlyph;
begin
if Control is TTntBitBtn then
Result := THackBitBtn(Control).FGlyph
else if Control is TTntSpeedButton then
Result := THackSpeedButton(Control).FGlyph
else
raise Exception.Create('TNT Internal Error: wrong button class for GetButtonGlyphObject.');
end;
function TButtonGlyph_CreateButtonGlyph(Control: TControl; State: TButtonState): Integer;
var
ButtonGlyph: THackButtonGlyph;
NumGlyphs: Integer;
begin
ButtonGlyph := GetButtonGlyphObject(Control);
NumGlyphs := ButtonGlyph.FNumGlyphs;
if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
Result := ButtonGlyph.FIndexs[State];
if (Result = -1) then begin
if Control is TTntBitBtn then begin
TTntBitBtn(Control).UpdateInternalGlyphList;
end else if Control is TTntSpeedButton then begin
TTntSpeedButton(Control).UpdateInternalGlyphList;
end else
raise Exception.Create('TNT Internal Error: wrong button class for CreateButtonGlyph.');
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 VER150}
Details: TThemedElementDetails;
R: TRect;
Button: TThemedButton;
{$ENDIF}
begin
ButtonGlyph := GetButtonGlyphObject(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 VER150}
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);
begin
with Canvas do
begin
Brush.Style := bsClear;
if State = bsDisabled then
begin
OffsetRect(TextBounds, 1, 1);
Font.Color := clBtnHighlight;
Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TextBounds, -1, -1);
Font.Color := clBtnShadow;
Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
end else
Tnt_DrawTextW(Handle, PWideChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
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);
var
TextPos: TPoint;
ClientSize,
GlyphSize,
TextSize: TPoint;
TotalSize: TPoint;
Glyph: TBitmap;
NumGlyphs: Integer;
ButtonGlyph: THackButtonGlyph;
begin
ButtonGlyph := GetButtonGlyphObject(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
TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
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 VER150}
{ 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): TRect;
var
GlyphPos: TPoint;
begin
TButtonGlyph_CalcButtonLayout(Control, Canvas.Handle, Client, Offset, Caption, Layout, Margin,
Spacing, GlyphPos, Result, BiDiFlags);
TButtonGlyph_DrawButtonGlyph(Control, Canvas, GlyphPos, State, Transparent);
TButtonGlyph_DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
end;
{ TTntSpeedButton }
procedure TTntSpeedButton.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntSpeedButton.IsCaptionStored: Boolean;
begin
Result := TntIsCaptionStored(Self)
end;
function TTntSpeedButton.GetCaption: TWideCaption;
begin
Result := WideGetWindowText(Self);
end;
procedure TTntSpeedButton.SetCaption(const Value: TWideCaption);
begin
WideSetWindowText(Self, Value);
end;
function TTntSpeedButton.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntSpeedButton.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntSpeedButton.SetHint(const Value: WideString);
begin
WideSetWindowHint(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;
procedure TTntSpeedButton.UpdateInternalGlyphList;
begin
FPaintInherited := True;
try
Repaint;
finally
FPaintInherited := False;
end;
Invalidate;
Abort;
end;
procedure TTntSpeedButton.Paint;
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 VER150}
Button: TThemedButton;
ToolButton: TThemedToolBar;
Details: TThemedElementDetails;
{$ENDIF}
begin
if FPaintInherited then
inherited
else begin
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 VER150}
if ThemeServices.ThemesEnabled then
begin
PerformEraseBackground(Self, Canvas.Handle);
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));
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));
end;
end;
end;
{ TTntButton }
procedure TTntBitBtn.CreateWindowHandle(const Params: TCreateParams);
begin
CreateUnicodeHandle(Self, Params, 'BUTTON');
end;
procedure TTntBitBtn.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntBitBtn.IsCaptionStored: Boolean;
var
PropInfo: PPropInfo;
begin
// TTntBitBtn has it's own storage specifier, based upon the button kind
PropInfo := GetPropInfo(TBitBtn{TNT-ALLOW TBitBtn}, 'Caption');
if PropInfo = nil then
raise EPropertyError.CreateResFmt(PResStringRec(@SUnknownProperty), ['Caption']);
Result := IsStoredProp(Self, PropInfo);
end;
function TTntBitBtn.GetCaption: TWideCaption;
begin
Result := WideGetWindowText(Self)
end;
procedure TTntBitBtn.SetCaption(const Value: TWideCaption);
begin
WideSetWindowText(Self, Value);
end;
function TTntBitBtn.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntBitBtn.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntBitBtn.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntBitBtn.CMDialogChar(var Message: TCMDialogChar);
begin
TntButton_CMDialogChar(Self, Message);
end;
procedure TTntBitBtn.UpdateInternalGlyphList;
begin
FPaintInherited := True;
try
Repaint;
finally
FPaintInherited := False;
end;
Invalidate;
Abort;
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 VER150}
Details: TThemedElementDetails;
Button: TThemedButton;
Offset: TPoint;
{$ENDIF}
begin
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 VER150}
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));
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));
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;
end;
procedure TTntBitBtn.CMMouseEnter(var Message: TMessage);
begin
FMouseInControl := True;
inherited;
end;
procedure TTntBitBtn.CMMouseLeave(var Message: TMessage);
begin
FMouseInControl := False;
inherited;
end;
end.
--- NEW FILE: TntCheckLst.pas ---
unit TntCheckLst;
interface
uses Classes, Windows, CheckLst, Controls, TntClasses, TntControls;
type
{TNT-WARN TCheckListBox}
TTntCheckListBox = class(TCheckListBox{TNT-ALLOW TCheckListBox}, IWideCustomListControl)
private
FItems: TTntWideStrings;
FSaveItems: TTntWideStrings;
FSaveTopIndex: Integer;
FSaveItemIndex: Integer;
procedure SetItems(const Value: TTntWideStrings);
function GetHint: WideString;
procedure SetHint(const Value: WideString);
function IsHintStored: Boolean;
protected
procedure CreateWindowHandle(const Params: TCreateParams); override;
procedure DefineProperties(Filer: TFiler); 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;
{$IFNDEF VER130}
procedure CopySelection(Destination: TCustomListControl); override;
{$ENDIF}
procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual;
published
property Hint: WideString read GetHint write SetHint stored IsHintStored;
property Items: TTntWideStrings read FItems write SetItems;
end;
implementation
uses SysUtils, TntWideStrPropHelper, TntStdCtrls;
{ 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;
DefineWideProperties(Filer, Self);
end;
procedure TTntCheckListBox.CreateWnd;
begin
inherited;
TntListBox_AfterInherited_CreateWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex);
end;
procedure TTntCheckListBox.DestroyWnd;
begin
TntListBox_BeforeInherited_DestroyWnd(Self, FSaveItems, FItems, FSaveTopIndex, FSaveItemIndex);
inherited;
end;
procedure TTntCheckListBox.SetItems(const Value: TTntWideStrings);
begin
FItems.Assign(Value);
end;
procedure TTntCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
if Assigned(OnDrawItem) then
OnDrawItem(Self, Index, Rect, State)
else begin
inherited; { first, draw item check box }
TntListBox_DrawItem_Text(Self, Items, Index, Rect); {second, draw item text}
end;
end;
function TTntCheckListBox.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntCheckListBox.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntCheckListBox.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntCheckListBox.AddItem(const Item: WideString; AObject: TObject);
begin
TntListBox_AddItem(Items, Item, AObject);
end;
{$IFNDEF VER130}
procedure TTntCheckListBox.CopySelection(Destination: TCustomListControl);
begin
TntListBox_CopySelection(Self, Items, Destination);
end;
{$ENDIF}
end.
--- NEW FILE: TntExtCtrls.pas ---
unit TntExtCtrls;
interface
uses Classes, Messages, Controls, ExtCtrls, TntControls;
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;
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;
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;
protected
procedure DefineProperties(Filer: TFiler); override;
published
property Hint: WideString read GetHint write SetHint stored IsHintStored;
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;
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;
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 BevelInner;
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;
property ParentBiDiMode;
{$IFDEF VER150}
property ParentBackground;
{$ENDIF}
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
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;
property OnMouseDown;
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;
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 VER150} nodefault {$ENDIF};
property Constraints;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
{$IFDEF VER150}
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;
property OnBandDrag;
property OnBandInfo;
property OnBandMove;
property OnBandPaint;
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;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPaint;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
implementation
uses Windows, TntWideStrPropHelper, TntClasses, Graphics, {$IFDEF VER150} Themes, {$ENDIF}
TntGraphics;
{ TTntShape }
procedure TTntShape.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntShape.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntShape.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntShape.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntShape.CMHintShow(var Message: TMessage);
begin
ProcessCMHintShowMsg(Message);
inherited;
end;
{ TTntPaintBox }
procedure TTntPaintBox.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntPaintBox.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntPaintBox.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntPaintBox.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntPaintBox.CMHintShow(var Message: TMessage);
begin
ProcessCMHintShowMsg(Message);
inherited;
end;
{ TTntImage }
procedure TTntImage.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntImage.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntImage.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntImage.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntImage.CMHintShow(var Message: TMessage);
begin
ProcessCMHintShowMsg(Message);
inherited;
end;
{ TTntBevel }
procedure TTntBevel.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntBevel.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self)
end;
function TTntBevel.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntBevel.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
procedure TTntBevel.CMHintShow(var Message: TMessage);
begin
ProcessCMHintShowMsg(Message);
inherited;
end;
{ TTntCustomPanel }
procedure TTntCustomPanel.CreateWindowHandle(const Params: TCreateParams);
begin
CreateUnicodeHandle(Self, Params, '');
end;
procedure TTntCustomPanel.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntCustomPanel.IsCaptionStored: Boolean;
begin
Result := TntIsCaptionStored(Self);
end;
function TTntCustomPanel.GetCaption: TWideCaption;
begin
Result := WideGetWindowText(Self)
end;
procedure TTntCustomPanel.SetCaption(const Value: TWideCaption);
begin
WideSetWindowText(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 VER150}
if ThemeServices.ThemesEnabled and ParentBackground 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 VER150}
if not ThemeServices.ThemesEnabled or not ParentBackground 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 := TntIsHintStored(Self)
end;
function TTntCustomPanel.GetHint: WideString;
begin
Result := WideGetWindowHint(Self);
end;
procedure TTntCustomPanel.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
{ TTntCustomControlBar }
procedure TTntCustomControlBar.CreateWindowHandle(const Params: TCreateParams);
begin
CreateUnicodeHandle(Self, Params, '');
end;
procedure TTntCustomControlBar.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
function TTntCustomControlBar.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self);
end;
function TTntCustomControlBar.GetHint: WideString;
begin
Result := WideGetWindowHint(Self);
end;
procedure TTntCustomControlBar.SetHint(const Value: WideString);
begin
WideSetWindowHint(Self, Value);
end;
end.
--- NEW FILE: TntGraphics.pas ---
{*******************************************************}
{ The Delphi Unicode Controls Project }
{ }
{ http://home.ccci.org/wolbrink }
{ }
{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) }
{ }
{*******************************************************}
unit TntGraphics;
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;
implementation
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;
end.
--- NEW FILE: TntGrids.pas ---
{*******************************************************}
{ The Delphi Unicode Controls Project }
{ }
{ http://home.ccci.org/wolbrink }
{ }
{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) }
{ }
{*******************************************************}
unit TntGrids;
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}
{$IFDEF VER130}
_TTntInternalCustomDrawGrid = class(TDrawGrid{TNT-ALLOW TDrawGrid})
{$ELSE}
_TTntInternalCustomDrawGrid = class(TCustomDrawGrid{TNT-ALLOW TCustomDrawGrid})
{$ENDIF}
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;
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 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;
property OnMouseDown;
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(TTntWideStrings)
private
FIsCol: Boolean;
FColRowIndex: Integer;
FGrid: TTntStringGrid;
function GetAnsiStrings: 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(IsCol: Boolean; ListIndex: Integer): TTntWideStrings;
function GetCols(Index: Integer): TTntWideStrings;
function GetRows(Index: Integer): TTntWideStrings;
procedure SetCols(Index: Integer; const Value: TTntWideStrings);
procedure SetRows(Index: Integer; const Value: TTntWideStrings);
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;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Cells[ACol, ARow: Integer]: WideString read GetCells write SetCells;
property Cols[Index: Integer]: TTntWideStrings read GetCols write SetCols;
property Rows[Index: Integer]: TTntWideStrings 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, TntGraphics, TntControls, TntStdCtrls, TntWideStrPropHelper,
{$IFDEF JCL} JclUnicode {$ELSE} Unicode {$ENDIF};
{ TTntInplaceEdit }
procedure TTntInplaceEdit.CreateWindowHandle(const Params: TCreateParams);
begin
TntCustomEdit_CreateWindowHandle(Self, Params);
end;
function TTntInplaceEdit.GetText: WideString;
begin
Result := WideGetWindowText(Self);
end;
procedure TTntInplaceEdit.SetText(const Value: WideString);
begin
WideSetWindowText(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;
DefineWideProperties(Filer, Self);
end;
function TTntCustomDrawGrid.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self);
end;
function TTntCustomDrawGrid.GetHint: WideString;
begin
Result := WideGetWindowHint(Self);
end;
procedure TTntCustomDrawGrid.SetHint(const Value: WideString);
begin
WideSetWindowHint(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, WideGetWindowText(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;
{ 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]);
GetAnsiStrings.Assign(UTF8Strings);
end else if Source is TWideStrings then begin
for i := 0 to TWideStrings(Source).Count - 1 do
UTF8Strings.AddObject(WideStringToUTF8(TWideStrings(Source).Strings[i]),
TWideStrings(Source).Objects[i]);
GetAnsiStrings.Assign(UTF8Strings);
end else
GetAnsiStrings.Assign(Source);
finally
UTF8Strings.Free;
end;
end;
function TTntStringGridStrings.GetAnsiStrings: 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
GetAnsiStrings.Clear;
end;
procedure TTntStringGridStrings.Delete(Index: Integer);
begin
GetAnsiStrings.Delete(Index);
end;
function TTntStringGridStrings.GetCount: Integer;
begin
Result := GetAnsiStrings.Count;
end;
function TTntStringGridStrings.Get(Index: Integer): WideString;
begin
Result := UTF8ToWideString(GetAnsiStrings[Index]);
end;
procedure TTntStringGridStrings.Put(Index: Integer; const S: WideString);
begin
GetAnsiStrings[Index] := WideStringToUTF8(S);
end;
procedure TTntStringGridStrings.Insert(Index: Integer; const S: WideString);
begin
GetAnsiStrings.Insert(Index, WideStringToUTF8(S));
end;
function TTntStringGridStrings.Add(const S: WideString): Integer;
begin
Result := GetAnsiStrings.Add(WideStringToUTF8(S));
end;
function TTntStringGridStrings.GetObject(Index: Integer): TObject;
begin
Result := GetAnsiStrings.Objects[Index];
end;
procedure TTntStringGridStrings.PutObject(Index: Integer; AObject: TObject);
begin
GetAnsiStrings.Objects[Index] := AObject;
end;
type TAccessStrings = class(TStrings{TNT-ALLOW TStrings});
procedure TTntStringGridStrings.SetUpdateState(Updating: Boolean);
begin
TAccessStrings(GetAnsiStrings).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 := TStringList{TNT-ALLOW TStringList}.Create;
FCreatedRowStrings.Sorted := True;
FCreatedRowStrings.Duplicates := dupError;
FCreatedColStrings := TStringList{TNT-ALLOW TStringList}.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;
DefineWideProperties(Filer, Self);
end;
function TTntStringGrid.IsHintStored: Boolean;
begin
Result := TntIsHintStored(Self);
end;
function TTntStringGrid.GetHint: WideString;
begin
Result := WideGetWindowHint(Self)
end;
procedure TTntStringGrid.SetHint(const Value: WideString);
begin
WideSetWindowHint(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);
begin
inherited Cells[ACol, ARow] := WideStringToUTF8(Value);
end;
function TTntStringGrid.FindGridStrings(IsCol: Boolean; ListIndex: Integer): TTntWideStrings;
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 TTntWideStrings
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): TTntWideStrings;
begin
Result := FindGridStrings(True, Index);
end;
function TTntStringGrid.GetRows(Index: Integer): TTntWideStrings;
begin
Result := FindGridStrings(False, Index);
end;
procedure TTntStringGrid.SetCols(Index: Integer; const Value: TTntWideStrings);
begin
FindGridStrings(True, Index).Assign(Value);
end;
procedure TTntStringGrid.SetRows(Index: Integer; const Value: TTntWideStrings);
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, WideGetWindowText(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;
end.
--- NEW FILE: TntMenus.pas ---
{*******************************************************}
{ The Delphi Unicode Controls Project }
{ }
{ http://home.ccci.org/wolbrink }
{ }
{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) }
{ }
{*******************************************************}
unit TntMenus;
interface
{$IFNDEF VER130}
{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! }
{$ENDIF}
uses Windows, Classes, TntClasses, Menus, Graphics, Messages;
type
{TNT-WARN TMenuItem}
TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem})
private
FCaption: WideString;
{$IFDEF VER130}
FOnMeasureItem: TMenuMeasureItemEvent;
{$ENDIF}
function GetCaption: WideString;
procedure SetCaption(const Value: WideString);
procedure SetInheritedCaption(const Value: AnsiString);
procedure UpdateMenuString(ParentMenu: TMenu);
function IsCaptionStored: Boolean;
function GetAlignmentDrawStyle: Word;
function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
{$IFDEF VER130}
procedure DoMeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
{$ENDIF}
protected
procedure DefineProperties(Filer: TFiler); 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); {$IFNDEF VER130} override; {$ENDIF}
public
constructor Create(AOwner: TComponent); override;
procedure Loaded; override;
function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
published
property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored;
{$IFDEF VER130}
property OnMeasureItem: TMenuMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;
{$ENDIF}
end;
{TNT-WARN TMainMenu}
TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu})
protected
procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
end;
{TNT-WARN TPopupMenu}
TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu})
protected
procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); 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(ShortCut: TShortCut): 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;
procedure WideSetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; const Value: WideString);
procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
implementation
uses SysUtils, TntWideStrPropHelper, ActnList, Consts, TntControls, ImgList, TntGraphics, Forms;
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(ShortCut: TShortCut): WideString;
var
ScanCode: Integer;
KeyName: array[0..255] of WideChar;
begin
Assert(Win32PlatformIsUnicode);
Result := '';
ScanCode := MapVirtualKeyW(WordRec(ShortCut).Lo, 0) shl 16;
if ScanCode <> 0 then
begin
GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName));
Result := KeyName;
end;
end;
function WideGetKeyboardChar(Key: Word): WideChar;
begin
Assert(Win32PlatformIsUnicode);
Result := WideChar(MapVirtualKeyW(Key, 2));
end;
function WideShortCutToText(ShortCut: TShortCut): WideString;
var
Name: WideString;
begin
if (not Win32PlatformIsUnicode)
or (WordRec(ShortCut).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}(ShortCut)
else begin
case WordRec(ShortCut).Lo of
$30..$39: Name := WideGetKeyboardChar(WordRec(ShortCut).Lo); {1-9,0}
$41..$5A: Name := WideGetKeyboardChar(WordRec(ShortCut).Lo); {A-Z}
$60..$69: Name := WideGetKeyboardChar(WordRec(ShortCut).Lo); {numpad 1-9,0}
else
Name := WideGetSpecialName(ShortCut);
end;
if Name <> '' then
begin
Result := '';
if ShortCut and scShift <> 0 then Result := Result + SmkcShift;
if ShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl;
if ShortCut 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 WideCompareText(Text, WideShortCutToText(Key)) = 0 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
Delete(Result, I-1, 4)
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 WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
begin
if MenuItem is TTntMenuItem then
Result := TTntMenuItem(MenuItem).Caption
else
Result := MenuItem.Caption;
end;
procedure WideSetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; const Value: WideString);
begin
if MenuItem is TTntMenuItem then
TTntMenuItem(MenuItem).Caption := Value
else
MenuItem.Caption := Value;
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;
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);
function SafeIndex(const S: WideString; Idx: Integer): Boolean;
begin
Result := (Idx <= Length(S)) and (Idx >= 1);
end;
function SafeGetChar(const S: WideString; Idx: Integer): WideChar;
begin
if SafeIndex(S, Idx) then
Result := S[Idx]
else
Result := #0;
end;
var
HotKey: WideChar;
HotKeyPrefixIndex: Integer;
FarEastHotKey_UseParen: Boolean;
begin
// determine pattern
HotKeyPrefixIndex := WideGetHotkeyPos(Source) - 1;
FarEastHotKey_UseParen := False;
HotKey := #0;
if (SysLocale.FarEast)
and (SafeGetChar(Source, HotKeyPrefixIndex - 1) = '(')
and (SafeGetChar(Source, HotKeyPrefixIndex + 2) = ')') then begin
HotKey := SafeGetChar(Source, HotKeyPrefixIndex + 1);
Dec(HotKeyPrefixIndex, 2);
FarEastHotKey_UseParen := True;
end;
// copy pattern
Dest := WideStripHotkey(Dest);
if SafeIndex(Dest, HotKeyPrefixIndex) then begin
if (not FarEastHotKey_UseParen) then
System.Insert(cHotkeyPrefix, Dest, HotKeyPrefixIndex)
else begin
System.Insert('(' + cHotkeyPrefix, Dest, HotKeyPrefixIndex + 1);
System.Insert(WideString(HotKey) + ')', Dest, HotKeyPrefixIndex + 3); // '(&A'
end;
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;
{$IFDEF VER130} // Delphi 5
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;
FxxxxBreak: TMenuBreak;
FBitmap: TBitmap;
end;
{$ENDIF}
{$IFDEF VER140} // Delphi 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;
FxxxxBreak: TMenuBreak;
FBitmap: TBitmap;
end;
{$ENDIF}
{$IFDEF VER150} // 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;
FxxxxBreak: TMenuBreak;
FBitmap: TBitmap;
end;
{$ENDIF}
function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
begin
Result := Assigned(THackMenuItem(MenuItem).FBitmap);
end;
{ TTntMenuItem }
constructor TTntMenuItem.Create(AOwner: TComponent);
begin
inherited;
{$IFDEF VER130}
inherited OnMeasureItem := DoMeasureItem;
{$ENDIF}
end;
procedure TTntMenuItem.DefineProperties(Filer: TFiler);
begin
inherited;
DefineWideProperties(Filer, Self);
end;
type TAccessActionlink = class(TActionLink);
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 WideSameCaption(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;
procedure TTntMenuItem.Loaded;
begin
inherited;
UpdateMenuString(GetParentMenu);
end;
procedure TTntMenuItem.MenuChanged(Rebuild: Boolean);
var
ParentMenu: TMenu;
begin
inherited;
UpdateMenuItems(Self, GetParentMenu);
// TMenu sometimes sets bidi on item[0] which can convert caption to ansi
if (SysLocale.MiddleEast) then begin
ParentMenu := GetParentMenu;
if (ParentMenu <> nil)
and (not ParentMenu.ParentBiDiMode)
and (ParentMenu.Items.Count > 0)
and (ParentMenu.Items[0] is TTntMenuItem) then
begin
(ParentMenu.Items[0] as TTntMenuItem).UpdateMenuString(ParentMenu);
end;
end;
end;
procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu);
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(Parent.Handle, 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(Parent.Handle, Command, nil, 0, MF_BYCOMMAND);
if Len = 0 then
Result := ''
else begin
SetLength(Result, Len + 1);
Len := GetMenuStringW(Parent.Handle, 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(Parent.Handle, 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(Parent.Handle, Command, False, MenuItemInfo));
end;
end;
function SameEvent(A, B: TMenuMeasureItemEvent): Boolean;
begin
Result := @A = @B;
end;
var
MenuCaption: WideString;
begin
{$IFDEF VER130}
if not SameEvent(inherited OnMeasureItem, DoMeasureItem) then begin
if not SameEvent(inherited OnMeasureItem, nil) then
OnMeasureItem := inherited OnMeasureItem; {sync}
inherited OnMeasureItem := DoMeasureItem;
end;
{$ENDIF}
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)
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) 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 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
SaveFontColor: TColor;
ParentMenu: TMenu;
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
SaveFontColor := ACanvas.Font.Color;
try
ACanvas.Font.Color := ACanvas.Brush.Color;
inherited;
finally
ACanvas.Font.Color := SaveFontColor;
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;
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;
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;
{$IFDEF VER130}
procedure TTntMenuItem.DoMeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
begin
if (not Win32PlatformIsUnicode)
or (Self.IsLine) then begin
inherited OnMeasureItem := OnMeasureItem;
try
inherited MeasureItem(ACanvas, Width, Height);
finally
inherited OnMeasureItem := DoMeasureItem;
end;
end else
MeasureItem(ACanvas, Width, Height);
end;
{$ENDIF}
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;
{ TTntMainMenu }
procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
begin
inherited;
UpdateMenuItems(Items, Self);
end;
{ TTntPopupMenu }
procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
begin
inherited;
UpdateMenuItems(Items, Self);
end;
initialization
Classes.RegisterClass(TTntMenuItem);
end.
--- NEW FILE: TntThemeMgr.pas ---
{*******************************************************}
{ The Delphi Unicode Controls Project }
{ }
{ http://home.ccci.org/wolbrink }
{ }
{ Copyright (c) 2002, Troy Wolbrink (wolbrink@ccci.org) }
{ }
{*******************************************************}
unit TntThemeMgr;
//---------------------------------------------------------------------------------------------
// TTntThemeManager is a TThemeManager descendant that knows about Tnt Unicode controls.
// Most of the code is a complete copy from the Mike Lischke's original with only a
// few modifications to enabled Unicode support of Tnt controls.
//---------------------------------------------------------------------------------------------
// The initial developer of ThemeMgr.pas is:
// Dipl. Ing. Mike Lischke (public@lischke-online.de, www.lischke-online.de).
// http://www.delphi-gems.com/ThemeManager.php
//
// Portions created by Mike Lischke are
// (C) 2001-2002 Mike Lischke. All Rights Reserved.
//---------------------------------------------------------------------------------------------
interface
{$I Compilers.inc}
uses
Windows, Sysutils, Messages, Classes, Controls, Graphics, Buttons, ComCtrls, ThemeMgr, ThemeSrv;
{TNT-WARN TThemeManager}
type
TTntThemeManagerHelper = class(TComponent)
private
FTntThemeManager: TThemeManager{TNT-ALLOW TThemeManager};
procedure GroupBox_WM_PAINT(Control: TControl; var Message : TMessage);
procedure CheckListBox_CN_DRAWITEM(Control: TControl; var Message: TMessage);
procedure Panel_NewPaint(Control: TControl; DC: HDC);
procedure Panel_WM_PAINT(Control: TControl; var Message: TMessage);
procedure Panel_WM_PRINTCLIENT(Control: TControl; var Message: TMessage);
procedure ToolBar_WM_LBUTTONDOWN(Control: TControl; var Message: TMessage);
procedure ToolBar_WM_LBUTTONUP(Control: TControl; var Message: TMessage);
procedure ToolBar_WM_CANCELMODE(Control: TControl; var Message: TMessage);
procedure BitBtn_CN_DRAWITEM(Control: TControl; var Message: TMessage);
procedure SpeedButton_WM_PAINT(Control: TControl; var Message: TMessage);
protected
procedure DrawBitBtn(Control: TBitBtn{TNT-ALLOW TBitBtn}; var DrawItemStruct: TDrawItemStruct);
procedure DrawButton(Control: TControl; Button: TThemedButton; DC: HDC; R: TRect; Focused: Boolean);
public
constructor Create(AOwner: TThemeManager{TNT-ALLOW TThemeManager}); reintroduce;
function DoControlMessage(Control: TControl; var Message: TMessage): Boolean;
end;
TTntThemeManager = class(TThemeManager{TNT-ALLOW TThemeManager})
private
FThemeMgrHelper: TTntThemeManagerHelper;
protected
function DoControlMessage(Control: TControl; var Message: TMessage): Boolean; override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
end;
procedure Register;
implementation
uses
TntClasses, TntControls, StdCtrls, TntStdCtrls, TntButtons, TntCheckLst, ExtCtrls,
TntExtCtrls, TntGraphics;
procedure Register;
begin
RegisterComponents('Tnt Additional', [TTntThemeManager]);
end;
var
GlobalCheckWidth: Integer;
GlobalCheckHeight: Integer;
procedure GetCheckSize;
begin
with TBitmap.Create do
try
Handle := LoadBitmap(0, PAnsiChar(32759));
GlobalCheckWidth := Width div 4;
GlobalCheckHeight := Height div 3;
finally
Free;
end;
end;
{ TTntThemeManagerHelper }
constructor TTntThemeManagerHelper.Create(AOwner: TThemeManager{TNT-ALLOW TThemeManager});
begin
inherited Create(AOwner);
FTntThemeManager := AOwner;
end;
function TTntThemeManagerHelper.DoControlMessage(Control: TControl; var Message: TMessage): Boolean;
begin
Result := False;
if ThemeServices.ThemesEnabled then begin
case Message.Msg of
WM_PAINT:
if (Control is TTntCustomPanel) then begin
Result := True;
Panel_WM_PAINT(Control, Message);
end else if (Control is TTntCustomGroupBox) then begin
Result := True;
GroupBox_WM_PAINT(Control, Message);
end else if (Control is TTntSpeedButton) then begin
Result := True;
SpeedButton_WM_PAINT(Control, Message);
end;
CN_DRAWITEM:
if (Control is TTntCheckListBox) then begin
Result := True;
CheckListBox_CN_DRAWITEM(Control, Message);
end else if (Control is TTntBitBtn) then begin
Result := True;
BitBtn_CN_DRAWITEM(Control, Message);
end;
WM_PRINTCLIENT:
if (Control is TTntCustomPanel) then begin
Result := True;
Panel_WM_PRINTCLIENT(Control, Message);
end;
WM_LBUTTONDOWN:
if (Control is TToolBar) then
ToolBar_WM_LBUTTONDOWN(Control, Message);
WM_LBUTTONUP:
if (Control is TToolBar) then
ToolBar_WM_LBUTTONUP(Control, Message);
WM_CANCELMODE:
if (Control is TToolBar) then
ToolBar_WM_CANCELMODE(Control, Message);
end;
end;
if Result then
Message.Msg := WM_NULL;
end;
// ------- Group Box --------
type
// Used to access protected properties.
TGroupBoxCast = class(TTntCustomGroupBox);
procedure TTntThemeManagerHelper.GroupBox_WM_PAINT(Control: TControl; var Message: TMessage);
var
GroupBoxCast: TGroupBoxCast;
procedure NewPaint(DC: HDC);
var
CaptionRect,
OuterRect: TRect;
Size: TSize;
LastFont: HFONT;
Box: TThemedButton;
Details: TThemedElementDetails;
begin
with FTntThemeManager, GroupBoxCast do
begin
LastFont := SelectObject(DC, Font.Handle);
if Caption <> '' then
begin
SetTextColor(DC, Graphics.ColorToRGB(Font.Color));
// Determine size and position of text rectangle.
// This must be clipped out before painting the frame.
GetTextExtentPoint32W(DC, 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(DC, Left, Top, Right, Bottom);
if Control.Enabled then
Box := tbGroupBoxNormal
else
Box := tbGroupBoxDisabled;
Details := ThemeServices.GetElementDetails(Box);
ThemeServices.DrawElement(DC, Details, OuterRect);
SelectClipRgn(DC, 0);
if Caption <> '' then
ThemeServices.DrawText{TNT-ALLOW DrawText}(DC, Details, Caption, CaptionRect, DT_LEFT, 0);
SelectObject(DC, LastFont);
end;
end;
var
PS: TPaintStruct;
begin
GroupBoxCast := TGroupBoxCast(Control as TTntCustomGroupBox);
BeginPaint(GroupBoxCast.Handle, PS);
NewPaint(PS.hdc);
GroupBoxCast.PaintControls(PS.hdc, nil);
EndPaint(GroupBoxCast.Handle, PS);
Message.Result := 0;
end;
// ------- Check List Box --------
type
TCheckListBoxCast = class(TTntCheckListBox);
procedure TTntThemeManagerHelper.CheckListBox_CN_DRAWITEM(Control: TControl; var Message: TMessage);
var
DrawState: TOwnerDrawState;
ListBox: TCheckListBoxCast;
procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean);
var
DrawRect: TRect;
Button: TThemedButton;
Details: TThemedElementDetails;
begin
DrawRect.Left := R.Left + (R.Right - R.Left - GlobalCheckWidth) div 2;
DrawRect.Top := R.Top + (R.Bottom - R.Top - GlobalCheckWidth) div 2;
DrawRect.Right := DrawRect.Left + GlobalCheckWidth;
DrawRect.Bottom := DrawRect.Top + GlobalCheckHeight;
case AState of
cbChecked:
if Enabled then
Button := tbCheckBoxCheckedNormal
else
Button := tbCheckBoxCheckedDisabled;
cbUnchecked:
if Enabled then
Button := tbCheckBoxUncheckedNormal
else
Button := tbCheckBoxUncheckedDisabled;
else // cbGrayed
if Enabled then
Button := tbCheckBoxMixedNormal
else
Button := tbCheckBoxMixedDisabled;
end;
with FTntThemeManager do begin
Details := ThemeServices.GetElementDetails(Button);
ThemeServices.DrawElement(ListBox.Canvas.Handle, Details, DrawRect, @DrawRect);
end;
end;
procedure NewDrawItem(Index: Integer; Rect: TRect; DrawState: TOwnerDrawState);
var
Flags: Integer;
Data: WideString;
R: TRect;
ACheckWidth: Integer;
Enable: Boolean;
begin
with ListBox do
begin
if Assigned(OnDrawItem) and (Style <> lbStandard)then
OnDrawItem(ListBox, Index, Rect, DrawState)
else
begin
ACheckWidth := GetCheckWidth;
if Index < Items.Count then
begin
R := Rect;
// Delphi 4 has neither an enabled state nor a header state for items.
Enable := Enabled {$ifdef COMPILER_6_UP} and ItemEnabled[Index] {$endif COMPILER_6_UP};
if {$ifdef COMPILER_6_UP} not Header[Index] {$else} True {$endif COMPILER_6_UP} then
begin
if not UseRightToLeftAlignment then
begin
R.Right := Rect.Left;
R.Left := R.Right - ACheckWidth;
end
else
begin
R.Left := Rect.Right;
R.Right := R.Left + ACheckWidth;
end;
DrawCheck(R, State[Index], Enable);
end
else
begin
{$ifdef COMPILER_6_UP}
Canvas.Font.Color := HeaderColor;
Canvas.Brush.Color := HeaderBackgroundColor;
{$endif COMPILER_6_UP}
end;
if not Enable then
Canvas.Font.Color := clGrayText;
end;
Canvas.FillRect(Rect);
if Index < {$ifdef COMPILER_6_UP} Count {$else} Items.Count {$endif COMPILER_6_UP}then
begin
Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
if not UseRightToLeftAlignment then
Inc(Rect.Left, 2)
else
Dec(Rect.Right, 2);
Data := '';
{$ifdef COMPILER_6_UP}
if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
Data := DoGetData(Index)
else
{$endif COMPILER_6_UP}
Data := Items[Index];
DrawTextW(Canvas.Handle, PWideChar(Data), Length(Data), Rect, Flags);
end;
end;
end;
end;
begin
ListBox := TCheckListBoxCast(Control);
if {$ifdef COMPILER_6_UP} ListBox.Count > 0 {$else} ListBox.Items.Count > 0 {$endif COMPILER_6_UP}
then begin
with TWMDrawItem(Message).DrawItemStruct^, ListBox do
begin
if {$ifdef COMPILER_6_UP} not Header[itemID] {$else} True {$endif COMPILER_6_UP} then
if not UseRightToLeftAlignment then
rcItem.Left := rcItem.Left + GetCheckWidth
else
rcItem.Right := rcItem.Right - GetCheckWidth;
{$ifdef COMPILER_5_UP}
DrawState := TOwnerDrawState(LongRec(itemState).Lo);
{$else}
DrawState := TOwnerDrawState(Byte(LongRec(itemState).Lo));
{$endif COMPILER_5_UP}
Canvas.Handle := hDC;
Canvas.Font := Font;
Canvas.Brush := Brush;
if (Integer(itemID) >= 0) and (odSelected in DrawState) then
begin
Canvas.Brush.Color := clHighlight;
Canvas.Font.Color := clHighlightText
end;
if Integer(itemID) >= 0 then
NewDrawItem(itemID, rcItem, DrawState)
else
Canvas.FillRect(rcItem);
if odFocused in DrawState then
DrawFocusRect(hDC, rcItem);
Canvas.Handle := 0;
end;
end;
end;
// ------- Panel --------
type
// Used to access protected properties.
TPanelCast = class(TTntCustomPanel);
procedure TTntThemeManagerHelper.Panel_NewPaint(Control: TControl; DC: HDC);
const
Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
TopColor, BottomColor: TColor;
procedure AdjustColors(Bevel: TPanelBevel);
begin
TopColor := clBtnHighlight;
if Bevel = bvLowered then
TopColor := clBtnShadow;
BottomColor := clBtnShadow;
if Bevel = bvLowered then
BottomColor := clBtnHighlight;
end;
var
Rect: TRect;
FontHeight: Integer;
Flags: Longint;
Details: TThemedElementDetails;
OldFont: HFONT;
begin
with TPanelCast(Control as TTntCustomPanel) do
begin
Canvas.Handle := DC;
try
Canvas.Font := Font;
Rect := GetClientRect;
if BevelOuter <> bvNone then
begin
AdjustColors(BevelOuter);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
InflateRect(Rect, -BorderWidth, -BorderWidth);
if BevelInner <> bvNone then
begin
AdjustColors(BevelInner);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
if ParentColor or ((Control.Parent <> nil) and (Control.Parent.Brush.Color = Color)) then
begin
if TWinControl(Control.Parent).DoubleBuffered then
FTntThemeManager.PerformEraseBackground(Control, DC)
else
begin
Details := ThemeServices.GetElementDetails(tbGroupBoxNormal);
ThemeServices.DrawParentBackground(Handle, DC, @Details, False, @Rect);
end
end
else
begin
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
FillRect(DC, Rect, Canvas.Brush.Handle);
end;
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);
OldFont := SelectObject(DC, Font.Handle);
SetBKMode(DC, TRANSPARENT);
SetTextColor(DC, ColorToRGB(Font.Color));
DrawTextW(DC, PWideChar(Caption), -1, Rect, Flags);
SelectObject(DC, OldFont);
finally
Canvas.Handle := 0;
end;
end;
end;
procedure TTntThemeManagerHelper.Panel_WM_PAINT(Control: TControl; var Message: TMessage);
var
DC: HDC;
PS: TPaintStruct;
begin
with TPanelCast(Control as TTntCustomPanel) do begin
DC := BeginPaint(Handle, PS);
Panel_NewPaint(Control, DC);
PaintControls(DC, nil);
EndPaint(Handle, PS);
Message.Result := 0;
end;
end;
procedure TTntThemeManagerHelper.Panel_WM_PRINTCLIENT(Control: TControl; var Message: TMessage);
var
DC: HDC;
begin
with TPanelCast(Control as TTntCustomPanel) do
begin
DC := TWMPrintClient(Message).DC;
Panel_NewPaint(Control, DC);
PaintControls(DC, nil);
Message.Result := 0;
end;
end;
//-----------------------------------------
function ClickedToolButton(ToolBar: TToolBar; var Message: TWMMouse): TToolButton;
var
Control: TControl;
begin
Result := nil;
Control := ToolBar.ControlAtPos(SmallPointToPoint(Message.Pos), False);
if (Control <> nil) and (Control is TToolButton) and not Control.Dragging then
Result := TToolButton(Control);
end;
var LastClickedButton: TToolButton;
procedure TTntThemeManagerHelper.ToolBar_WM_LBUTTONDOWN(Control: TControl; var Message: TMessage);
begin
LastClickedButton := ClickedToolButton(Control as TToolBar, TWMMouse(Message));
end;
procedure TTntThemeManagerHelper.ToolBar_WM_LBUTTONUP(Control: TControl; var Message: TMessage);
var
ToolButton: TToolButton;
begin
ToolButton := ClickedToolButton(Control as TToolBar, TWMMouse(Message));
if (ToolButton <> nil)
and (ToolButton = LastClickedButton)
and (not (csCaptureMouse in ToolButton.ControlStyle)) then begin
SetCaptureControl(LastClickedButton); // TToolBar is depending on this
PostMessage((Control as TToolBar).Handle, WM_CANCELMODE, 0, 0); // this is to clean it up
end;
end;
procedure TTntThemeManagerHelper.ToolBar_WM_CANCELMODE(Control: TControl; var Message: TMessage);
begin
if (GetCaptureControl = nil)
or (GetCaptureControl = LastClickedButton) then
SetCaptureControl(nil);
LastClickedButton := nil;
end;
//-----------------------------------------
procedure TTntThemeManagerHelper.DrawBitBtn(Control: TBitBtn{TNT-ALLOW TBitBtn}; var DrawItemStruct: TDrawItemStruct);
var
Button: TThemedButton;
R: TRect;
Wnd: HWND;
P: TPoint;
begin
with DrawItemStruct do
begin
// For owner drawn buttons we will never get the ODS_HIGHLIGHT flag. This makes it necessary to
// check ourselves if the button is "hot".
GetCursorPos(P);
Wnd := WindowFromPoint(P);
if Wnd = TWinControl(Control).Handle then
itemState := itemState or ODS_HOTLIGHT;
R := rcItem;
if not Control.Enabled then
Button := tbPushButtonDisabled
else
if (itemState and ODS_SELECTED) <> 0 then
Button := tbPushButtonPressed
else
if (itemState and ODS_HOTLIGHT) <> 0 then
Button := tbPushButtonHot
else
// It seems ODS_DEFAULT is never set, so we have to check the control's properties.
if Control.Default or ((itemState and ODS_FOCUS) <> 0) then
Button := tbPushButtonDefaulted
else
Button := tbPushButtonNormal;
DrawButton(Control, Button, hDC, R, itemState and ODS_FOCUS <> 0);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; const Offset: TPoint; var GlyphPos: TPoint;
var TextBounds: TRect; BiDiFlags: Integer);
var
Layout: TButtonLayout;
Spacing: Integer;
Margin: Integer;
Caption: TWideCaption;
begin
if Control is TTntBitBtn then
begin
Layout := TTntBitBtn(Control).Layout;
Spacing := TTntBitBtn(Control).Spacing;
Margin := TTntBitBtn(Control).Margin;
Caption := TTntBitBtn(Control).Caption;
end
else if Control is TTntSpeedButton then
begin
Layout := TTntSpeedButton(Control).Layout;
Spacing := TTntSpeedButton(Control).Spacing;
Margin := TTntSpeedButton(Control).Margin;
Caption := TTntSpeedButton(Control).Caption;
end else
raise Exception.Create('TNT Internal Error: Wrong button class in CalcButtonLayout.');
TButtonGlyph_CalcButtonLayout(Control, DC, Client, Offset, Caption, Layout, Margin,
Spacing, GlyphPos, TextBounds, BiDiFlags);
end;
type
TSpeedButtonCast = class(TTntSpeedButton);
TControlCast = class(TControl);
procedure TTntThemeManagerHelper.DrawButton(Control: TControl; Button: TThemedButton; DC: HDC; R: TRect; Focused: Boolean);
// Common paint routine for TTntBitBtn and TTntSpeedButton.
var
TextBounds: TRect;
LastFont: HFONT;
Glyph: TBitmap;
GlyphPos: TPoint;
GlyphWidth: Integer;
GlyphSourceX: Integer;
GlyphMask: TBitmap;
Offset: TPoint;
ToolButton: TThemedToolBar;
Details: TThemedElementDetails;
begin
GlyphSourceX := 0;
GlyphWidth := 0;
ToolButton := ttbToolbarDontCare;
if Control is TTntBitBtn then
begin
Glyph := TTntBitBtn(Control).Glyph;
// Determine which image to use (if there is more than one in the glyph).
with TTntBitBtn(Control), Glyph do
begin
if not Empty then
begin
GlyphWidth := Width div NumGlyphs;
if not Enabled and (NumGlyphs > 1) then
GlyphSourceX := GlyphWidth
else
if (Button = tbPushButtonPressed) and (NumGlyphs > 2) then
GlyphSourceX := 2 * GlyphWidth;
end;
end;
end
else
begin
Assert(Control is TTntSpeedButton, 'TNT Internal Error: Wrong button type in TTntThemeManagerHelper.DrawButton');
Glyph := TTntSpeedButton(Control).Glyph;
with TSpeedButtonCast(Control) do
begin
// Determine which image to use (if there is more than one in the glyph).
with Glyph do
if not Empty then
begin
GlyphWidth := Width div NumGlyphs;
if not Enabled and (NumGlyphs > 1) then
GlyphSourceX := GlyphWidth
else
case FState of
bsDown:
if NumGlyphs > 2 then
GlyphSourceX := 2 * GlyphWidth;
bsExclusive:
if NumGlyphs > 3 then
GlyphSourceX := 3 * GlyphWidth;
end;
end;
// If the speed button is flat then we use toolbutton images for drawing.
if Flat then
begin
case Button of
tbPushButtonDisabled:
Toolbutton := ttbButtonDisabled;
tbPushButtonPressed:
Toolbutton := ttbButtonPressed;
tbPushButtonHot:
Toolbutton := ttbButtonHot;
tbPushButtonNormal:
Toolbutton := ttbButtonNormal;
end;
end;
end;
end;
if ToolButton = ttbToolbarDontCare then
begin
Details := ThemeServices.GetElementDetails(Button);
ThemeServices.DrawElement(DC, Details, R);
R := ThemeServices.ContentRect(DC, Details, R);
end
else
begin
Details := ThemeServices.GetElementDetails(ToolButton);
ThemeServices.DrawElement(DC, Details, R);
R := ThemeServices.ContentRect(DC, Details, R);
end;
// The XP style does no longer indicate pressed buttons by moving the caption one pixel down and right.
Offset := Point(0, 0);
with TControlCast(Control) do
begin
LastFont := SelectObject(DC, Font.Handle);
CalcButtonLayout(Control, DC, R, Offset, GlyphPos, TextBounds, DrawTextBidiModeFlags(0));
// Note: Currently we cannot do text output via the themes services because the second flags parameter (which is
// used for graying out strings) is ignored (bug in XP themes implementation?).
// Hence we have to do it the "usual" way.
if ToolButton = ttbButtonDisabled then
SetTextColor(DC, ColorToRGB(clGrayText));
SetBkMode(DC, TRANSPARENT);
if Control is TTntBitBtn then begin
with TTntBitBtn(Control) do
DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER)
end else begin
Assert(Control is TTntSpeedButton, 'TNT Internal Error: Wrong button type in TTntThemeManagerHelper.DrawButton');
with TTntSpeedButton(Control) do
DrawTextW(DC, PWideChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER)
end;
with Glyph do
if not Empty then
begin
GlyphMask := TBitmap.Create;
GlyphMask.Assign(Glyph);
GlyphMask.Mask(Glyph.TransparentColor);
TransparentStretchBlt(DC, GlyphPos.X, GlyphPos.Y, GlyphWidth, Height, Canvas.Handle, GlyphSourceX, 0,
GlyphWidth, Height, GlyphMask.Canvas.Handle, GlyphSourceX, 0);
GlyphMask.Free;
end;
SelectObject(DC, LastFont);
end;
if Focused then
begin
SetTextColor(DC, 0);
DrawFocusRect(DC, R);
end;
end;
procedure TTntThemeManagerHelper.BitBtn_CN_DRAWITEM(Control: TControl; var Message: TMessage);
var
Details: TThemedElementDetails;
begin
with FTntThemeManager, TWMDrawItem(Message) do
begin
// This message is sent for bit buttons (TTntBitBtn) when they must be drawn. Since a bit button is a normal
// Windows button (but with custom draw enabled) it is handled here too.
// TTntSpeedButton is a TGraphicControl descentant and handled separately.
Details := ThemeServices.GetElementDetails(tbPushButtonNormal);
ThemeServices.DrawParentBackground(TWinControl(Control).Handle, DrawItemStruct.hDC, @Details, True);
DrawBitBtn(Control as TTntBitBtn, DrawItemStruct^);
end;
end;
procedure TTntThemeManagerHelper.SpeedButton_WM_PAINT(Control: TControl; var Message: TMessage);
var
Button: TThemedButton;
P: TPoint;
begin
with FTntThemeManager, TWMPaint(Message) do
begin
// We cannot use the theme parent paint for the background of general speed buttons (because they are not
// window controls).
PerformEraseBackground(Control, DC);
// Speed buttons are not window controls and are painted by a call of their parent with a given DC.
if not Control.Enabled then
Button := tbPushButtonDisabled
else
if TSpeedButtonCast(Control).FState in [bsDown, bsExclusive] then
Button := tbPushButtonPressed
else
with TSpeedButtonCast(Control) do
begin
// Check the hot style here. If the button has a flat style then this check is easy. Otherwise
// some more work is necessary.
Button := tbPushButtonNormal;
if Flat then
begin
if MouseInControl then
Button := tbPushButtonHot;
end
else
begin
GetCursorPos(P);
if FindDragTarget(P, True) = Control then
Button := tbPushButtonHot;
end;
end;
DrawButton(Control, Button, DC, Control.ClientRect, False);
Message.Result := 0;
end;
end;
{ TTntThemeManager }
constructor TTntThemeManager.Create(AOwner: TComponent);
begin
inherited;
FThemeMgrHelper := TTntThemeManagerHelper.Create(Self);
end;
procedure TTntThemeManager.Loaded;
begin
if (not (csDesigning in ComponentState))
and (not ThemeServices.ThemesAvailable) then begin
Options := Options - [toResetMouseCapture];
FixControls(nil);
end;
inherited;
end;
function TTntThemeManager.DoControlMessage(Control: TControl; var Message: TMessage): Boolean;
begin
Result := FThemeMgrHelper.DoControlMessage(Control, Message);
end;
initialization
GetCheckSize;
end.
--- NEW FILE: TntWideStrPropHelper.pas ---
unit TntWideStrPropHelper;
interface
uses
Classes, TypInfo;
type
TTntWideStringUTFPropertyFiler = 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;
procedure DefineWideProperties(Filer: TFiler; Instance: TPersistent);
{$IFDEF VER130}
function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
{$ENDIF}
implementation
uses
ConvertUTF7, {$IFDEF JCL} JclUnicode; {$ELSE} Unicode; {$ENDIF}
//===========================================================================
// The Delphi 5 Classes.pas has no support for streaming WideStrings.
// The Delphi 6 Classes.pas works great. Too bad the Delphi 6 IDE doesn't not use
// the updated Classes.pas. Switching between Form/Text mode corrupts extended
// characters in WideStrings even under Delphi 6.
//
// The purpose of this solution is to store WideString properties which contain
// non-ASCII chars in the form of UTF8 under the old property name + 'W'.
//
// Special thanks go to Francisco Leong for helping to develop this solution.
//
procedure DefineWideProperties(Filer: TFiler; Instance: TPersistent);
var
I, Count: Integer;
PropInfo: PPropInfo;
PropList: PPropList;
WideStringFiler: TTntWideStringUTFPropertyFiler;
begin
Count := GetTypeData(Instance.ClassInfo)^.PropCount;
if Count > 0 then
begin
WideStringFiler := TTntWideStringUTFPropertyFiler.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);
end;
finally
FreeMem(PropList, Count * SizeOf(Pointer));
end;
finally
WideStringFiler.Free;
end;
end;
end;
{ TTntWideStringUTFPropertyFiler }
{$IFDEF VER130}
const IsDelphi5 = True;
{$ELSE}
const IsDelphi5 = False;
{$ENDIF}
procedure TTntWideStringUTFPropertyFiler.ReadDataUTF8(Reader: TReader);
begin
// Delphi 6 runtime does not need to read UTF.
if IsDelphi5 or (csDesigning in Reader.Owner.ComponentState) then
SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString))
else
Reader.ReadString; { do nothing with result }
end;
procedure TTntWideStringUTFPropertyFiler.ReadDataUTF7(Reader: TReader);
begin
// Delphi 6 runtime does not need to read UTF.
if IsDelphi5 or (csDesigning in Reader.Owner.ComponentState) then
SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString))
else
Reader.ReadString; { do nothing with result }
end;
procedure TTntWideStringUTFPropertyFiler.WriteDataUTF7(Writer: TWriter);
begin
Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo)));
end;
procedure TTntWideStringUTFPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent;
PropName: AnsiString);
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;
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);
Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData);
end;
FInstance := nil;
FPropInfo := nil;
end;
{$IFDEF VER130}
procedure AssignWideStr(var Dest: WideString; const Source: WideString);
begin
Dest := Source;
end;
procedure IntGetWideStrProp(Instance: TObject; PropInfo: PPropInfo;
var Value: WideString); assembler;
asm
{ -> EAX Pointer to instance }
{ EDX Pointer to property info }
{ ECX Pointer to result string }
PUSH ESI
PUSH EDI
MOV EDI,EDX
MOV EDX,[EDI].TPropInfo.Index { pass index in EDX }
CMP EDX,$80000000
JNE @@hasIndex
MOV EDX,ECX { pass value in EDX }
@@hasIndex:
MOV ESI,[EDI].TPropInfo.GetProc
CMP [EDI].TPropInfo.GetProc.Byte[3],$FE
JA @@isField
JB @@isStaticMethod
@@isVirtualMethod:
MOVSX ESI,SI { sign extend slot offset }
ADD ESI,[EAX] { vmt + slot offset }
CALL DWORD PTR [ESI]
JMP @@exit
@@isStaticMethod:
CALL ESI
JMP @@exit
@@isField:
AND ESI,$00FFFFFF
MOV EDX,[EAX+ESI]
MOV EAX,ECX
CALL AssignWideStr
@@exit:
POP EDI
POP ESI
end;
function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
begin
IntGetWideStrProp(Instance, PropInfo, Result);
end;
procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo;
const Value: WideString); assembler;
asm
{ -> EAX Pointer to instance }
{ EDX Pointer to property info }
{ ECX Pointer to string value }
PUSH ESI
PUSH EDI
MOV ESI,EDX
MOV EDX,[ESI].TPropInfo.Index { pass index in EDX }
CMP EDX,$80000000
JNE @@hasIndex
MOV EDX,ECX { pass value in EDX }
@@hasIndex:
MOV EDI,[ESI].TPropInfo.SetProc
CMP [ESI].TPropInfo.SetProc.Byte[3],$FE
JA @@isField
JB @@isStaticMethod
@@isVirtualMethod:
MOVSX EDI,DI
ADD EDI,[EAX]
CALL DWORD PTR [EDI]
JMP @@exit
@@isStaticMethod:
CALL EDI
JMP @@exit
@@isField:
AND EDI,$00FFFFFF
ADD EAX,EDI
MOV EDX,ECX
CALL AssignWideStr
@@exit:
POP EDI
POP ESI
end;
{$ENDIF}
end.
Index: Readme.txt
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/Readme.txt,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Readme.txt 13 Jun 2002 23:54:44 -0000 1.1
--- Readme.txt 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 4,8 ****
Email: wolbrink@ccci.org
! These controls are provided as-is, with no implied warranty. They are freely available for you to use in your own projects. Please let me know if you have found them helpful. Also, please let me know if you find any bugs or other areas of needed improvement. I'm also open to those wishing to contribute to the project. Just let me know before you start to make sure no one else is working on it simultaneously.
---Background----------------------------
--- 4,8 ----
Email: wolbrink@ccci.org
! These controls are provided as-is, with no implied warranty. They are freely available for you to use in your own projects. Please let me know if you have found them helpful. Also, please let me know if you find any bugs or other areas of needed improvement.
---Background----------------------------
Index: TntClasses.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/TntClasses.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** TntClasses.pas 13 Jun 2002 23:54:44 -0000 1.1
--- TntClasses.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 16,55 ****
interface
! {$IFDEF VER140}
{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! }
{$ENDIF}
! uses Classes, SysUtils, Windows, ActiveX, {$IFDEF JCL} JclUnicode {$ELSE} Unicode {$ENDIF};
{$IFDEF JCL}
! procedure JCL_WideStrings_Put(Strings: TWideStrings; Index: Integer; const S: WideString);
[...2008 lines suppressed...]
+ begin
+ TTntWideStringListHelper(FList).InheritedChanged;
+ end;
+
+ procedure TTntWideStringList.Changing;
+ begin
+ TTntWideStringListHelper(FList).InheritedChanging;
+ end;
+
+ function TTntWideStringList.Find(const S: WideString; var Index: Integer): Boolean;
+ begin
+ Result := TTntWideStringListHelper(FList).InheritedFind(S, Index);
+ end;
+
+ initialization
+ Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
+ Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))
+ or (Win32MajorVersion > 5);
end.
Index: TntComCtrls.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/TntComCtrls.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** TntComCtrls.pas 13 Jun 2002 23:54:44 -0000 1.1
--- TntComCtrls.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 13,19 ****
interface
implementation
! {$R *.dcr}
end.
--- 13,2705 ----
interface
[...2671 lines suppressed...]
! Result := WideGetWindowHint(Self);
! end;
!
! procedure TTntPageScroller.SetHint(const Value: WideString);
! begin
! WideSetWindowHint(Self, Value);
! end;
!
! initialization
! RegisterClasses([TTntListItems]);
! RegisterClasses([TTntListItem]);
! RegisterClasses([TTntTabSheet]);
!
! finalization
! if Assigned(AIMM) then
! AIMM.Deactivate;
! if FRichEdit20Module <> 0 then
! FreeLibrary(FRichEdit20Module);
end.
Index: TntControls.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/TntControls.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** TntControls.pas 13 Jun 2002 23:54:44 -0000 1.1
--- TntControls.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 34,38 ****
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 subclasses 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.
--- 34,38 ----
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
[...1332 lines suppressed...]
! procedure DoneControls;
! begin
! GlobalDeleteAtom(ControlAtom);
! ControlAtomString := '';
! GlobalDeleteAtom(WindowAtom);
! WindowAtomString := '';
! end;
initialization
! WideCaptionHolders := TComponentList.Create(True);
! PendingRecreateWndTrapList := TComponentList.Create(False);
! InitControls;
finalization
! WideCaptionHolders.Free;
! PendingRecreateWndTrapList.Free;
! DoneControls;
end.
Index: TntForms.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/TntForms.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** TntForms.pas 13 Jun 2002 23:54:44 -0000 1.1
--- TntForms.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 12,37 ****
interface
!
! {$IFDEF VER140}
{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! }
{$ENDIF}
uses
! Classes, TntClasses, Windows, Messages, Controls, Forms;
- {TNT-WARN TForm}
type
TTntForm{TNT-ALLOW TTntForm} = class(TForm{TNT-ALLOW TForm})
private
! function GetCaption: WideString;
! procedure SetCaption(const Value: WideString);
protected
procedure CreateWindowHandle(const Params: TCreateParams); override;
public
procedure DefaultHandler(var Message); override;
published
! property Caption: WideString read GetCaption write SetCaption;
end;
{TNT-WARN PeekMessage}
{TNT-WARN PeekMessageA}
--- 12,129 ----
interface
!
! {$IFNDEF VER130}
{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! }
{$ENDIF}
uses
! Classes, TntClasses, Windows, Messages, Controls, Forms, TntControls;
type
+ {TNT-WARN TScrollBox}
+ TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox})
+ private
+ function IsHintStored: Boolean;
+ function GetHint: WideString;
+ procedure SetHint(const Value: WideString);
+ protected
+ procedure CreateWindowHandle(const Params: TCreateParams); override;
+ procedure DefineProperties(Filer: TFiler); 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;
+ published
+ property Hint: WideString read GetHint write SetHint stored IsHintStored;
+ end;
+
+ {TNT-WARN TFrame}
+ TTntFrame{TNT-ALLOW 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 VER150}
+ 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;
+ 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;
+ property OnMouseDown;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnResize;
+ property OnStartDock;
+ property OnStartDrag;
+ property OnUnDock;
+ end;
+
+ {TNT-WARN TForm}
TTntForm{TNT-ALLOW 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;
protected
procedure CreateWindowHandle(const Params: TCreateParams); override;
+ procedure DefineProperties(Filer: TFiler); 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;
+ {TNT-WARN IsAccel}
+ function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;
+
{TNT-WARN PeekMessage}
{TNT-WARN PeekMessageA}
***************
*** 40,48 ****
procedure DisableManualPeekMessageWithRemove;
! implementation
! {$R *.DFM}
! uses SysUtils, Consts, TntControls;
{$IFDEF VER130}
--- 132,141 ----
procedure DisableManualPeekMessageWithRemove;
! procedure ConstructBaseClassForm(Self: TTntForm{TNT-ALLOW TTntForm}; FormClass: TCustomFormClass; AOwner: TComponent);
! implementation
! uses SysUtils, Consts, {$IFNDEF VER130} RTLConsts, {$ENDIF} TntMenus, TntWideStrPropHelper,
! {$IFDEF JCL} JclUnicode {$ELSE} Unicode {$ENDIF};
{$IFDEF VER130}
***************
*** 51,56 ****
--- 144,251 ----
{$ENDIF}
+ function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;
+ var
+ W: WideChar;
+ W1, W2: WideString;
+ begin
+ if CharCode <= Word(High(AnsiChar)) then
+ W := KeyUnicode(AnsiChar(CharCode))
+ else
+ W := WideChar(CharCode);
+
+ W1 := W;
+ W2 := WideGetHotKey(Caption);
+ if Win32PlatformIsUnicode then
+ Result := (2 = CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(W1), Length(W1), PWideChar(W2), Length(W2)))
+ else
+ Result := (CompareText{TNT-ALLOW CompareText}(W1, W2) = 0);
+ end;
+
+ procedure ConstructBaseClassForm(Self: TTntForm{TNT-ALLOW TTntForm}; FormClass: TCustomFormClass; AOwner: TComponent);
+ begin
+ with Self do begin
+ GlobalNameSpace.BeginWrite;
+ try
+ CreateNew(AOwner);
+ if (ClassType <> FormClass) and not (csDesigning in ComponentState) then
+ begin
+ Include(FFormState, fsCreating);
+ try
+ if not InitInheritedComponent(Self, FormClass) then
+ raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
+ finally
+ Exclude(FFormState, fsCreating);
+ end;
+ if OldCreateOrder then DoCreate;
+ end;
+ finally
+ GlobalNameSpace.EndWrite;
+ end;
+ end;
+ end;
+
+ { TTntScrollBox }
+
+ procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams);
+ begin
+ CreateUnicodeHandle(Self, Params, '');
+ end;
+
+ procedure TTntScrollBox.DefineProperties(Filer: TFiler);
+ begin
+ inherited;
+ DefineWideProperties(Filer, Self);
+ end;
+
+ function TTntScrollBox.IsHintStored: Boolean;
+ begin
+ Result := TntIsHintStored(Self);
+ end;
+
+ function TTntScrollBox.GetHint: WideString;
+ begin
+ Result := WideGetWindowHint(Self);
+ end;
+
+ procedure TTntScrollBox.SetHint(const Value: WideString);
+ begin
+ WideSetWindowHint(Self, Value);
+ end;
+
+ { TTntCustomFrame }
+
+ procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams);
+ begin
+ CreateUnicodeHandle(Self, Params, '');
+ end;
+
+ procedure TTntCustomFrame.DefineProperties(Filer: TFiler);
+ begin
+ inherited;
+ DefineWideProperties(Filer, Self);
+ end;
+
+ function TTntCustomFrame.IsHintStored: Boolean;
+ begin
+ Result := TntIsHintStored(Self);
+ end;
+
+ function TTntCustomFrame.GetHint: WideString;
+ begin
+ Result := WideGetWindowHint(Self);
+ end;
+
+ procedure TTntCustomFrame.SetHint(const Value: WideString);
+ begin
+ WideSetWindowHint(Self, Value);
+ end;
+
{ TTntForm }
+ constructor TTntForm{TNT-ALLOW TTntForm}.Create(AOwner: TComponent);
+ begin
+ ConstructBaseClassForm(Self, TTntForm{TNT-ALLOW TTntForm}, AOwner);
+ end;
+
procedure TTntForm{TNT-ALLOW TTntForm}.CreateWindowHandle(const Params: TCreateParams);
var
***************
*** 58,63 ****
WideWinClassName: WideString;
begin
! if (Win32Platform <> VER_PLATFORM_WIN32_NT)
! or (csDesigning in ComponentState) then
inherited
else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
--- 253,257 ----
WideWinClassName: WideString;
begin
! if (not Win32PlatformIsUnicode) then
inherited
else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
***************
*** 66,79 ****
(Application.MainForm.ClientHandle = 0) then
raise EInvalidOperation.Create(SNoMDIForm);
! WideWinClassName := Params.WinClassName + UNICODE_CLASS_EXT;
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;
! SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC));
! WideSetWindowText(Self, Params.Caption);
! SubClassUnicodeControl(Self);
Include(FFormState, fsCreatedMDIChild);
end else
--- 260,271 ----
(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, Params.WindowClass.hInstance, Longint(Params.Param));
if WindowHandle = 0 then
RaiseLastOSError;
! SubClassUnicodeControl(Self, Params.Caption);
Include(FFormState, fsCreatedMDIChild);
end else
***************
*** 84,88 ****
Exclude(FFormState, fsCreatedMDIChild);
end;
! {$IFDEF VER140}
if AlphaBlend then begin
// toggle AlphaBlend to force update
--- 276,280 ----
Exclude(FFormState, fsCreatedMDIChild);
end;
! {$IFNDEF VER130}
if AlphaBlend then begin
// toggle AlphaBlend to force update
***************
*** 93,101 ****
end;
procedure TTntForm{TNT-ALLOW TTntForm}.DefaultHandler(var Message);
begin
if (ClientHandle <> 0)
! and (Win32Platform = VER_PLATFORM_WIN32_NT)
! and (not (csDesigning in ComponentState)) then
with TMessage(Message) do
if Msg = WM_SIZE then
--- 285,298 ----
end;
+ procedure TTntForm{TNT-ALLOW TTntForm}.DefineProperties(Filer: TFiler);
+ begin
+ inherited;
+ DefineWideProperties(Filer, Self);
+ end;
+
procedure TTntForm{TNT-ALLOW TTntForm}.DefaultHandler(var Message);
begin
if (ClientHandle <> 0)
! and (Win32PlatformIsUnicode) then
with TMessage(Message) do
if Msg = WM_SIZE then
***************
*** 107,124 ****
end;
! function TTntForm{TNT-ALLOW TTntForm}.GetCaption: WideString;
begin
! if (csDesigning in ComponentState) then
! result := inherited Caption
! else
! result := WideGetWindowText(Self)
end;
! procedure TTntForm{TNT-ALLOW TTntForm}.SetCaption(const Value: WideString);
begin
! if (csDesigning in ComponentState) then
! inherited Caption := Value
! else
! WideSetWindowText(Self, Value)
end;
--- 304,335 ----
end;
! function TTntForm{TNT-ALLOW TTntForm}.IsCaptionStored: Boolean;
begin
! Result := TntIsCaptionStored(Self);
end;
! function TTntForm{TNT-ALLOW TTntForm}.GetCaption: TWideCaption;
begin
! Result := WideGetWindowText(Self)
! end;
!
! procedure TTntForm{TNT-ALLOW TTntForm}.SetCaption(const Value: TWideCaption);
! begin
! WideSetWindowText(Self, Value)
! end;
!
! function TTntForm{TNT-ALLOW TTntForm}.IsHintStored: Boolean;
! begin
! Result := TntIsHintStored(Self);
! end;
!
! function TTntForm{TNT-ALLOW TTntForm}.GetHint: WideString;
! begin
! Result := WideGetWindowHint(Self)
! end;
!
! procedure TTntForm{TNT-ALLOW TTntForm}.SetHint(const Value: WideString);
! begin
! WideSetWindowHint(Self, Value);
end;
***************
*** 139,143 ****
function IsDlgMsg(var Msg: TMsg): Boolean;
begin
! result := (Application.DialogHandle <> 0)
and (IsDialogMessage(Application.DialogHandle, Msg))
end;
--- 350,354 ----
function IsDlgMsg(var Msg: TMsg): Boolean;
begin
! Result := (Application.DialogHandle <> 0)
and (IsDialogMessage(Application.DialogHandle, Msg))
end;
Index: TntStdCtrls.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/TntStdCtrls.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** TntStdCtrls.pas 13 Jun 2002 23:54:44 -0000 1.1
--- TntStdCtrls.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 11,25 ****
unit TntStdCtrls;
- { If you want to use JCLUnicode that comes with Jedi Component Library,
- define JCL as a "Conditional Define" in the project options. }
-
interface
uses
! Windows, Messages, Classes, Controls, StdCtrls, CheckLst,
! {$IFDEF JCL} JclUnicode {$ELSE} Unicode {$ENDIF};
[...3009 lines suppressed...]
+ procedure TTntCustomStaticText.SetCaption(const Value: TWideCaption);
+ begin
+ WideSetWindowText(Self, Value);
+ end;
+
+ function TTntCustomStaticText.IsHintStored: Boolean;
+ begin
+ Result := TntIsHintStored(Self)
+ end;
+
+ function TTntCustomStaticText.GetHint: WideString;
+ begin
+ Result := WideGetWindowHint(Self)
+ end;
+
+ procedure TTntCustomStaticText.SetHint(const Value: WideString);
+ begin
+ WideSetWindowHint(Self, Value);
end;
Index: Unicode.pas
===================================================================
RCS file: /usr/local/cvsroot/sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/Unicode.pas,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Unicode.pas 13 Jun 2002 23:54:44 -0000 1.1
--- Unicode.pas 23 Jan 2003 00:02:43 -0000 1.2
***************
*** 22,25 ****
--- 22,27 ----
unit Unicode;
+ {TNT-IGNORE-UNIT}
+
// Copyright (c) 1999, 2000 Mike Lischke (public@lischke-online.de)
// Portions Copyright (c) 1999, 2000 Azret Botash (az)
***************
*** 114,119 ****
type
// Unicode transformation formats (UTF) data types
! UTF7 = AnsiChar;
! UTF8 = AnsiChar;
UTF16 = WideChar;
UTF32 = Cardinal;
--- 116,121 ----
type
// Unicode transformation formats (UTF) data types
! UTF7 = Char;
! UTF8 = Char;
UTF16 = WideChar;
UTF32 = Cardinal;
***************
*** 497,505 ****
TConfirmConversionEvent = procedure(Sender: TWideStrings; var Allowed: Boolean) of object;
- TAnsiStrings = TStrings{TNT-ALLOW TStrings};
-
TWideStrings = class(TPersistent)
private
- FAnsiStrings: TAnsiStrings;
FUpdateCount: Integer;
FLanguage: LCID; // language can usually left alone, the system's default is used
--- 499,504 ----
***************
*** 516,523 ****
procedure SetValue(const Name, Value: WideString);
procedure WriteData(Writer: TWriter);
- procedure SetAnsiStrings(const Value: TAnsiStrings);
protected
procedure DefineProperties(Filer: TFiler); override;
! procedure Error(const Msg: WideString; Data: Integer);
function Get(Index: Integer): WideString; virtual; abstract;
function GetCapacity: Integer; virtual;
--- 515,521 ----
procedure SetValue(const Name, Value: WideString);
procedure WriteData(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
! procedure Error(const Msg: String; Data: Integer);
function Get(Index: Integer): WideString; virtual; abstract;
function GetCapacity: Integer; virtual;
***************
*** 538,542 ****
function AddObject(const S: WideString; AObject: TObject): Integer; virtual;
procedure Append(const S: WideString);
! procedure AddStrings(Strings: TAnsiStrings); overload; virtual;
procedure AddStrings(Strings: TWideStrings); overload; virtual;
procedure Assign(Source: TPersistent); override;
--- 536,540 ----
function AddObject(const S: WideString; AObject: TObject): Integer; virtual;
procedure Append(const S: WideString);
! procedure AddStrings(Strings: TStrings); overload; virtual;
procedure AddStrings(Strings: TWideStrings); overload; virtual;
procedure Assign(Source: TPersistent); override;
***************
*** 554,561 ****
procedure Insert(Index: Integer; const S: WideString); virtual; abstract;
procedure InsertObject(Index: Integer; const S: WideString; AObject: TObject);
! 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 SetText(Text: PWideChar); virtual;
--- 552,559 ----
procedure Insert(Index: Integer; const S: WideString); virtual; abstract;
procedure InsertObject(Index: Integer; const S: WideString; AObject: TObject);
! procedure LoadFromFile(const FileName: String); virtual;
procedure LoadFromStream(Stream: TStream); virtual;
procedure Move(CurIndex, NewIndex: Integer); virtual;
! procedure SaveToFile(const FileName: String); virtual;
procedure SaveToStream(Stream: TStream); virtual;
procedure SetText(Text: PWideChar); virtual;
***************
*** 574,579 ****
property OnConfirmConversion: TConfirmConversionEvent read FOnConfirmConversion write FOnConfirmConversion;
- published
- property AnsiStrings: TAnsiStrings read FAnsiStrings write SetAnsiStrings stored False;
end;
--- 572,575 ----
***************
*** 643,648 ****
function StrECopyW(Dest, Source: PWideChar): PWideChar;
function StrLCopyW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
! function StrPCopyW(Dest: PWideChar; const Source: WideString): PWideChar;
! function StrPLCopyW(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar;
function StrCatW(Dest, Source: PWideChar): PWideChar;
function StrLCatW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
--- 639,644 ----
function StrECopyW(Dest, Source: PWideChar): PWideChar;
function StrLCopyW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
! function StrPCopyW(Dest: PWideChar; const Source: String): PWideChar;
! function StrPLCopyW(Dest: PWideChar; const Source: String; MaxLen: Cardinal): PWideChar;
function StrCatW(Dest, Source: PWideChar): PWideChar;
function StrLCatW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
***************
*** 760,772 ****
// utility functions
! function CodePageFromLocale(Language: LCID): Integer;
! function KeyboardCodePage: Word;
! function KeyUnicode(C: AnsiChar): WideChar;
function CodeBlockFromChar(const C: WideChar): Cardinal;
! function CodePageToWideString(A: AnsiString; CodePage: Word): WideString;
// WideString Conversion routines
! function WideStringToUTF8(S: WideString): AnsiString;
! function UTF8ToWideString(S: AnsiString): WideString;
//----------------------------------------------------------------------------------------------------------------------
--- 756,768 ----
// utility functions
! function CodePageFromLocale(Language: LCID): Cardinal;
! function KeyboardCodePage: Cardinal;
! function KeyUnicode(C: Char): WideChar;
function CodeBlockFromChar(const C: WideChar): Cardinal;
! function CodePageToWideString(const A: AnsiString; CodePage: Cardinal; dwFlags: Cardinal = 0): WideString;
// WideString Conversion routines
! function WideStringToUTF8(const S: WideString): AnsiString;
! function UTF8ToWideString(const S: AnsiString): WideString;
//----------------------------------------------------------------------------------------------------------------------
***************
*** 780,784 ****
uses
! Consts, {$IFDEF VER140} RTLConsts, {$ENDIF} SyncObjs, SysUtils, TntClasses;
resourcestring
--- 776,780 ----
uses
! Consts, {$IFNDEF VER130} RTLConsts, {$ENDIF} SyncObjs, SysUtils;
resourcestring
***************
*** 793,797 ****
type
! TCompareFunc = function (W1, W2: WideString; Locale: LCID): Integer;
var
--- 789,793 ----
type
! TCompareFunc = function (const W1, W2: WideString; Locale: LCID): Integer;
var
***************
*** 902,906 ****
I, Size: Integer;
Header: TUHeader;
! Stream: TTntResourceStream;
begin
--- 898,902 ----
I, Size: Integer;
Header: TUHeader;
! Stream: TResourceStream;
begin
***************
*** 912,916 ****
if PropertyOffsets = nil then
begin
! Stream := TTntResourceStream.Create(HInstance, 'TYPE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
--- 908,912 ----
if PropertyOffsets = nil then
begin
! Stream := TResourceStream.Create(HInstance, 'TYPE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
***************
*** 1047,1051 ****
var
! Stream: TTntResourceStream;
I: Cardinal;
Header: TUHeader;
--- 1043,1047 ----
var
! Stream: TResourceStream;
I: Cardinal;
Header: TUHeader;
***************
*** 1058,1062 ****
if CaseMap = nil then
begin
! Stream := TTntResourceStream.Create(HInstance, 'CASE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
--- 1054,1058 ----
if CaseMap = nil then
begin
! Stream := TResourceStream.Create(HInstance, 'CASE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
***************
*** 1236,1240 ****
var
! Stream: TTntResourceStream;
I: Cardinal;
Header: TUHeader;
--- 1232,1236 ----
var
! Stream: TResourceStream;
I: Cardinal;
Header: TUHeader;
***************
*** 1247,1251 ****
if Decompositions = nil then
begin
! Stream := TTntResourceStream.Create(HInstance, 'DECOMPOSE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
--- 1243,1247 ----
if Decompositions = nil then
begin
! Stream := TResourceStream.Create(HInstance, 'DECOMPOSE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
***************
*** 1358,1362 ****
var
! Stream: TTntResourceStream;
I: Cardinal;
Header: TUHeader;
--- 1354,1358 ----
var
! Stream: TResourceStream;
I: Cardinal;
Header: TUHeader;
***************
*** 1369,1373 ****
if CCLNodes = nil then
begin
! Stream := TTntResourceStream.Create(HInstance, 'COMBINE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
--- 1365,1369 ----
if CCLNodes = nil then
begin
! Stream := TResourceStream.Create(HInstance, 'COMBINE', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
***************
*** 1434,1438 ****
var
! Stream: TTntResourceStream;
I: Cardinal;
Header: TUHeader;
--- 1430,1434 ----
var
! Stream: TResourceStream;
I: Cardinal;
Header: TUHeader;
***************
*** 1445,1449 ****
if NumberNodes = nil then
begin
! Stream := TTntResourceStream.Create(HInstance, 'NUMBERS', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
--- 1441,1445 ----
if NumberNodes = nil then
begin
! Stream := TResourceStream.Create(HInstance, 'NUMBERS', 'UNICODE');
Stream.Read(Header, SizeOf(Header));
***************
*** 1998,2002 ****
// set the number of characters actually used
! FPatternUsed := (PAnsiChar(Cp) - PAnsiChar(FPattern)) div SizeOf(TUTBMChar);
// Go through and construct the skip array and determine the actual length
--- 1994,1998 ----
// set the number of characters actually used
! FPatternUsed := (PChar(Cp) - PChar(FPattern)) div SizeOf(TUTBMChar);
// Go through and construct the skip array and determine the actual length
***************
*** 4320,4365 ****
end;
- //----------------- TAnsiStringsForWideStrings ---------------------------------------------------------------------------------------
-
- type
- TAnsiStringsForWideStrings = class(TAnsiStrings)
- private
- FWideStrings: TWideStrings;
- protected
- function Get(Index: Integer): AnsiString; override;
- function GetCount: Integer; override;
- public
- procedure Clear; override;
- procedure Delete(Index: Integer); override;
- procedure Insert(Index: Integer; const S: AnsiString); override;
- end;
-
- { TAnsiStringsForWideStrings }
-
- procedure TAnsiStringsForWideStrings.Clear;
- begin
- FWideStrings.Clear;
- end;
-
- procedure TAnsiStringsForWideStrings.Delete(Index: Integer);
- begin
- FWideStrings.Delete(Index);
- end;
-
- function TAnsiStringsForWideStrings.Get(Index: Integer): AnsiString;
- begin
- result := FWideStrings.Get(Index);
- end;
-
- function TAnsiStringsForWideStrings.GetCount: Integer;
- begin
- result := FWideStrings.Count;
- end;
-
- procedure TAnsiStringsForWideStrings.Insert(Index: Integer; const S: AnsiString);
- begin
- FWideStrings.Insert(Index, S);
- end;
-
//----------------- TWideStrings ---------------------------------------------------------------------------------------
--- 4316,4319 ----
***************
*** 4368,4373 ****
begin
inherited;
- FAnsiStrings := TAnsiStringsForWideStrings.Create;
- TAnsiStringsForWideStrings(FAnsiStrings).FWideStrings := Self;
// there should seldom be the need to use a language other than the one of the system
FLanguage := GetUserDefaultLCID;
--- 4322,4325 ----
***************
*** 4379,4383 ****
begin
- FreeAndNil(FAnsiStrings);
inherited;
end;
--- 4331,4334 ----
***************
*** 4385,4396 ****
//----------------------------------------------------------------------------------------------------------------------
- procedure TWideStrings.SetAnsiStrings(const Value: TAnsiStrings);
- begin
- Clear;
- AddStrings(Value);
- end;
-
- //----------------------------------------------------------------------------------------------------------------------
-
procedure TWideStrings.SetLanguage(Value: LCID);
--- 4336,4339 ----
***************
*** 4427,4431 ****
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.AddStrings(Strings: TAnsiStrings);
var
--- 4370,4374 ----
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.AddStrings(Strings: TStrings);
var
***************
*** 4478,4487 ****
end
else
! if Source is TAnsiStrings then
begin
BeginUpdate;
try
Clear;
! for I := 0 to TAnsiStrings(Source).Count - 1 do AddObject(TAnsiStrings(Source)[I], TAnsiStrings(Source).Objects[I]);
finally
EndUpdate;
--- 4421,4430 ----
end
else
! if Source is TStrings then
begin
BeginUpdate;
try
Clear;
! for I := 0 to TStrings(Source).Count - 1 do AddObject(TStrings(Source)[I], TStrings(Source).Objects[I]);
finally
EndUpdate;
***************
*** 4502,4507 ****
begin
! if Dest is TAnsiStrings then
! with Dest as TAnsiStrings do
begin
BeginUpdate;
--- 4445,4450 ----
begin
! if Dest is TStrings then
! with Dest as TStrings do
begin
BeginUpdate;
***************
*** 4583,4587 ****
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.Error(const Msg: WideString; Data: Integer);
function ReturnAddr: Pointer;
--- 4526,4530 ----
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.Error(const Msg: String; Data: Integer);
function ReturnAddr: Pointer;
***************
*** 4662,4666 ****
begin
Result := Get(Index);
! P := Pos{TNT-ALLOW Pos}('=', Result);
if P > 0 then SetLength(Result, P - 1)
else Result := '';
--- 4605,4609 ----
begin
Result := Get(Index);
! P := Pos('=', Result);
if P > 0 then SetLength(Result, P - 1)
else Result := '';
***************
*** 4751,4755 ****
begin
S := Get(Result);
! P := Pos{TNT-ALLOW Pos}('=', S);
if (P > 0) and (WideCompareText(Copy(S, 1, P - 1), Name, FLanguage) = 0) then Exit;
end;
--- 4694,4698 ----
begin
S := Get(Result);
! P := Pos('=', S);
if (P > 0) and (WideCompareText(Copy(S, 1, P - 1), Name, FLanguage) = 0) then Exit;
end;
***************
*** 4778,4782 ****
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.LoadFromFile(const FileName: WideString);
var
--- 4721,4725 ----
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.LoadFromFile(const FileName: String);
var
***************
*** 4785,4789 ****
begin
try
! Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
try
LoadFromStream(Stream);
--- 4728,4732 ----
begin
try
! Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
try
LoadFromStream(Stream);
***************
*** 4792,4796 ****
--- 4735,4743 ----
end;
except
+ {$IFDEF VER130}
+ RaiseLastWin32Error;
+ {$ELSE}
RaiseLastOSError;
+ {$ENDIF}
end;
end;
***************
*** 4807,4811 ****
Order: WideChar;
SW: WideString;
! SA: AnsiString;
begin
--- 4754,4758 ----
Order: WideChar;
SW: WideString;
! SA: String;
begin
***************
*** 4828,4832 ****
Stream.Seek(-BytesRead, soFromCurrent);
SetLength(SA, Size);
! Stream.Read(PAnsiChar(SA)^, Size);
SetTextStr(SA);
end;
--- 4775,4779 ----
Stream.Seek(-BytesRead, soFromCurrent);
SetLength(SA, Size);
! Stream.Read(PChar(SA)^, Size);
SetTextStr(SA);
end;
***************
*** 4889,4896 ****
Clear;
while not Reader.EndOfList do
! if Reader.NextValue in [vaString, vaLString] then
! Add(Reader.ReadString)
! else
! Add(Reader.ReadWideString);
finally
EndUpdate;
--- 4836,4840 ----
Clear;
while not Reader.EndOfList do
! Add(Reader.ReadWideString);
finally
EndUpdate;
***************
*** 4901,4905 ****
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.SaveToFile(const FileName: WideString);
var
--- 4845,4849 ----
//----------------------------------------------------------------------------------------------------------------------
! procedure TWideStrings.SaveToFile(const FileName: String);
var
***************
*** 4907,4911 ****
begin
! Stream := TTntFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream);
--- 4851,4855 ----
begin
! Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream);
***************
*** 4921,4925 ****
var
SW, BOM: WideString;
! SA: AnsiString;
Allowed: Boolean;
Run: PWideChar;
--- 4865,4869 ----
var
SW, BOM: WideString;
! SA: String;
Allowed: Boolean;
Run: PWideChar;
***************
*** 4962,4966 ****
// implicit conversion to ANSI
SA := SW;
! if Allowed then Stream.WriteBuffer(PAnsiChar(SA)^, Length(SA));
end;
FSaved := True;
--- 4906,4910 ----
// implicit conversion to ANSI
SA := SW;
! if Allowed then Stream.WriteBuffer(PChar(SA)^, Length(SA));
end;
FSaved := True;
***************
*** 5419,5423 ****
//----------------- functions for null terminated wide strings ---------------------------------------------------------
! function StrLenW(Str: PWideChar): Cardinal;
// returns number of characters in a string excluding the null terminator
--- 5363,5367 ----
//----------------- functions for null terminated wide strings ---------------------------------------------------------
! function StrLenW(Str: PWideChar): Cardinal;
// returns number of characters in a string excluding the null terminator
***************
*** 5582,5591 ****
//----------------------------------------------------------------------------------------------------------------------
! function StrPCopyW(Dest: PWideChar; const Source: WideString): PWideChar;
// copies a Pascal-style string to a null-terminated wide string
begin
! Result := StrPLCopyW(Dest, Source, Length(Source));
Result[Length(Source)] := WideNull;
end;
--- 5526,5538 ----
//----------------------------------------------------------------------------------------------------------------------
! function StrPCopyW(Dest: PWideChar; const Source: String): PWideChar;
// copies a Pascal-style string to a null-terminated wide string
begin
! if Length(Source) > 0 then
! Result := StrPLCopyW(Dest, Source, Length(Source))
! else
! Result := Dest;
Result[Length(Source)] := WideNull;
end;
***************
*** 5593,5601 ****
//----------------------------------------------------------------------------------------------------------------------
! function StrPLCopyW(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar;
! // copies characters from a Pascal-style WideString into a null-terminated wide string
! begin
! result := StrLCopyW(Dest, PWideChar(Source), MaxLen);
end;
--- 5540,5561 ----
//----------------------------------------------------------------------------------------------------------------------
! function StrPLCopyW(Dest: PWideChar; const Source: String; MaxLen: Cardinal): PWideChar;
! // copies characters from a Pascal-style string into a null-terminated wide string
!
! asm
! PUSH EDI
! PUSH ESI
! MOV EDI, EAX
! MOV ESI, EDX
! MOV EDX, EAX
! XOR AX, AX
! @@1: LODSB
! STOSW
! DEC ECX
! JNZ @@1
! MOV EAX, EDX
! POP ESI
! POP EDI
end;
***************
*** 6669,6678 ****
//----------------------------------------------------------------------------------------------------------------------
! function CodePageFromLocale(Language: LCID): Integer;
// determines the code page for a given locale
var
! Buf: array[0..6] of AnsiChar;
begin
--- 6629,6638 ----
//----------------------------------------------------------------------------------------------------------------------
! function CodePageFromLocale(Language: LCID): Cardinal;
// determines the code page for a given locale
var
! Buf: array[0..6] of Char;
begin
***************
*** 6683,6687 ****
//----------------------------------------------------------------------------------------------------------------------
! function KeyboardCodePage: Word;
begin
--- 6643,6647 ----
//----------------------------------------------------------------------------------------------------------------------
! function KeyboardCodePage: Cardinal;
begin
***************
*** 6691,6695 ****
//----------------------------------------------------------------------------------------------------------------------
! function KeyUnicode(C: AnsiChar): WideChar;
// converts the given character (as it comes with a WM_CHAR message) into its corresponding
--- 6651,6655 ----
//----------------------------------------------------------------------------------------------------------------------
! function KeyUnicode(C: Char): WideChar;
// converts the given character (as it comes with a WM_CHAR message) into its corresponding
***************
*** 6850,6863 ****
//----------------------------------------------------------------------------------------------------------------------
! function CodePageToWideString(A: AnsiString; CodePage: Word): WideString;
!
begin
! SetLength(Result, Length(A));
! MultiByteToWideChar(CodePage, 0, PAnsiChar(A), Length(A), PWideChar(Result), Length(A) * 2);
end;
//----------------------------------------------------------------------------------------------------------------------
! function CompareTextWin95(W1, W2: WideString; Locale: LCID): Integer;
// special comparation function for Win9x since there's no system defined comparation function,
--- 6810,6839 ----
//----------------------------------------------------------------------------------------------------------------------
! function CodePageToWideString(const A: AnsiString; CodePage: Cardinal; dwFlags: Cardinal = 0): WideString;
! var
! Len: Integer;
begin
! // figure length
! Len := MultiByteToWideChar(CodePage, dwFlags, PChar(A), Length(A), nil, 0);
! SetLength(Result, Len);
! if Len > 0 then begin
! // convert string
! Len := MultiByteToWideChar(CodePage, dwFlags, PChar(A), Length(A),
! PWideChar(Result), Length(Result));
! // check result
! if Len = 0 then begin
! {$IFDEF VER130}
! RaiseLastWin32Error;
! {$ELSE}
! RaiseLastOSError;
! {$ENDIF}
! end else
! SetLength(Result, Len);
! end;
end;
//----------------------------------------------------------------------------------------------------------------------
! function CompareTextWin95(const W1, W2: WideString; Locale: LCID): Integer;
// special comparation function for Win9x since there's no system defined comparation function,
***************
*** 6865,6870 ****
var
! S1, S2: AnsiString;
! CP: Integer;
L1, L2: Integer;
--- 6841,6846 ----
var
! S1, S2: String;
! CP: Cardinal;
L1, L2: Integer;
***************
*** 6875,6886 ****
SetLength(S2, L2);
CP := CodePageFromLocale(Locale);
! WideCharToMultiByte(CP, 0, PWideChar(W1), L1, PAnsiChar(S1), L1, nil, nil);
! WideCharToMultiByte(CP, 0, PWideChar(W2), L2, PAnsiChar(S2), L2, nil, nil);
! Result := CompareStringA(Locale, NORM_IGNORECASE, PAnsiChar(S1), Length(S1), PAnsiChar(S2), Length(S2)) - 2;
end;
//----------------------------------------------------------------------------------------------------------------------
! function CompareTextWinNT(W1, W2: WideString; Locale: LCID): Integer;
// Wrapper function for WinNT since there's no system defined comparation function in Win9x and
--- 6851,6862 ----
SetLength(S2, L2);
CP := CodePageFromLocale(Locale);
! WideCharToMultiByte(CP, 0, PWideChar(W1), L1, PChar(S1), L1, nil, nil);
! WideCharToMultiByte(CP, 0, PWideChar(W2), L2, PChar(S2), L2, nil, nil);
! Result := CompareStringA(Locale, NORM_IGNORECASE, PChar(S1), Length(S1), PChar(S2), Length(S2)) - 2;
end;
//----------------------------------------------------------------------------------------------------------------------
! function CompareTextWinNT(const W1, W2: WideString; Locale: LCID): Integer;
// Wrapper function for WinNT since there's no system defined comparation function in Win9x and
***************
*** 6916,6920 ****
//----------------------------------------------------------------------------------------------------------------------
! function WideStringToUTF8(S: WideString): AnsiString;
var
--- 6892,6896 ----
//----------------------------------------------------------------------------------------------------------------------
! function WideStringToUTF8(const S: WideString): AnsiString;
var
***************
*** 6966,6973 ****
for L := bytesToWrite downto 2 do
begin
! Result[T + L - 1] := AnsiChar((ch or byteMark) and byteMask);
ch := ch shr 6;
end;
! Result[T] := AnsiChar(ch or firstByteMark[bytesToWrite]);
Inc(T, bytesToWrite);
end;
--- 6942,6949 ----
for L := bytesToWrite downto 2 do
begin
! Result[T + L - 1] := Char((ch or byteMark) and byteMask);
ch := ch shr 6;
end;
! Result[T] := Char(ch or firstByteMark[bytesToWrite]);
Inc(T, bytesToWrite);
end;
***************
*** 6977,6981 ****
//----------------------------------------------------------------------------------------------------------------------
! function UTF8ToWideString(S: AnsiString): WideString;
var
--- 6953,6957 ----
//----------------------------------------------------------------------------------------------------------------------
! function UTF8ToWideString(const S: AnsiString): WideString;
var
--- ExampleUnicode.dof DELETED ---
--- ExampleUnicode.dpr DELETED ---
--- ExampleUnicode.res DELETED ---
--- MainFrm.pas DELETED ---
--- TntComCtrls.dcr DELETED ---
--- TntDBCtrls.dcr DELETED ---
--- TntDBCtrls.pas DELETED ---
--- TntForms.dfm DELETED ---
--- TntForms_Design.pas DELETED ---
--- TntStdCtrls.dcr DELETED ---
--- TntUnicodeVcl_D50.dof DELETED ---
--- TntUnicodeVcl_D50.dpk DELETED ---
--- TntUnicodeVcl_D50.res DELETED ---
--- TntUnicodeVcl_D60.dof DELETED ---
- Previous message: [sword-cvs] sword/apps/windoze/CBuilder5/BibleCS/TntUnicodeControls/Example ExampleUnicode.cfg,NONE,1.1 ExampleUnicode.dof,NONE,1.1 ExampleUnicode.dpr,NONE,1.1 ExampleUnicode.res,NONE,1.1 MainFrm.dfm,NONE,1.1 MainFrm.pas,NONE,1.1
- Next message: [sword-cvs] sword/ideproj - New directory
- Messages sorted by:
[ date ]
[ thread ]
[ subject ]
[ author ]