From 194923c172167eb3fc33807ec8009b255f86337e Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 09:10:06 +0000 Subject: Plugin is not adapted until someone can compile it and tell others how to do the same git-svn-id: http://svn.miranda-ng.org/main/trunk@1809 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- .../lib/TntUnicodeControls/Source/TntForms.pas | 873 +++++++++++++++++++++ 1 file changed, 873 insertions(+) create mode 100644 plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas (limited to 'plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas') diff --git a/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas new file mode 100644 index 0000000000..780005714e --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntForms.pas @@ -0,0 +1,873 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntForms; + +{$INCLUDE TntCompilers.inc} + +interface + +uses + Classes, Windows, Messages, Controls, Forms, TntControls; + +type +{TNT-WARN TScrollBox} + TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox}) + private + FWMSizeCallCount: Integer; + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + procedure WMSize(var Message: TWMSize); message WM_SIZE; + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TCustomFrame} + TTntCustomFrame = class(TCustomFrame{TNT-ALLOW TCustomFrame}) + private + function IsHintStored: Boolean; + function GetHint: WideString; + procedure SetHint(const Value: WideString); + protected + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + published + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + +{TNT-WARN TFrame} + TTntFrame = class(TTntCustomFrame) + published + property Align; + property Anchors; + property AutoScroll; + property AutoSize; + property BiDiMode; + property Constraints; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Color nodefault; + property Ctl3D; + property Font; + {$IFDEF COMPILER_10_UP} + property Padding; + {$ENDIF} + {$IFDEF COMPILER_7_UP} + property ParentBackground default True; + {$ENDIF} + property ParentBiDiMode; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + {$IFDEF COMPILER_9_UP} + property OnAlignInsertBefore; + property OnAlignPosition; + {$ENDIF} + property OnCanResize; + property OnClick; + property OnConstrainedResize; + property OnContextPopup; + property OnDblClick; + property OnDockDrop; + property OnDockOver; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetSiteInfo; + {$IFDEF COMPILER_9_UP} + property OnMouseActivate; + {$ENDIF} + property OnMouseDown; + {$IFDEF COMPILER_10_UP} + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + +{TNT-WARN TForm} + TTntForm = class(TForm{TNT-ALLOW TForm}) + private + function GetCaption: TWideCaption; + procedure SetCaption(const Value: TWideCaption); + function GetHint: WideString; + procedure SetHint(const Value: WideString); + function IsCaptionStored: Boolean; + function IsHintStored: Boolean; + procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT; + procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED; + procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING; + protected + procedure UpdateActions; override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure DestroyWindowHandle; override; + procedure DefineProperties(Filer: TFiler); override; + function GetActionLinkClass: TControlActionLinkClass; override; + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + function CreateDockManager: IDockManager; override; + public + constructor Create(AOwner: TComponent); override; + procedure DefaultHandler(var Message); override; + published + property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; + property Hint: WideString read GetHint write SetHint stored IsHintStored; + end; + + TTntApplication = class(TComponent) + private + FMainFormChecked: Boolean; + FHint: WideString; + FTntAppIdleEventControl: TControl; + FSettingChangeTime: Cardinal; + FTitle: WideString; + function GetHint: WideString; + procedure SetAnsiAppHint(const Value: AnsiString); + procedure SetHint(const Value: WideString); + function GetExeName: WideString; + function IsDlgMsg(var Msg: TMsg): Boolean; + procedure DoIdle; + function GetTitle: WideString; + procedure SetTitle(const Value: WideString); + procedure SetAnsiApplicationTitle(const Value: AnsiString); + function ApplicationMouseControlHint: WideString; + protected + function WndProc(var Message: TMessage): Boolean; + function ProcessMessage(var Msg: TMsg): Boolean; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Hint: WideString read GetHint write SetHint; + property ExeName: WideString read GetExeName; + property SettingChangeTime: Cardinal read FSettingChangeTime; + property Title: WideString read GetTitle write SetTitle; + end; + +{TNT-WARN IsAccel} +function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; + +{TNT-WARN PeekMessage} +{TNT-WARN PeekMessageA} +{TNT-WARN PeekMessageW} +procedure EnableManualPeekMessageWithRemove; +procedure DisableManualPeekMessageWithRemove; + +type + TFormProc = procedure (Form: TForm{TNT-ALLOW TForm}); + +var + TntApplication: TTntApplication; + +procedure InitTntEnvironment; + +implementation + +uses + SysUtils, Consts, RTLConsts, Menus, FlatSB, StdActns, + Graphics, TntSystem, TntSysUtils, TntMenus, TntActnList, TntStdActns, TntClasses; + +function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean; +var + W: WideChar; +begin + W := KeyUnicode(CharCode); + Result := WideSameText(W, WideGetHotKey(Caption)); +end; + +{ TTntScrollBox } + +procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntScrollBox.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntScrollBox.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntScrollBox.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntScrollBox.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntScrollBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntScrollBox.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntScrollBox.WMSize(var Message: TWMSize); +begin + Inc(FWMSizeCallCount); + try + if FWMSizeCallCount < 32 then { Infinite recursion was encountered on Win 9x. } + inherited; + finally + Dec(FWMSizeCallCount); + end; +end; + +{ TTntCustomFrame } + +procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams); +begin + CreateUnicodeHandle(Self, Params, ''); +end; + +procedure TTntCustomFrame.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +function TTntCustomFrame.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntCustomFrame.GetHint: WideString; +begin + Result := TntControl_GetHint(Self); +end; + +procedure TTntCustomFrame.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntCustomFrame.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntCustomFrame.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +{ TTntForm } + +constructor TTntForm.Create(AOwner: TComponent); +begin + // standard construction technique (look at TForm.Create) + GlobalNameSpace.BeginWrite; + try + CreateNew(AOwner); + if (ClassType <> TTntForm) and not (csDesigning in ComponentState) then + begin + Include(FFormState, fsCreating); + try + if not InitInheritedComponent(Self, TTntForm) then + raise EResNotFound.CreateFmt(SResNotFound, [ClassName]); + finally + Exclude(FFormState, fsCreating); + end; + if OldCreateOrder then DoCreate; + end; + finally + GlobalNameSpace.EndWrite; + end; +end; + +procedure TTntForm.CreateWindowHandle(const Params: TCreateParams); +var + NewParams: TCreateParams; + WideWinClassName: WideString; +begin + if (not Win32PlatformIsUnicode) then + inherited + else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then + begin + if (Application.MainForm = nil) or + (Application.MainForm.ClientHandle = 0) then + raise EInvalidOperation.Create(SNoMDIForm); + RegisterUnicodeClass(Params, WideWinClassName); + DefWndProc := @DefMDIChildProcW; + WindowHandle := CreateMDIWindowW(PWideChar(WideWinClassName), + nil, Params.style, Params.X, Params.Y, Params.Width, Params.Height, + Application.MainForm.ClientHandle, hInstance, Longint(Params.Param)); + if WindowHandle = 0 then + RaiseLastOSError; + SubClassUnicodeControl(Self, Params.Caption); + Include(FFormState, fsCreatedMDIChild); + end else + begin + NewParams := Params; + NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED; + CreateUnicodeHandle(Self, NewParams, ''); + Exclude(FFormState, fsCreatedMDIChild); + end; + if AlphaBlend then begin + // toggle AlphaBlend to force update + AlphaBlend := False; + AlphaBlend := True; + end else if TransparentColor then begin + // toggle TransparentColor to force update + TransparentColor := False; + TransparentColor := True; + end; +end; + +procedure TTntForm.DestroyWindowHandle; +begin + if Win32PlatformIsUnicode then + UninitializeFlatSB(Handle); { Bug in VCL: Without this there might be a resource leak. } + inherited; +end; + +procedure TTntForm.DefineProperties(Filer: TFiler); +begin + inherited; + TntPersistent_AfterInherited_DefineProperties(Filer, Self); +end; + +procedure TTntForm.DefaultHandler(var Message); +begin + if (ClientHandle <> 0) + and (Win32PlatformIsUnicode) then begin + with TMessage(Message) do begin + if (Msg = WM_SIZE) then + Result := DefWindowProcW(Handle, Msg, wParam, lParam) + else + Result := DefFrameProcW(Handle, ClientHandle, Msg, wParam, lParam); + if (Msg = WM_DESTROY) then + Perform(TNT_WM_DESTROY, 0, 0); { This ensures that the control is Unsubclassed. } + end; + end else + inherited DefaultHandler(Message); +end; + +function TTntForm.IsCaptionStored: Boolean; +begin + Result := TntControl_IsCaptionStored(Self); +end; + +function TTntForm.GetCaption: TWideCaption; +begin + Result := TntControl_GetText(Self) +end; + +procedure TTntForm.SetCaption(const Value: TWideCaption); +begin + TntControl_SetText(Self, Value) +end; + +function TTntForm.IsHintStored: Boolean; +begin + Result := TntControl_IsHintStored(Self); +end; + +function TTntForm.GetHint: WideString; +begin + Result := TntControl_GetHint(Self) +end; + +procedure TTntForm.SetHint(const Value: WideString); +begin + TntControl_SetHint(Self, Value); +end; + +procedure TTntForm.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); + inherited; +end; + +function TTntForm.GetActionLinkClass: TControlActionLinkClass; +begin + Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); +end; + +procedure TTntForm.WMMenuSelect(var Message: TWMMenuSelect); +var + MenuItem: TMenuItem{TNT-ALLOW TMenuItem}; + ID: Integer; + FindKind: TFindItemKind; +begin + if Menu <> nil then + with Message do + begin + MenuItem := nil; + if (MenuFlag <> $FFFF) or (IDItem <> 0) then + begin + FindKind := fkCommand; + ID := IDItem; + if MenuFlag and MF_POPUP <> 0 then + begin + FindKind := fkHandle; + ID := Integer(GetSubMenu(Menu, ID)); + end; + MenuItem := Self.Menu.FindItem(ID, FindKind); + end; + if MenuItem <> nil then + TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem)) + else + TntApplication.Hint := ''; + end; +end; + +procedure TTntForm.UpdateActions; +begin + inherited; + TntApplication.DoIdle; +end; + +procedure TTntForm.CMBiDiModeChanged(var Message: TMessage); +var + Loop: Integer; +begin + inherited; + for Loop := 0 to ComponentCount - 1 do + if Components[Loop] is TMenu then + FixMenuBiDiProblem(TMenu(Components[Loop])); +end; + +procedure TTntForm.WMWindowPosChanging(var Message: TMessage); +begin + inherited; + // This message *sometimes* means that the Menu.BiDiMode changed. + FixMenuBiDiProblem(Menu); +end; + +function TTntForm.CreateDockManager: IDockManager; +begin + if (DockManager = nil) and DockSite and UseDockManager then + HandleNeeded; // force TNT subclassing to occur first + Result := inherited CreateDockManager; +end; + +{ TTntApplication } + +constructor TTntApplication.Create(AOwner: TComponent); +begin + inherited; + Application.HookMainWindow(WndProc); + FSettingChangeTime := GetTickCount; + TntSysUtils._SettingChangeTime := GetTickCount; +end; + +destructor TTntApplication.Destroy; +begin + FreeAndNil(FTntAppIdleEventControl); + Application.UnhookMainWindow(WndProc); + inherited; +end; + +function TTntApplication.GetHint: WideString; +begin + // check to see if the hint has already been set on application.idle + if Application.Hint = AnsiString(ApplicationMouseControlHint) then + FHint := ApplicationMouseControlHint; + // get the synced string + Result := GetSyncedWideString(FHint, Application.Hint) +end; + +procedure TTntApplication.SetAnsiAppHint(const Value: AnsiString); +begin + Application.Hint := Value; +end; + +procedure TTntApplication.SetHint(const Value: WideString); +begin + SetSyncedWideString(Value, FHint, Application.Hint, SetAnsiAppHint); +end; + +function TTntApplication.GetExeName: WideString; +begin + Result := WideParamStr(0); +end; + +function TTntApplication.GetTitle: WideString; +begin + if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin + SetLength(Result, DefWindowProcW(Application.Handle, WM_GETTEXTLENGTH, 0, 0) + 1); + DefWindowProcW(Application.Handle, WM_GETTEXT, Length(Result), Integer(PWideChar(Result))); + SetLength(Result, Length(Result) - 1); + end else + Result := GetSyncedWideString(FTitle, Application.Title); +end; + +procedure TTntApplication.SetAnsiApplicationTitle(const Value: AnsiString); +begin + Application.Title := Value; +end; + +procedure TTntApplication.SetTitle(const Value: WideString); +begin + if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin + if (GetTitle <> Value) or (FTitle <> '') then begin + DefWindowProcW(Application.Handle, WM_SETTEXT, 0, lParam(PWideChar(Value))); + FTitle := ''; + end + end else + SetSyncedWideString(Value, FTitle, Application.Title, SetAnsiApplicationTitle); +end; + +{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} +{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 +type + THackApplication = class(TComponent) + protected + FxxxxxxxxxHandle: HWnd; + FxxxxxxxxxBiDiMode: TBiDiMode; + FxxxxxxxxxBiDiKeyboard: AnsiString; + FxxxxxxxxxNonBiDiKeyboard: AnsiString; + FxxxxxxxxxObjectInstance: Pointer; + FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm}; + FMouseControl: TControl; + end; +{$ENDIF} + +function TTntApplication.ApplicationMouseControlHint: WideString; +var + MouseControl: TControl; +begin + MouseControl := THackApplication(Application).FMouseControl; + Result := WideGetLongHint(WideGetHint(MouseControl)); +end; + +procedure TTntApplication.DoIdle; +begin + // update TntApplication.Hint only when Ansi encodings are the same... (otherwise there are problems with action menus) + if Application.Hint = AnsiString(ApplicationMouseControlHint) then + Hint := ApplicationMouseControlHint; +end; + +function TTntApplication.IsDlgMsg(var Msg: TMsg): Boolean; +begin + Result := False; + if (Application.DialogHandle <> 0) then begin + if IsWindowUnicode(Application.DialogHandle) then + Result := IsDialogMessageW(Application.DialogHandle, Msg) + else + Result := IsDialogMessageA(Application.DialogHandle, Msg); + end; +end; + +type + TTntAppIdleEventControl = class(TControl) + protected + procedure OnIdle(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +constructor TTntAppIdleEventControl.Create(AOwner: TComponent); +begin + inherited; + ParentFont := False; { This allows Parent (Application) to be in another module. } + Parent := Application.MainForm; + Visible := True; + Action := TTntAction.Create(Self); + Action.OnExecute := OnIdle; + Action.OnUpdate := OnIdle; + TntApplication.FTntAppIdleEventControl := Self; +end; + +destructor TTntAppIdleEventControl.Destroy; +begin + if TntApplication <> nil then + TntApplication.FTntAppIdleEventControl := nil; + inherited; +end; + +procedure TTntAppIdleEventControl.OnIdle(Sender: TObject); +begin + TntApplication.DoIdle; +end; + +function TTntApplication.ProcessMessage(var Msg: TMsg): Boolean; +var + Handled: Boolean; +begin + Result := False; + // Check Main Form + if (not FMainFormChecked) and (Application.MainForm <> nil) then begin + if not (Application.MainForm is TTntForm) then begin + // This control will help ensure that DoIdle is called + TTntAppIdleEventControl.Create(Application.MainForm); + end; + FMainFormChecked := True; + end; + // Check for Unicode char messages + if (Msg.message = WM_CHAR) + and (Msg.wParam > Integer(High(AnsiChar))) + and IsWindowUnicode(Msg.hwnd) + and ((Application.DialogHandle = 0) or IsWindowUnicode(Application.DialogHandle)) + then begin + Result := True; + // more than 8-bit WM_CHAR destined for Unicode window + Handled := False; + if Assigned(Application.OnMessage) then + Application.OnMessage(Msg, Handled); + Application.CancelHint; + // dispatch msg if not a dialog message + if (not Handled) and (not IsDlgMsg(Msg)) then + DispatchMessageW(Msg); + end; +end; + +function TTntApplication.WndProc(var Message: TMessage): Boolean; +var + BasicAction: TBasicAction; +begin + Result := False; { not handled } + if (Message.Msg = WM_SETTINGCHANGE) then begin + FSettingChangeTime := GetTickCount; + TntSysUtils._SettingChangeTime := FSettingChangeTime; + end; + if (Message.Msg = WM_CREATE) + and (FTitle <> '') then begin + SetTitle(FTitle); + FTitle := ''; + end; + if (Message.Msg = CM_ACTIONEXECUTE) then begin + BasicAction := TBasicAction(Message.LParam); + if (BasicAction.ClassType = THintAction{TNT-ALLOW THintAction}) + and (THintAction{TNT-ALLOW THintAction}(BasicAction).Hint = AnsiString(Hint)) + then begin + Result := True; + Message.Result := 1; + with TTntHintAction.Create(Self) do + begin + Hint := Self.Hint; + try + Execute; + finally + Free; + end; + end; + end; + end; +end; + +//=========================================================================== +// The NT GetMessage Hook is needed to support entering Unicode +// characters directly from the keyboard (bypassing the IME). +// Special thanks go to Francisco Leong for developing this solution. +// +// Example: +// 1. Install "Turkic" language support. +// 2. Add "Azeri (Latin)" as an input locale. +// 3. In an EDIT, enter Shift+I. (You should see a capital "I" with dot.) +// 4. In an EDIT, enter single quote (US Keyboard). (You should see an upturned "e".) +// +var + ManualPeekMessageWithRemove: Integer = 0; + +procedure EnableManualPeekMessageWithRemove; +begin + Inc(ManualPeekMessageWithRemove); +end; + +procedure DisableManualPeekMessageWithRemove; +begin + if (ManualPeekMessageWithRemove > 0) then + Dec(ManualPeekMessageWithRemove); +end; + +var + NTGetMessageHook: HHOOK; + +function GetMessageForNT(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall; +var + ThisMsg: PMSG; +begin + if (Code >= 0) + and (wParam = PM_REMOVE) + and (ManualPeekMessageWithRemove = 0) then + begin + ThisMsg := PMSG(lParam); + if (TntApplication <> nil) + and TntApplication.ProcessMessage(ThisMsg^) then + ThisMsg.message := WM_NULL; { clear for further processing } + end; + Result := CallNextHookEx(NTGetMessageHook, Code, wParam, lParam); +end; + +procedure CreateGetMessageHookForNT; +begin + Assert(Win32Platform = VER_PLATFORM_WIN32_NT); + NTGetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, GetMessageForNT, 0, GetCurrentThreadID); + if NTGetMessageHook = 0 then + RaiseLastOSError; +end; + +//--------------------------------------------------------------------------------------------- +// Tnt Environment Setup +//--------------------------------------------------------------------------------------------- + +procedure InitTntEnvironment; + + function GetDefaultFont: WideString; + + function RunningUnderIDE: Boolean; + begin + Result := ModuleIsPackage and + ( WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bds.exe') + or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'delphi32.exe') + or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bcb.exe')); + end; + + function GetProfileStr(const Section, Key, Default: AnsiString; MaxLen: Integer): AnsiString; + var + Len: Integer; + begin + SetLength(Result, MaxLen + 1); + Len := GetProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Default), + PAnsiChar(Result), Length(Result)); + SetLength(Result, Len); + end; + + procedure SetProfileStr(const Section, Key, Value: AnsiString); + var + DummyResult: Cardinal; + begin + try + Win32Check(WriteProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Value))); + if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then + WriteProfileString(nil, nil, nil); {this flushes the WIN.INI cache} + SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PAnsiChar(Section)), + SMTO_NORMAL, 250, DummyResult); + except + on E: Exception do begin + E.Message := 'Couldn''t create font substitutes.' + CRLF + E.Message; + Application.HandleException(nil); + end; + end; + end; + + var + ShellDlgFontName_1: WideString; + ShellDlgFontName_2: WideString; + begin + ShellDlgFontName_1 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg', '', LF_FACESIZE); + if ShellDlgFontName_1 = '' then begin + ShellDlgFontName_1 := 'MS Sans Serif'; + SetProfileStr('FontSubstitutes', 'MS Shell Dlg', ShellDlgFontName_1); + end; + ShellDlgFontName_2 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', '', LF_FACESIZE); + if ShellDlgFontName_2 = '' then begin + if Screen.Fonts.IndexOf('Tahoma') <> -1 then + ShellDlgFontName_2 := 'Tahoma' + else + ShellDlgFontName_2 := ShellDlgFontName_1; + SetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', ShellDlgFontName_2); + end; + if RunningUnderIDE then begin + Result := 'MS Shell Dlg 2' {Delphi is running} + end else + Result := ShellDlgFontName_2; + end; + +begin + // Tnt Environment Setup + InstallTntSystemUpdates; + DefFontData.Name := GetDefaultFont; + Forms.HintWindowClass := TntControls.TTntHintWindow; +end; + +initialization + TntApplication := TTntApplication.Create(nil); + if Win32Platform = VER_PLATFORM_WIN32_NT then + CreateGetMessageHookForNT; + +finalization + if NTGetMessageHook <> 0 then begin + UnhookWindowsHookEx(NTGetMessageHook) // no Win32Check, fails in too many cases, and doesn't matter + end; + FreeAndNil(TntApplication); + +end. -- cgit v1.2.3