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 insertions(+) create mode 100644 plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas (limited to 'plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas') diff --git a/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas new file mode 100644 index 0000000000..55025ecdc2 --- /dev/null +++ b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas @@ -0,0 +1,1099 @@ + +{*****************************************************************************} +{ } +{ 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