diff options
Diffstat (limited to 'plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas')
| -rw-r--r-- | plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas | 1099 |
1 files changed, 1099 insertions, 0 deletions
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.
|