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/TntControls.pas | 1099 -------------------- 1 file changed, 1099 deletions(-) delete mode 100644 plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas (limited to 'plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas') diff --git a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas deleted file mode 100644 index 55025ecdc2..0000000000 --- a/plugins/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas +++ /dev/null @@ -1,1099 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntControls; - -{$INCLUDE TntCompilers.inc} - -{ - Windows NT provides support for native Unicode windows. To add Unicode support to a - TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle(). - - One major reason this works is because the VCL only uses the ANSI version of - SendMessage() -- SendMessageA(). If you call SendMessageA() on a UNICODE - window, Windows deals with the ANSI/UNICODE conversion automatically. So - for example, if the VCL sends WM_SETTEXT to a window using SendMessageA, - Windows actually *expects* a PAnsiChar even if the target window is a UNICODE - window. So caling SendMessageA with PChars causes no problems. - - A problem in the VCL has to do with the TControl.Perform() method. Perform() - calls the window procedure directly and assumes an ANSI window. This is a - problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a - PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar. - - This is the reason for SubClassUnicodeControl(). This procedure will subclass the - Windows WndProc, and the TWinControl.WindowProc pointer. It will determine if the - message came from Windows or if the WindowProc was called directly. It will then - call SendMessageA() for Windows to perform proper conversion on certain text messages. - - Another problem has to do with TWinControl.DoKeyPress(). It is called from the WM_CHAR - message. It casts the WideChar to an AnsiChar, and sends the resulting character to - DefWindowProc. In order to avoid this, the DefWindowProc is subclassed as well. WindowProc - will make a WM_CHAR message safe for ANSI handling code by converting the char code to - #FF before passing it on. It stores the original WideChar in the .Unused field of TWMChar. - The code #FF is converted back to the WideChar before passing onto DefWindowProc. -} - -{ - Things to consider when designing new controls: - 1) Check that a WideString Hint property is published. - 2) If descending from TWinControl, override CreateWindowHandle(). - 3) If not descending from TWinControl, handle CM_HINTSHOW message. - 4) Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly. - 5) If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd. - 6) Consider using storage specifiers for Hint and Caption properties. - 7) If any class could possibly have published WideString properties, - override DefineProperties and call TntPersistent_AfterInherited_DefineProperties. - 8) Check if TTntThemeManager needs to be updated. - 9) Override GetActionLinkClass() and ActionChange(). - 10) If class updates Application.Hint then update TntApplication.Hint instead. -} - -interface - -{ TODO: Unicode enable .OnKeyPress event } - -uses - Classes, Windows, Messages, Controls, Menus; - - -{TNT-WARN TCaption} -type TWideCaption = type WideString; - -// caption/text management -function TntControl_IsCaptionStored(Control: TControl): Boolean; -function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; -procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); -function TntControl_GetText(Control: TControl): WideString; -procedure TntControl_SetText(Control: TControl; const Text: WideString); - -// hint management -function TntControl_IsHintStored(Control: TControl): Boolean; -function TntControl_GetHint(Control: TControl): WideString; -procedure TntControl_SetHint(Control: TControl; const Value: WideString); - -function WideGetHint(Control: TControl): WideString; -function WideGetShortHint(const Hint: WideString): WideString; -function WideGetLongHint(const Hint: WideString): WideString; -procedure ProcessCMHintShowMsg(var Message: TMessage); - -type - TTntCustomHintWindow = class(THintWindow) - private - FActivating: Boolean; - FBlockPaint: Boolean; - function GetCaption: TWideCaption; - procedure SetCaption(const Value: TWideCaption); - procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; - protected - procedure CreateWindowHandle(const Params: TCreateParams); override; -{$IFNDEF COMPILER_7_UP} - procedure CreateParams(var Params: TCreateParams); override; -{$ENDIF} - procedure Paint; override; - public - procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override; - procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override; - function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override; - property Caption: TWideCaption read GetCaption write SetCaption; - end; - - TTntHintWindow = class(TTntCustomHintWindow) - public - procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce; - procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce; - function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce; - end; - -// text/char message -function IsTextMessage(Msg: UINT): Boolean; -procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); -procedure RestoreWMCharMsg(var Message: TMessage); -function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; -procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); - -// register/create window -procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); -procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); -procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; - const SubClass: WideString; IDEWindow: Boolean = False); -procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); - -type - IWideCustomListControl = interface - ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}'] - procedure AddItem(const Item: WideString; AObject: TObject); - end; - -procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); - -var - _IsShellProgramming: Boolean = False; - -var - TNT_WM_DESTROY: Cardinal; - -implementation - -uses - ActnList, Forms, SysUtils, Contnrs, - TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils; - -type - TAccessControl = class(TControl); - TAccessWinControl = class(TWinControl); - TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink}); - -//----------------------------------------------- WIDE CAPTION HOLDERS -------- - -{ TWideControlHelper } - -var - WideControlHelpers: TComponentList = nil; - -type - TWideControlHelper = class(TWideComponentHelper) - private - FControl: TControl; - FWideCaption: WideString; - FWideHint: WideString; - procedure SetAnsiText(const Value: AnsiString); - procedure SetAnsiHint(const Value: AnsiString); - public - constructor Create(AOwner: TControl); reintroduce; - property WideCaption: WideString read FWideCaption; - property WideHint: WideString read FWideHint; - end; - -constructor TWideControlHelper.Create(AOwner: TControl); -begin - inherited CreateHelper(AOwner, WideControlHelpers); - FControl := AOwner; -end; - -procedure TWideControlHelper.SetAnsiText(const Value: AnsiString); -begin - TAccessControl(FControl).Text := Value; -end; - -procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString); -begin - FControl.Hint := Value; -end; - -function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper; -begin - Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control)); - if (Result = nil) and CreateIfNotFound then - Result := TWideControlHelper.Create(Control); -end; - -//----------------------------------------------- GET/SET WINDOW CAPTION/HINT ------------- - -function TntControl_IsCaptionStored(Control: TControl): Boolean; -begin - with TAccessControl(Control) do - Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked; -end; - -function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString; -var - WideControlHelper: TWideControlHelper; -begin - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper <> nil then - Result := WideControlHelper.WideCaption - else - Result := Default; -end; - -procedure TntControl_SetStoredText(Control: TControl; const Value: WideString); -begin - FindWideControlHelper(Control).FWideCaption := Value; - TAccessControl(Control).Text := Value; -end; - -function TntControl_GetText(Control: TControl): WideString; -var - WideControlHelper: TWideControlHelper; -begin - if (not Win32PlatformIsUnicode) - or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then - // Win9x / non-unicode handle - Result := TAccessControl(Control).Text - else if (not (Control is TWinControl)) then begin - // non-windowed TControl - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper = nil then - Result := TAccessControl(Control).Text - else - Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text); - end else if (not TWinControl(Control).HandleAllocated) then begin - // NO HANDLE - Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text) - end else begin - // UNICODE & HANDLE - SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1); - GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result)); - SetLength(Result, Length(Result) - 1); - end; -end; - -procedure TntControl_SetText(Control: TControl; const Text: WideString); -begin - if (not Win32PlatformIsUnicode) - or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then - // Win9x / non-unicode handle - TAccessControl(Control).Text := Text - else if (not (Control is TWinControl)) then begin - // non-windowed TControl - with FindWideControlHelper(Control) do - SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText) - end else if (not TWinControl(Control).HandleAllocated) then begin - // NO HANDLE - TntControl_SetStoredText(Control, Text); - end else if TntControl_GetText(Control) <> Text then begin - // UNICODE & HANDLE - Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text)); - Control.Perform(CM_TEXTCHANGED, 0, 0); - end; -end; - -// hint management ----------------------------------------------------------------------- - -function TntControl_IsHintStored(Control: TControl): Boolean; -begin - with TAccessControl(Control) do - Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked; -end; - -function TntControl_GetHint(Control: TControl): WideString; -var - WideControlHelper: TWideControlHelper; -begin - if (not Win32PlatformIsUnicode) then - Result := Control.Hint - else begin - WideControlHelper := FindWideControlHelper(Control, False); - if WideControlHelper <> nil then - Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint) - else - Result := Control.Hint; - end; -end; - -procedure TntControl_SetHint(Control: TControl; const Value: WideString); -begin - if (not Win32PlatformIsUnicode) then - Control.Hint := Value - else - with FindWideControlHelper(Control) do - SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint); -end; - -function WideGetHint(Control: TControl): WideString; -begin - while Control <> nil do - if TntControl_GetHint(Control) = '' then - Control := Control.Parent - else - begin - Result := TntControl_GetHint(Control); - Exit; - end; - Result := ''; -end; - -function WideGetShortHint(const Hint: WideString): WideString; -var - I: Integer; -begin - I := Pos('|', Hint); - if I = 0 then - Result := Hint else - Result := Copy(Hint, 1, I - 1); -end; - -function WideGetLongHint(const Hint: WideString): WideString; -var - I: Integer; -begin - I := Pos('|', Hint); - if I = 0 then - Result := Hint else - Result := Copy(Hint, I + 1, Maxint); -end; - -//---------------------------------------------------------------------------------------- - -var UnicodeCreationControl: TWinControl = nil; - -function IsUnicodeCreationControl(Handle: HWND): Boolean; -begin - Result := (UnicodeCreationControl <> nil) - and (UnicodeCreationControl.HandleAllocated) - and (UnicodeCreationControl.Handle = Handle); -end; - -function WMNotifyFormatResult(FromHandle: HWND): Integer; -begin - if Win32PlatformIsUnicode - and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then - Result := NFR_UNICODE - else - Result := NFR_ANSI; -end; - -function IsTextMessage(Msg: UINT): Boolean; -begin - // WM_CHAR is omitted because of the special handling it receives - Result := (Msg = WM_SETTEXT) - or (Msg = WM_GETTEXT) - or (Msg = WM_GETTEXTLENGTH); -end; - -const - ANSI_UNICODE_HOLDER = $FF; - -procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage); -begin - with TWMChar(Message) do begin - Assert(Msg = WM_CHAR); - if not _IsShellProgramming then - Assert(Unused = 0) - else begin - Assert((Unused = 0) or (CharCode <= Word(High(AnsiChar)))); - // When a Unicode control is embedded under non-Delphi Unicode - // window something strange happens - if (Unused <> 0) then begin - CharCode := (Unused shl 8) or CharCode; - end; - end; - if (CharCode > Word(High(AnsiChar))) then begin - Unused := CharCode; - CharCode := ANSI_UNICODE_HOLDER; - end; - end; -end; - -procedure RestoreWMCharMsg(var Message: TMessage); -begin - with TWMChar(Message) do begin - Assert(Message.Msg = WM_CHAR); - if (Unused > 0) - and (CharCode = ANSI_UNICODE_HOLDER) then - CharCode := Unused; - Unused := 0; - end; -end; - -function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar; -begin - if (Message.CharCode = ANSI_UNICODE_HOLDER) - and (Message.Unused <> 0) then - Result := WideChar(Message.Unused) - else - Result := WideChar(Message.CharCode); -end; - -procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar); -begin - Message.CharCode := Word(Ch); - Message.Unused := 0; - MakeWMCharMsgSafeForAnsi(TMessage(Message)); -end; - -//----------------------------------------------------------------------------------- -type - TWinControlTrap = class(TComponent) - private - WinControl_ObjectInstance: Pointer; - ObjectInstance: Pointer; - DefObjectInstance: Pointer; - function IsInSubclassChain(Control: TWinControl): Boolean; - procedure SubClassWindowProc; - private - FControl: TAccessWinControl; - Handle: THandle; - PrevWin32Proc: Pointer; - PrevDefWin32Proc: Pointer; - PrevWindowProc: TWndMethod; - private - LastWin32Msg: UINT; - Win32ProcLevel: Integer; - IDEWindow: Boolean; - DestroyTrap: Boolean; - TestForNull: Boolean; - FoundNull: Boolean; - {$IFDEF TNT_VERIFY_WINDOWPROC} - LastVerifiedWindowProc: TWndMethod; - {$ENDIF} - procedure Win32Proc(var Message: TMessage); - procedure DefWin32Proc(var Message: TMessage); - procedure WindowProc(var Message: TMessage); - private - procedure SubClassControl(Params_Caption: PAnsiChar); - procedure UnSubClassUnicodeControl; - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - end; - -constructor TWinControlTrap.Create(AOwner: TComponent); -begin - FControl := TAccessWinControl(AOwner as TWinControl); - inherited Create(nil); - FControl.FreeNotification(Self); - - WinControl_ObjectInstance := Classes.MakeObjectInstance(FControl.MainWndProc); - ObjectInstance := Classes.MakeObjectInstance(Win32Proc); - DefObjectInstance := Classes.MakeObjectInstance(DefWin32Proc); -end; - -destructor TWinControlTrap.Destroy; -begin - Classes.FreeObjectInstance(ObjectInstance); - Classes.FreeObjectInstance(DefObjectInstance); - Classes.FreeObjectInstance(WinControl_ObjectInstance); - inherited; -end; - -procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (AComponent = FControl) and (Operation = opRemove) then begin - FControl := nil; - if Win32ProcLevel = 0 then - Free - else - DestroyTrap := True; - end; -end; - -procedure TWinControlTrap.SubClassWindowProc; -begin - if not IsInSubclassChain(FControl) then begin - PrevWindowProc := FControl.WindowProc; - FControl.WindowProc := Self.WindowProc; - end; - {$IFDEF TNT_VERIFY_WINDOWPROC} - LastVerifiedWindowProc := FControl.WindowProc; - {$ENDIF} -end; - -procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar); -begin - // initialize trap object - Handle := FControl.Handle; - PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC)); - PrevDefWin32Proc := FControl.DefWndProc; - - // subclass Window Procedures - SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance)); - FControl.DefWndProc := DefObjectInstance; - SubClassWindowProc; - - // For some reason, caption gets garbled after calling SetWindowLongW(.., GWL_WNDPROC). - TntControl_SetText(FControl, TntControl_GetStoredText(FControl, Params_Caption)); -end; - -function SameWndMethod(A, B: TWndMethod): Boolean; -begin - Result := @A = @B; -end; - -var - PendingRecreateWndTrapList: TComponentList = nil; - -procedure TWinControlTrap.UnSubClassUnicodeControl; -begin - // remember caption for future window creation - if not (csDestroying in FControl.ComponentState) then - TntControl_SetStoredText(FControl, TntControl_GetText(FControl)); - - // restore window procs (restore WindowProc only if we are still the direct subclass) - if SameWndMethod(FControl.WindowProc, Self.WindowProc) then - FControl.WindowProc := PrevWindowProc; - TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc; - SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc)); - - if IDEWindow then - DestroyTrap := True - else if not (csDestroying in FControl.ComponentState) then - // control not being destroyed, probably recreating window - PendingRecreateWndTrapList.Add(Self); -end; - -var - Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak. - Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. } - -procedure TWinControlTrap.Win32Proc(var Message: TMessage); -begin - if (not Finalized) then begin - Inc(Win32ProcLevel); - try - with Message do begin - {$IFDEF TNT_VERIFY_WINDOWPROC} - if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin - SubClassWindowProc; - LastVerifiedWindowProc := FControl.WindowProc; - end; - {$ENDIF} - LastWin32Msg := Msg; - Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam); - end; - finally - Dec(Win32ProcLevel); - end; - if (Win32ProcLevel = 0) and (DestroyTrap) then - Free; - end else if (Message.Msg = WM_DESTROY) or (Message.Msg = TNT_WM_DESTROY) then - FControl.WindowHandle := 0 -end; - -procedure TWinControlTrap.DefWin32Proc(var Message: TMessage); - - function IsChildEdit(AHandle: HWND): Boolean; - var - AHandleClass: WideString; - begin - Result := False; - if (FControl.Handle = GetParent(Handle)) then begin - // child control - SetLength(AHandleClass, 255); - SetLength(AHandleClass, GetClassNameW(AHandle, PWideChar(AHandleClass), Length(AHandleClass))); - Result := WideSameText(AHandleClass, 'EDIT'); - end; - end; - -begin - with Message do begin - if Msg = WM_NOTIFYFORMAT then - Result := WMNotifyFormatResult(HWND(Message.wParam)) - else begin - if (Msg = WM_CHAR) then begin - RestoreWMCharMsg(Message) - end; - if (Msg = WM_IME_CHAR) and (not _IsShellProgramming) and (not Win32PlatformIsXP) then - begin - { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. } - { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. } - { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. } - Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam) - end else if (Msg = WM_IME_CHAR) and (_IsShellProgramming) then begin - { When a Tnt control is hosted by a non-delphi control, DefWindowProc doesn't always work even on XP. } - if IsChildEdit(Handle) then - Message.Result := Integer(PostMessageW(Handle, WM_CHAR, wParam, lParam)) // native edit child control - else - Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam); - end else begin - if (Msg = WM_DESTROY) then begin - UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } - end; - { Normal DefWindowProc } - Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam); - end; - end; - end; -end; - -procedure ProcessCMHintShowMsg(var Message: TMessage); -begin - if Win32PlatformIsUnicode then begin - with TCMHintShow(Message) do begin - if (HintInfo.HintWindowClass = THintWindow) - or (HintInfo.HintWindowClass.InheritsFrom(TTntCustomHintWindow)) then begin - if (HintInfo.HintWindowClass = THintWindow) then - HintInfo.HintWindowClass := TTntCustomHintWindow; - HintInfo.HintData := HintInfo; - HintInfo.HintStr := WideGetShortHint(WideGetHint(HintInfo.HintControl)); - end; - end; - end; -end; - -function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean; -var - Message: TMessage; -begin - if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then - Result := False { no subclassing } - else if SameWndMethod(Control.WindowProc, Self.WindowProc) then - Result := True { directly subclassed } - else begin - TestForNull := True; - FoundNull := False; - ZeroMemory(@Message, SizeOf(Message)); - Message.Msg := WM_NULL; - Control.WindowProc(Message); - Result := FoundNull; { indirectly subclassed } - end; -end; - -procedure TWinControlTrap.WindowProc(var Message: TMessage); -var - CameFromWindows: Boolean; -begin - if TestForNull and (Message.Msg = WM_NULL) then - FoundNull := True; - - if (not FControl.HandleAllocated) then - FControl.WndProc(Message) - else begin - CameFromWindows := LastWin32Msg <> WM_NULL; - LastWin32Msg := WM_NULL; - with Message do begin - if Msg = CM_HINTSHOW then - ProcessCMHintShowMsg(Message); - if (not CameFromWindows) - and (IsTextMessage(Msg)) then - Result := SendMessageA(Handle, Msg, wParam, lParam) - else begin - if (Msg = WM_CHAR) then begin - MakeWMCharMsgSafeForAnsi(Message); - end; - PrevWindowProc(Message) - end; - if (Msg = TNT_WM_DESTROY) then - UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. } - end; - end; -end; - -//---------------------------------------------------------------------------------- - -function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap; -var - i: integer; -begin - // find or create trap object - Result := nil; - for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin - if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin - Result := TWinControlTrap(PendingRecreateWndTrapList[i]); - PendingRecreateWndTrapList.Delete(i); - break; { found it } - end; - end; - if Result = nil then - Result := TWinControlTrap.Create(Control); -end; - -procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False); -var - WinControlTrap: TWinControlTrap; -begin - if not IsWindowUnicode(Control.Handle) then - raise ETntInternalError.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.'); - - WinControlTrap := FindOrCreateWinControlTrap(Control); - WinControlTrap.SubClassControl(Params_Caption); - WinControlTrap.IDEWindow := IDEWindow; -end; - - -//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE - -var - WindowAtom: TAtom; - ControlAtom: TAtom; - WindowAtomString: AnsiString; - ControlAtomString: AnsiString; - -type - TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; - -function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall; - - function GetObjectInstance(Control: TWinControl): Pointer; - var - WinControlTrap: TWinControlTrap; - begin - WinControlTrap := FindOrCreateWinControlTrap(Control); - PendingRecreateWndTrapList.Add(WinControlTrap); - Result := WinControlTrap.WinControl_ObjectInstance; - end; - -var - ObjectInstance: Pointer; -begin - TAccessWinControl(CreationControl).WindowHandle := HWindow; - ObjectInstance := GetObjectInstance(CreationControl); - {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!} - SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance)); - if (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0) - and (GetWindowLongW(HWindow, GWL_ID) = 0) then - SetWindowLongW(HWindow, GWL_ID, Integer(HWindow)); - SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl)); - SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl)); - CreationControl := nil; - Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam); -end; - -procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False); -const - UNICODE_CLASS_EXT = '.UnicodeClass'; -var - TempClass: TWndClassW; - WideClass: TWndClassW; - ClassRegistered: Boolean; - InitialProc: TFNWndProc; -begin - if IDEWindow then - InitialProc := @InitWndProc - else - InitialProc := @InitWndProcW; - - with Params do begin - WideWinClassName := WinClassName + UNICODE_CLASS_EXT; - ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass); - if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc) - then begin - if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance)); - // Prepare a TWndClassW record - WideClass := TWndClassW(WindowClass); - WideClass.hInstance := hInstance; - WideClass.lpfnWndProc := InitialProc; - if not Tnt_Is_IntResource(PWideChar(WindowClass.lpszMenuName)) then begin - WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName)); - end; - WideClass.lpszClassName := PWideChar(WideWinClassName); - - // Register the UNICODE class - if RegisterClassW(WideClass) = 0 then RaiseLastOSError; - end; - end; -end; - -procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams; - const SubClass: WideString; IDEWindow: Boolean = False); -var - TempSubClass: TWndClassW; - WideWinClassName: WideString; - Handle: THandle; -begin - if (not Win32PlatformIsUnicode) then begin - with Params do - TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName, - Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); - end else begin - // SubClass the unicode version of this control by getting the correct DefWndProc - if (SubClass <> '') - and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then - TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc - else - TAccessWinControl(Control).DefWndProc := @DefWindowProcW; - - // make sure Unicode window class is registered - RegisterUnicodeClass(Params, WideWinClassName, IDEWindow); - - // Create UNICODE window handle - UnicodeCreationControl := Control; - try - with Params do - Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil, - Style, X, Y, Width, Height, WndParent, 0, hInstance, Param); - if Handle = 0 then - RaiseLastOSError; - TAccessWinControl(Control).WindowHandle := Handle; - if IDEWindow then - SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC)); - finally - UnicodeCreationControl := nil; - end; - - SubClassUnicodeControl(Control, Params.Caption, IDEWindow); - end; -end; - -procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False); -var - WasFocused: Boolean; - Params: TCreateParams; -begin - with TAccessWinControl(Control) do begin - WasFocused := Focused; - DestroyHandle; - CreateParams(Params); - CreationControl := Control; - CreateUnicodeHandle(Control, Params, SubClass, IDEWindow); - StrDispose{TNT-ALLOW StrDispose}(WindowText); - WindowText := nil; - Perform(WM_SETFONT, Integer(Font.Handle), 1); - if AutoSize then AdjustSize; - UpdateControlState; - if WasFocused and (WindowHandle <> 0) then Windows.SetFocus(WindowHandle); - end; -end; - -{ TTntCustomHintWindow procs } - -function DataPointsToHintInfoForTnt(AData: Pointer): Boolean; -begin - try - Result := (AData <> nil) - and (PHintInfo(AData).HintData = AData) {points to self} - and (PHintInfo(AData).HintWindowClass.InheritsFrom(TTntCustomHintWindow)); - except - Result := False; - end; -end; - -function ExtractTntHintCaption(AData: Pointer): WideString; -var - Control: TControl; - WideHint: WideString; - AnsiHintWithShortCut: AnsiString; - ShortCut: TShortCut; -begin - Result := PHintInfo(AData).HintStr; - if Result <> '' then begin - Control := PHintInfo(AData).HintControl; - WideHint := WideGetShortHint(WideGetHint(Control)); - if (AnsiString(WideHint) = PHintInfo(AData).HintStr) then - Result := WideHint - else if Application.HintShortCuts and (Control <> nil) - and (Control.Action is TCustomAction{TNT-ALLOW TCustomAction}) then begin - ShortCut := TCustomAction{TNT-ALLOW TCustomAction}(Control.Action).ShortCut; - if (ShortCut <> scNone) then - begin - AnsiHintWithShortCut := Format{TNT-ALLOW Format}('%s (%s)', [WideHint, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)]); - if AnsiHintWithShortCut = PHintInfo(AData).HintStr then - Result := WideFormat('%s (%s)', [WideHint, WideShortCutToText(ShortCut)]); - end; - end; - end; -end; - -{ TTntCustomHintWindow } - -procedure TTntCustomHintWindow.CreateWindowHandle(const Params: TCreateParams); -begin - CreateUnicodeHandle(Self, Params, ''); -end; - -{$IFNDEF COMPILER_7_UP} -procedure TTntCustomHintWindow.CreateParams(var Params: TCreateParams); -const - CS_DROPSHADOW = $00020000; -begin - inherited; - if Win32PlatformIsXP then { Enable drop shadow effect on Windows XP and later. } - Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; -end; -{$ENDIF} - -function TTntCustomHintWindow.GetCaption: TWideCaption; -begin - Result := TntControl_GetText(Self) -end; - -procedure TTntCustomHintWindow.SetCaption(const Value: TWideCaption); -begin - TntControl_SetText(Self, Value); -end; - -procedure TTntCustomHintWindow.Paint; -var - R: TRect; -begin - if FBlockPaint then - exit; - if (not Win32PlatformIsUnicode) then - inherited - else begin - R := ClientRect; - Inc(R.Left, 2); - Inc(R.Top, 2); - Canvas.Font.Color := Screen.HintFont.Color; - Tnt_DrawTextW(Canvas.Handle, PWideChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or - DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly); - end; -end; - -procedure TTntCustomHintWindow.CMTextChanged(var Message: TMessage); -begin - { Avoid flicker when calling ActivateHint } - if FActivating then Exit; - Width := WideCanvasTextWidth(Canvas, Caption) + 6; - Height := WideCanvasTextHeight(Canvas, Caption) + 6; -end; - -procedure TTntCustomHintWindow.ActivateHint(Rect: TRect; const AHint: AnsiString); -var - SaveActivating: Boolean; -begin - SaveActivating := FActivating; - try - FActivating := True; - inherited; - finally - FActivating := SaveActivating; - end; -end; - -procedure TTntCustomHintWindow.ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); -var - SaveActivating: Boolean; -begin - if (not Win32PlatformIsUnicode) - or (not DataPointsToHintInfoForTnt(AData)) then - inherited - else begin - FBlockPaint := True; - try - SaveActivating := FActivating; - try - FActivating := True; - inherited; - Caption := ExtractTntHintCaption(AData); - finally - FActivating := SaveActivating; - end; - finally - FBlockPaint := False; - end; - Invalidate; - end; -end; - -function TntHintWindow_CalcHintRect(HintWindow: TTntCustomHintWindow; MaxWidth: Integer; const AHint: WideString): TRect; -begin - Result := Rect(0, 0, MaxWidth, 0); - Tnt_DrawTextW(HintWindow.Canvas.Handle, PWideChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or - DT_WORDBREAK or DT_NOPREFIX or HintWindow.DrawTextBiDiModeFlagsReadingOnly); - Inc(Result.Right, 6); - Inc(Result.Bottom, 2); -end; - -function TTntCustomHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; -var - WideHintStr: WideString; -begin - if (not Win32PlatformIsUnicode) - or (not DataPointsToHintInfoForTnt(AData)) then - Result := inherited CalcHintRect(MaxWidth, AHint, AData) - else begin - WideHintStr := ExtractTntHintCaption(AData); - Result := TntHintWindow_CalcHintRect(Self, MaxWidth, WideHintStr); - end; -end; - -{ TTntHintWindow } - -procedure TTntHintWindow.ActivateHint(Rect: TRect; const AHint: WideString); -var - SaveActivating: Boolean; -begin - SaveActivating := FActivating; - try - FActivating := True; - Caption := AHint; - inherited ActivateHint(Rect, AHint); - finally - FActivating := SaveActivating; - end; -end; - -procedure TTntHintWindow.ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); -var - SaveActivating: Boolean; -begin - FBlockPaint := True; - try - SaveActivating := FActivating; - try - FActivating := True; - Caption := AHint; - inherited ActivateHintData(Rect, AHint, AData); - finally - FActivating := SaveActivating; - end; - finally - FBlockPaint := False; - end; - Invalidate; -end; - -function TTntHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; -begin - Result := TntHintWindow_CalcHintRect(Self, MaxWidth, AHint); -end; - -procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject); -var - WideControl: IWideCustomListControl; -begin - if Control.GetInterface(IWideCustomListControl, WideControl) then - WideControl.AddItem(Item, AObject) - else - Control.AddItem(Item, AObject); -end; - -procedure InitControls; - - procedure InitAtomStrings_D6_D7_D9; - var - Controls_HInstance: Cardinal; - begin - Controls_HInstance := FindClassHInstance(TWinControl); - WindowAtomString := Format{TNT-ALLOW Format}('Delphi%.8X',[GetCurrentProcessID]); - ControlAtomString := Format{TNT-ALLOW Format}('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]); - end; - - {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 - procedure InitAtomStrings; - begin - InitAtomStrings_D6_D7_D9; - end; - {$ENDIF} - -begin - InitAtomStrings; - WindowAtom := WinCheckH(GlobalAddAtom(PAnsiChar(WindowAtomString))); - ControlAtom := WinCheckH(GlobalAddAtom(PAnsiChar(ControlAtomString))); -end; - -initialization - TNT_WM_DESTROY := RegisterWindowMessage('TntUnicodeVcl.DestroyWindow'); - WideControlHelpers := TComponentList.Create(True); - PendingRecreateWndTrapList := TComponentList.Create(False); - InitControls; - -finalization - GlobalDeleteAtom(ControlAtom); - GlobalDeleteAtom(WindowAtom); - FreeAndNil(WideControlHelpers); - FreeAndNil(PendingRecreateWndTrapList); - Finalized := True; - -end. -- cgit v1.2.3