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, 0 insertions, 1099 deletions
diff --git a/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas b/plugins/!NotAdopted/Chess4Net/lib/TntUnicodeControls/Source/TntControls.pas deleted file mode 100644 index 55025ecdc2..0000000000 --- a/plugins/!NotAdopted/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.
|