tntcontrols.pas

TNT Components Source

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.3.0                                                       }
{                                                                             }
{    Copyright (c) 2002-2007, Troy Wolbrink ([e-mail])       }
{                                                                             }
{*****************************************************************************}

unit TntControls;

{$INCLUDE TntCompilers.inc}

{
  Windows NT provides support for native Unicode windows.  To add Unicode support to a
    TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle().

  One major reason this works is because the VCL only uses the ANSI version of
    SendMessage() -- SendMessageA().  If you call SendMessageA() on a UNICODE
    window, Windows deals with the ANSI/UNICODE conversion automatically.  So
    for example, if the VCL sends WM_SETTEXT to a window using SendMessageA,
    Windows actually *expects* a PAnsiChar even if the target window is a UNICODE
    window.  So caling SendMessageA with PChars causes no problems.

  A problem in the VCL has to do with the TControl.Perform() method. Perform()
    calls the window procedure directly and assumes an ANSI window.  This is a
    problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a
    PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar.

  This is the reason for SubClassUnicodeControl().  This procedure will subclass the
    Windows WndProc, and the TWinControl.WindowProc pointer.  It will determine if the
    message came from Windows or if the WindowProc was called directly.  It will then
    call SendMessageA() for Windows to perform proper conversion on certain text messages.

  Another problem has to do with TWinControl.DoKeyPress().  It is called from the WM_CHAR
    message.  It casts the WideChar to an AnsiChar, and sends the resulting character to
    DefWindowProc.  In order to avoid this, the DefWindowProc is subclassed as well.  WindowProc
    will make a WM_CHAR message safe for ANSI handling code by converting the char code to
    #FF before passing it on.  It stores the original WideChar in the .Unused field of TWMChar.
    The code #FF is converted back to the WideChar before passing onto DefWindowProc.
}

{
  Things to consider when designing new controls:
    1)  Check that a WideString Hint property is published.
    2)  If descending from TWinControl, override CreateWindowHandle().
    3)  If not descending from TWinControl, handle CM_HINTSHOW message.
    4)  Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly.
    5)  If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd.
    6)  Consider using storage specifiers for Hint and Caption properties.
    7)  If any class could possibly have published WideString properties,
          override DefineProperties and call TntPersistent_AfterInherited_DefineProperties.
    8)  Check if TTntThemeManager needs to be updated.
    9)  Override GetActionLinkClass() and ActionChange().
    10) If class updates Application.Hint then update TntApplication.Hint instead.
}

interface

{ TODO: Unicode enable .OnKeyPress event }

uses
  Classes, Windows, Messages, Controls, Menus;


{TNT-WARN TCaption}
type TWideCaption = type WideString;

// caption/text management
function TntControl_IsCaptionStored(Control: TControl): Boolean;
function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString;
procedure TntControl_SetStoredText(Control: TControl; const Value: WideString);
function TntControl_GetText(Control: TControl): WideString;
procedure TntControl_SetText(Control: TControl; const Text: WideString);

// hint management
function TntControl_IsHintStored(Control: TControl): Boolean;
function TntControl_GetHint(Control: TControl): WideString;
procedure TntControl_SetHint(Control: TControl; const Value: WideString);

function WideGetHint(Control: TControl): WideString;
function WideGetShortHint(const Hint: WideString): WideString;
function WideGetLongHint(const Hint: WideString): WideString;
procedure ProcessCMHintShowMsg(var Message: TMessage);

type
  TTntCustomHintWindow = class(THintWindow)
  private
    FActivating: Boolean;
    FBlockPaint: Boolean;
    function GetCaption: TWideCaption;
    procedure SetCaption(const Value: TWideCaption);
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    procedure CreateWindowHandle(const Params: TCreateParams); override;
{$IFNDEF COMPILER_7_UP}
    procedure CreateParams(var Params: TCreateParams); override;
{$ENDIF}
    procedure Paint; override;
  public
    procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override;
    procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override;
    function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override;
    property Caption: TWideCaption read GetCaption write SetCaption;
  end;

  TTntHintWindow = class(TTntCustomHintWindow)
  public
    procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce;
    procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce;
    function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce;
  end;

// text/char message
function IsTextMessage(Msg: UINT): Boolean;
procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage);
procedure RestoreWMCharMsg(var Message: TMessage);
function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar;
procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar);

// register/create window
procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False);
procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False);
procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams;
                                        const SubClass: WideString; IDEWindow: Boolean = False);
procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False);

type
  IWideCustomListControl = interface
    ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}']
    procedure AddItem(const Item: WideString; AObject: TObject);
  end;

procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject);

var
  _IsShellProgramming: Boolean = False;

var
  TNT_WM_DESTROY: Cardinal;

implementation

uses
  ActnList, Forms, SysUtils, Contnrs, 
  TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils;

type
  TAccessControl = class(TControl);
  TAccessWinControl = class(TWinControl);
  TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink});

//----------------------------------------------- WIDE CAPTION HOLDERS --------

{ TWideControlHelper }

var
  WideControlHelpers: TComponentList = nil;

type
  TWideControlHelper = class(TWideComponentHelper)
  private
    FControl: TControl;
    FWideCaption: WideString;
    FWideHint: WideString;
    procedure SetAnsiText(const Value: AnsiString);
    procedure SetAnsiHint(const Value: AnsiString);
  public
    constructor Create(AOwner: TControl); reintroduce;
    property WideCaption: WideString read FWideCaption;
    property WideHint: WideString read FWideHint;
  end;

constructor TWideControlHelper.Create(AOwner: TControl);
begin
  inherited CreateHelper(AOwner, WideControlHelpers);
  FControl := AOwner;
end;

procedure TWideControlHelper.SetAnsiText(const Value: AnsiString);
begin
  TAccessControl(FControl).Text := Value;
end;

procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString);
begin
  FControl.Hint := Value;
end;

function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper;
begin
  Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control));
  if (Result = nil) and CreateIfNotFound then
  	Result := TWideControlHelper.Create(Control);
end;

//----------------------------------------------- GET/SET WINDOW CAPTION/HINT -------------

function TntControl_IsCaptionStored(Control: TControl): Boolean;
begin
  with TAccessControl(Control) do
    Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked;
end;

function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString;
var
  WideControlHelper: TWideControlHelper;
begin
  WideControlHelper := FindWideControlHelper(Control, False);
  if WideControlHelper <> nil then
    Result := WideControlHelper.WideCaption
  else
    Result := Default;
end;

procedure TntControl_SetStoredText(Control: TControl; const Value: WideString);
begin
  FindWideControlHelper(Control).FWideCaption := Value;
  TAccessControl(Control).Text := Value;
end;

function TntControl_GetText(Control: TControl): WideString;
var
  WideControlHelper: TWideControlHelper;
begin
  if (not Win32PlatformIsUnicode)
  or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then
    // Win9x / non-unicode handle
    Result := TAccessControl(Control).Text
  else if (not (Control is TWinControl)) then begin
    // non-windowed TControl
    WideControlHelper := FindWideControlHelper(Control, False);
    if WideControlHelper = nil then
      Result := TAccessControl(Control).Text
    else
      Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text);
  end else if (not TWinControl(Control).HandleAllocated) then begin
    // NO HANDLE
    Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text)
  end else begin
    // UNICODE & HANDLE
    SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1);
    GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result));
    SetLength(Result, Length(Result) - 1);
  end;
end;

procedure TntControl_SetText(Control: TControl; const Text: WideString);
begin
  if (not Win32PlatformIsUnicode)
  or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then
    // Win9x / non-unicode handle
    TAccessControl(Control).Text := Text
  else if (not (Control is TWinControl)) then begin
    // non-windowed TControl
    with FindWideControlHelper(Control) do
      SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText)
  end else if (not TWinControl(Control).HandleAllocated) then begin
    // NO HANDLE
    TntControl_SetStoredText(Control, Text);
  end else if TntControl_GetText(Control) <> Text then begin
    // UNICODE & HANDLE
    Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text));
    Control.Perform(CM_TEXTCHANGED, 0, 0);
  end;
end;

// hint management -----------------------------------------------------------------------

function TntControl_IsHintStored(Control: TControl): Boolean;
begin
  with TAccessControl(Control) do
    Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked;
end;

function TntControl_GetHint(Control: TControl): WideString;
var
  WideControlHelper: TWideControlHelper;
begin
  if (not Win32PlatformIsUnicode) then
    Result := Control.Hint
  else begin
    WideControlHelper := FindWideControlHelper(Control, False);
    if WideControlHelper <> nil then
      Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint)
    else
      Result := Control.Hint;
  end;
end;

procedure TntControl_SetHint(Control: TControl; const Value: WideString);
begin
  if (not Win32PlatformIsUnicode) then
    Control.Hint := Value
  else
    with FindWideControlHelper(Control) do
      SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint);
end;

function WideGetHint(Control: TControl): WideString;
begin
  while Control <> nil do
    if TntControl_GetHint(Control) = '' then
      Control := Control.Parent
    else
    begin
      Result := TntControl_GetHint(Control);
      Exit;
    end;
  Result := '';
end;

function WideGetShortHint(const Hint: WideString): WideString;
var
  I: Integer;
begin
  I := Pos('|', Hint);
  if I = 0 then
    Result := Hint else
    Result := Copy(Hint, 1, I - 1);
end;

function WideGetLongHint(const Hint: WideString): WideString;
var
  I: Integer;
begin
  I := Pos('|', Hint);
  if I = 0 then
    Result := Hint else
    Result := Copy(Hint, I + 1, Maxint);
end;

//----------------------------------------------------------------------------------------

var UnicodeCreationControl: TWinControl = nil;

function IsUnicodeCreationControl(Handle: HWND): Boolean;
begin
  Result := (UnicodeCreationControl <> nil)
        and (UnicodeCreationControl.HandleAllocated)
        and (UnicodeCreationControl.Handle = Handle);
end;

function WMNotifyFormatResult(FromHandle: HWND): Integer;
begin
  if Win32PlatformIsUnicode
  and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then
    Result := NFR_UNICODE
  else
    Result := NFR_ANSI;
end;

function IsTextMessage(Msg: UINT): Boolean;
begin
  // WM_CHAR is omitted because of the special handling it receives
  Result := (Msg = WM_SETTEXT)
         or (Msg = WM_GETTEXT)
         or (Msg = WM_GETTEXTLENGTH);
end;

const
  ANSI_UNICODE_HOLDER = $FF;

procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage);
begin