tntforms.pas

TNTUniCtrlsWithExceptions UniCode 国际化语言

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

unit TntForms;

{$INCLUDE TntCompilers.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, TntControls;

type
{TNT-WARN TScrollBox}
  TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox})
  private
    FWMSizeCallCount: Integer;
    function IsHintStored: Boolean;
    function GetHint: WideString;
    procedure SetHint(const Value: WideString);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure DefineProperties(Filer: TFiler); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  published
    property Hint: WideString read GetHint write SetHint stored IsHintStored;
  end;

{TNT-WARN TCustomFrame}
  TTntCustomFrame = class(TCustomFrame{TNT-ALLOW TCustomFrame})
  private
    function IsHintStored: Boolean;
    function GetHint: WideString;
    procedure SetHint(const Value: WideString);
  protected
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure DefineProperties(Filer: TFiler); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  published
    property Hint: WideString read GetHint write SetHint stored IsHintStored;
  end;

{TNT-WARN TFrame}
  TTntFrame = class(TTntCustomFrame)
  published
    property Align;
    property Anchors;
    property AutoScroll;
    property AutoSize;
    property BiDiMode;
    property Constraints;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Color nodefault;
    property Ctl3D;
    property Font;
    {$IFDEF COMPILER_10_UP}
    property Padding;
    {$ENDIF}
    {$IFDEF COMPILER_7_UP}
    property ParentBackground default True;
    {$ENDIF}
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    {$IFDEF COMPILER_9_UP}
    property OnAlignInsertBefore;
    property OnAlignPosition;
    {$ENDIF}
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDblClick;
    property OnDockDrop;
    property OnDockOver;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    {$IFDEF COMPILER_9_UP}
    property OnMouseActivate;
    {$ENDIF}
    property OnMouseDown;
    {$IFDEF COMPILER_10_UP}
    property OnMouseEnter;
    property OnMouseLeave;
    {$ENDIF}
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

{TNT-WARN TForm}
  TTntForm = class(TForm{TNT-ALLOW TForm})
  private
    function GetCaption: TWideCaption;
    procedure SetCaption(const Value: TWideCaption);
    function GetHint: WideString;
    procedure SetHint(const Value: WideString);
    function IsCaptionStored: Boolean;
    function IsHintStored: Boolean;
    procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
    procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING;
  protected
    procedure UpdateActions; override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;
    procedure DestroyWindowHandle; override;
    procedure DefineProperties(Filer: TFiler); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    function CreateDockManager: IDockManager; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure DefaultHandler(var Message); override;
  published
    property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored;
    property Hint: WideString read GetHint write SetHint stored IsHintStored;
  end;

  TTntApplication = class(TComponent)
  private
    FMainFormChecked: Boolean;
    FHint: WideString;
    FTntAppIdleEventControl: TControl;
    FSettingChangeTime: Cardinal;
    FTitle: WideString;
    function GetHint: WideString;
    procedure SetAnsiAppHint(const Value: AnsiString);
    procedure SetHint(const Value: WideString);
    function GetExeName: WideString;
    function IsDlgMsg(var Msg: TMsg): Boolean;
    procedure DoIdle;
    function GetTitle: WideString;
    procedure SetTitle(const Value: WideString);
    procedure SetAnsiApplicationTitle(const Value: AnsiString);
    function ApplicationMouseControlHint: WideString;
  protected
    function WndProc(var Message: TMessage): Boolean;
    function ProcessMessage(var Msg: TMsg): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function MessageBox(const Text, Caption: PWideChar; Flags: Longint): Integer;
    procedure ShowException(E: Exception);
    property Hint: WideString read GetHint write SetHint;
    property ExeName: WideString read GetExeName;
    property SettingChangeTime: Cardinal read FSettingChangeTime;
    property Title: WideString read GetTitle write SetTitle;
  end;

{TNT-WARN IsAccel}
function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;

{TNT-WARN PeekMessage}
{TNT-WARN PeekMessageA}
{TNT-WARN PeekMessageW}
procedure EnableManualPeekMessageWithRemove;
procedure DisableManualPeekMessageWithRemove;

type
  TFormProc = procedure (Form: TForm{TNT-ALLOW TForm});

var
  TntApplication: TTntApplication;

procedure InitTntEnvironment;
  
implementation

uses
  Consts, RTLConsts, Menus, FlatSB, StdActns, Graphics, MultiMon,
  TntSystem, TntSysUtils, TntMenus, TntActnList, TntStdActns, TntClasses;

function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;
var
  W: WideChar;
begin
  W := KeyUnicode(CharCode);
  Result := WideSameText(W, WideGetHotKey(Caption));
end;

{ TTntScrollBox }

procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams);
begin
  CreateUnicodeHandle(Self, Params, '');
end;

procedure TTntScrollBox.DefineProperties(Filer: TFiler);
begin
  inherited;
  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
end;

function TTntScrollBox.IsHintStored: Boolean;
begin
  Result := TntControl_IsHintStored(Self);
end;

function TTntScrollBox.GetHint: WideString;
begin
  Result := TntControl_GetHint(Self);
end;

procedure TTntScrollBox.SetHint(const Value: WideString);
begin
  TntControl_SetHint(Self, Value);
end;

procedure TTntScrollBox.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
  inherited;
end;

function TTntScrollBox.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
end;

procedure TTntScrollBox.WMSize(var Message: TWMSize);
begin
  Inc(FWMSizeCallCount);
  try
    if FWMSizeCallCount < 32 then { Infinite recursion was encountered on Win 9x. }
      inherited;
  finally
    Dec(FWMSizeCallCount);
  end;
end;

{ TTntCustomFrame }

procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams);
begin
  CreateUnicodeHandle(Self, Params, '');
end;

procedure TTntCustomFrame.DefineProperties(Filer: TFiler);
begin
  inherited;
  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
end;

function TTntCustomFrame.IsHintStored: Boolean;
begin
  Result := TntControl_IsHintStored(Self);
end;

function TTntCustomFrame.GetHint: WideString;
begin
  Result := TntControl_GetHint(Self);
end;

procedure TTntCustomFrame.SetHint(const Value: WideString);
begin
  TntControl_SetHint(Self, Value);
end;

procedure TTntCustomFrame.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
  inherited;
end;

function TTntCustomFrame.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
end;

{ TTntForm }

constructor TTntForm.Create(AOwner: TComponent);
begin
  // standard construction technique (look at TForm.Create)
  GlobalNameSpace.BeginWrite;
  try
    CreateNew(AOwner);
    if (ClassType <> TTntForm) and not (csDesigning in ComponentState) then
    begin
      Include(FFormState, fsCreating);
      try
        if not InitInheritedComponent(Self, TTntForm) then
          raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
      finally
        Exclude(FFormState, fsCreating);
      end;
      if OldCreateOrder then DoCreate;
    end;
  finally
    GlobalNameSpace.EndWrite;
  end;
end;

procedure TTntForm.CreateWindowHandle(const Params: TCreateParams);
var
  NewParams: TCreateParams;
  WideWinClassName: WideString;
begin
  if (not Win32PlatformIsUnicode) then
    inherited
  else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
  begin
    if (Application.MainForm = nil) or
      (Application.MainForm.ClientHandle = 0) then
        raise EInvalidOperation.Create(SNoMDIForm);
    RegisterUnicodeClass(Params, WideWinClassName);
    DefWndProc := @DefMDIChildProcW;
    WindowHandle := CreateMDIWindowW(PWideChar(WideWinClassName),
      nil, Params.style, Params.X, Params.Y, Params.Width, Params.Height,
        Application.MainForm.ClientHandle, hInstance, Longint(Params.Param));
    if WindowHandle = 0 then
      RaiseLastOSError;
    SubClassUnicodeControl(Self, Params.Caption);
    Include(FFormState, fsCreatedMDIChild);
  end else
  begin
    NewParams := Params;
    NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED;
    CreateUnicodeHandle(Self, NewParams, '');
    Exclude(FFormState, fsCreatedMDIChild);
  end;
  if AlphaBlend then begin
    // toggle AlphaBlend to force update
    AlphaBlend := False;
    AlphaBlend := True;
  end else if TransparentColor then begin
    // toggle TransparentColor to force update
    TransparentColor := False;
    TransparentColor := True;
  end;
end;

procedure TTntForm.DestroyWindowHandle;
begin
  if Win32PlatformIsUnicode then
    UninitializeFlatSB(Handle); { Bug in VCL: Without this there might be a resource leak. }
  inherited;
end;

procedure TTntForm.DefineProperties(Filer: TFiler);
begin
  inherited;
  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
end;

procedure TTntForm.DefaultHandler(var Message);
begin
  if (ClientHandle <> 0)
  and (Win32PlatformIsUnicode) then begin
    with TMessage(Message) do begin
      if (Msg = WM_SIZE) then
        Result := DefWindowProcW(Handle, Msg, wParam, lParam)
      else
        Result := DefFrameProcW(Handle, ClientHandle, Msg, wParam, lParam);
      if (Msg = WM_DESTROY) then
         Perform(TNT_WM_DESTROY, 0, 0); { This ensures that the control is Unsubclassed. }
    end;
  end else
    inherited DefaultHandler(Message);
end;

function TTntForm.IsCaptionStored: Boolean;
begin
  Result := TntControl_IsCaptionStored(Self);
end;

function TTntForm.GetCaption: TWideCaption;
begin
  Result := TntControl_GetText(Self)
end;

procedure TTntForm.SetCaption(const Value: TWideCaption);
begin
  TntControl_SetText(Self, Value)
end;

function TTntForm.IsHintStored: Boolean;
begin
  Result := TntControl_IsHintStored(Self);
end;

function TTntForm.GetHint: WideString;
begin
  Result := TntControl_GetHint(Self)
end;

procedure TTntForm.SetHint(const Value: WideString);
begin
  TntControl_SetHint(Self, Value);
end;

procedure TTntForm.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
  inherited;
end;

function TTntForm.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
end;

procedure TTntForm.WMMenuSelect(var Message: TWMMenuSelect);
var
  MenuItem: TMenuItem{TNT-ALLOW TMenuItem};
  ID: Integer;
  FindKind: TFindItemKind;
begin
  if Menu <> nil then
    with Message do
    begin
      MenuItem := nil;
      if (MenuFlag <> $FFFF) or (IDItem <> 0) then
      begin
        FindKind := fkCommand;
        ID := IDItem;
        if MenuFlag and MF_POPUP <> 0 then
        begin
          FindKind := fkHandle;
          ID := Integer(GetSubMenu(Menu, ID));
        end;
        MenuItem := Self.Menu.FindItem(ID, FindKind);
      end;
      if MenuItem <> nil then
        TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem))
      else
        TntApplication.Hint := '';
    end;
end;

procedure TTntForm.UpdateActions;
begin
  inherited;
  TntApplication.DoIdle;
end;

procedure TTntForm.CMBiDiModeChanged(var Message: TMessage);
var
  Loop: Integer;
begin
  inherited;
  for Loop := 0 to ComponentCount - 1 do
    if Components[Loop] is TMenu then
      FixMenuBiDiProblem(TMenu(Components[Loop]));
end;