source: cprs/branches/tmg-cprs/TMG_Extra/tntUniCode/Source/TntControls.pas

Last change on this file was 672, checked in by Kevin Toppenberg, 9 years ago

Adding source to tntControls for compilation

File size: 37.3 KB
Line 
1
2{*****************************************************************************}
3{                                                                             }
4{    Tnt Delphi Unicode Controls                                              }
5{      http://www.tntware.com/delphicontrols/unicode/                         }
6{        Version: 2.3.0                                                       }
7{                                                                             }
8{    Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com)       }
9{                                                                             }
10{*****************************************************************************}
11
12unit TntControls;
13
14{$INCLUDE TntCompilers.inc}
15
16{
17  Windows NT provides support for native Unicode windows.  To add Unicode support to a
18    TWinControl descendant, override CreateWindowHandle() and call CreateUnicodeHandle().
19
20  One major reason this works is because the VCL only uses the ANSI version of
21    SendMessage() -- SendMessageA().  If you call SendMessageA() on a UNICODE
22    window, Windows deals with the ANSI/UNICODE conversion automatically.  So
23    for example, if the VCL sends WM_SETTEXT to a window using SendMessageA,
24    Windows actually *expects* a PAnsiChar even if the target window is a UNICODE
25    window.  So caling SendMessageA with PChars causes no problems.
26
27  A problem in the VCL has to do with the TControl.Perform() method. Perform()
28    calls the window procedure directly and assumes an ANSI window.  This is a
29    problem if, for example, the VCL calls Perform(WM_SETTEXT, ...) passing in a
30    PAnsiChar which eventually gets passed downto DefWindowProcW() which expects a PWideChar.
31
32  This is the reason for SubClassUnicodeControl().  This procedure will subclass the
33    Windows WndProc, and the TWinControl.WindowProc pointer.  It will determine if the
34    message came from Windows or if the WindowProc was called directly.  It will then
35    call SendMessageA() for Windows to perform proper conversion on certain text messages.
36
37  Another problem has to do with TWinControl.DoKeyPress().  It is called from the WM_CHAR
38    message.  It casts the WideChar to an AnsiChar, and sends the resulting character to
39    DefWindowProc.  In order to avoid this, the DefWindowProc is subclassed as well.  WindowProc
40    will make a WM_CHAR message safe for ANSI handling code by converting the char code to
41    #FF before passing it on.  It stores the original WideChar in the .Unused field of TWMChar.
42    The code #FF is converted back to the WideChar before passing onto DefWindowProc.
43}
44
45{
46  Things to consider when designing new controls:
47    1)  Check that a WideString Hint property is published.
48    2)  If descending from TWinControl, override CreateWindowHandle().
49    3)  If not descending from TWinControl, handle CM_HINTSHOW message.
50    4)  Check to make sure that CN_CHAR, CN_SYSCHAR and CM_DIALOGCHAR are handled properly.
51    5)  If descending from TWinControl, verify Unicode chars are preserved after RecreateWnd.
52    6)  Consider using storage specifiers for Hint and Caption properties.
53    7)  If any class could possibly have published WideString properties,
54          override DefineProperties and call TntPersistent_AfterInherited_DefineProperties.
55    8)  Check if TTntThemeManager needs to be updated.
56    9)  Override GetActionLinkClass() and ActionChange().
57    10) If class updates Application.Hint then update TntApplication.Hint instead.
58}
59
60interface
61
62{ TODO: Unicode enable .OnKeyPress event }
63
64uses
65  Classes, Windows, Messages, Controls, Menus;
66
67
68{TNT-WARN TCaption}
69type TWideCaption = type WideString;
70
71// caption/text management
72function TntControl_IsCaptionStored(Control: TControl): Boolean;
73function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString;
74procedure TntControl_SetStoredText(Control: TControl; const Value: WideString);
75function TntControl_GetText(Control: TControl): WideString;
76procedure TntControl_SetText(Control: TControl; const Text: WideString);
77
78// hint management
79function TntControl_IsHintStored(Control: TControl): Boolean;
80function TntControl_GetHint(Control: TControl): WideString;
81procedure TntControl_SetHint(Control: TControl; const Value: WideString);
82
83function WideGetHint(Control: TControl): WideString;
84function WideGetShortHint(const Hint: WideString): WideString;
85function WideGetLongHint(const Hint: WideString): WideString;
86procedure ProcessCMHintShowMsg(var Message: TMessage);
87
88type
89  TTntCustomHintWindow = class(THintWindow)
90  private
91    FActivating: Boolean;
92    FBlockPaint: Boolean;
93    function GetCaption: TWideCaption;
94    procedure SetCaption(const Value: TWideCaption);
95    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
96  protected
97    procedure CreateWindowHandle(const Params: TCreateParams); override;
98{$IFNDEF COMPILER_7_UP}
99    procedure CreateParams(var Params: TCreateParams); override;
100{$ENDIF}
101    procedure Paint; override;
102  public
103    procedure ActivateHint(Rect: TRect; const AHint: AnsiString); override;
104    procedure ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer); override;
105    function CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect; override;
106    property Caption: TWideCaption read GetCaption write SetCaption;
107  end;
108
109  TTntHintWindow = class(TTntCustomHintWindow)
110  public
111    procedure ActivateHint(Rect: TRect; const AHint: WideString); reintroduce;
112    procedure ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer); reintroduce;
113    function CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect; reintroduce;
114  end;
115
116// text/char message
117function IsTextMessage(Msg: UINT): Boolean;
118procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage);
119procedure RestoreWMCharMsg(var Message: TMessage);
120function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar;
121procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar);
122
123// register/create window
124procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False);
125procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False);
126procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams;
127                                        const SubClass: WideString; IDEWindow: Boolean = False);
128procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False);
129
130type
131  IWideCustomListControl = interface
132    ['{C1801F41-51E9-4DB5-8DB8-58AC86698C2E}']
133    procedure AddItem(const Item: WideString; AObject: TObject);
134  end;
135
136procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject);
137
138var
139  _IsShellProgramming: Boolean = False;
140
141var
142  TNT_WM_DESTROY: Cardinal;
143
144implementation
145
146uses
147  ActnList, Forms, SysUtils, Contnrs, 
148  TntGraphics, TntWindows, TntClasses, TntMenus, TntSysUtils;
149
150type
151  TAccessControl = class(TControl);
152  TAccessWinControl = class(TWinControl);
153  TAccessControlActionLink = class(TControlActionLink{TNT-ALLOW TControlActionLink});
154
155//----------------------------------------------- WIDE CAPTION HOLDERS --------
156
157{ TWideControlHelper }
158
159var
160  WideControlHelpers: TComponentList = nil;
161
162type
163  TWideControlHelper = class(TWideComponentHelper)
164  private
165    FControl: TControl;
166    FWideCaption: WideString;
167    FWideHint: WideString;
168    procedure SetAnsiText(const Value: AnsiString);
169    procedure SetAnsiHint(const Value: AnsiString);
170  public
171    constructor Create(AOwner: TControl); reintroduce;
172    property WideCaption: WideString read FWideCaption;
173    property WideHint: WideString read FWideHint;
174  end;
175
176constructor TWideControlHelper.Create(AOwner: TControl);
177begin
178  inherited CreateHelper(AOwner, WideControlHelpers);
179  FControl := AOwner;
180end;
181
182procedure TWideControlHelper.SetAnsiText(const Value: AnsiString);
183begin
184  TAccessControl(FControl).Text := Value;
185end;
186
187procedure TWideControlHelper.SetAnsiHint(const Value: AnsiString);
188begin
189  FControl.Hint := Value;
190end;
191
192function FindWideControlHelper(Control: TControl; CreateIfNotFound: Boolean = True): TWideControlHelper;
193begin
194  Result := TWideControlHelper(FindWideComponentHelper(WideControlHelpers, Control));
195  if (Result = nil) and CreateIfNotFound then
196        Result := TWideControlHelper.Create(Control);
197end;
198
199//----------------------------------------------- GET/SET WINDOW CAPTION/HINT -------------
200
201function TntControl_IsCaptionStored(Control: TControl): Boolean;
202begin
203  with TAccessControl(Control) do
204    Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsCaptionLinked;
205end;
206
207function TntControl_GetStoredText(Control: TControl; const Default: WideString): WideString;
208var
209  WideControlHelper: TWideControlHelper;
210begin
211  WideControlHelper := FindWideControlHelper(Control, False);
212  if WideControlHelper <> nil then
213    Result := WideControlHelper.WideCaption
214  else
215    Result := Default;
216end;
217
218procedure TntControl_SetStoredText(Control: TControl; const Value: WideString);
219begin
220  FindWideControlHelper(Control).FWideCaption := Value;
221  TAccessControl(Control).Text := Value;
222end;
223
224function TntControl_GetText(Control: TControl): WideString;
225var
226  WideControlHelper: TWideControlHelper;
227begin
228  if (not Win32PlatformIsUnicode)
229  or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then
230    // Win9x / non-unicode handle
231    Result := TAccessControl(Control).Text
232  else if (not (Control is TWinControl)) then begin
233    // non-windowed TControl
234    WideControlHelper := FindWideControlHelper(Control, False);
235    if WideControlHelper = nil then
236      Result := TAccessControl(Control).Text
237    else
238      Result := GetSyncedWideString(WideControlHelper.FWideCaption, TAccessControl(Control).Text);
239  end else if (not TWinControl(Control).HandleAllocated) then begin
240    // NO HANDLE
241    Result := TntControl_GetStoredText(Control, TAccessControl(Control).Text)
242  end else begin
243    // UNICODE & HANDLE
244    SetLength(Result, GetWindowTextLengthW(TWinControl(Control).Handle) + 1);
245    GetWindowTextW(TWinControl(Control).Handle, PWideChar(Result), Length(Result));
246    SetLength(Result, Length(Result) - 1);
247  end;
248end;
249
250procedure TntControl_SetText(Control: TControl; const Text: WideString);
251begin
252  if (not Win32PlatformIsUnicode)
253  or ((Control is TWinControl) and TWinControl(Control).HandleAllocated and (not IsWindowUnicode(TWinControl(Control).Handle))) then
254    // Win9x / non-unicode handle
255    TAccessControl(Control).Text := Text
256  else if (not (Control is TWinControl)) then begin
257    // non-windowed TControl
258    with FindWideControlHelper(Control) do
259      SetSyncedWideString(Text, FWideCaption, TAccessControl(Control).Text, SetAnsiText)
260  end else if (not TWinControl(Control).HandleAllocated) then begin
261    // NO HANDLE
262    TntControl_SetStoredText(Control, Text);
263  end else if TntControl_GetText(Control) <> Text then begin
264    // UNICODE & HANDLE
265    Tnt_SetWindowTextW(TWinControl(Control).Handle, PWideChar(Text));
266    Control.Perform(CM_TEXTCHANGED, 0, 0);
267  end;
268end;
269
270// hint management -----------------------------------------------------------------------
271
272function TntControl_IsHintStored(Control: TControl): Boolean;
273begin
274  with TAccessControl(Control) do
275    Result := (ActionLink = nil) or not TAccessControlActionLink(ActionLink).IsHintLinked;
276end;
277
278function TntControl_GetHint(Control: TControl): WideString;
279var
280  WideControlHelper: TWideControlHelper;
281begin
282  if (not Win32PlatformIsUnicode) then
283    Result := Control.Hint
284  else begin
285    WideControlHelper := FindWideControlHelper(Control, False);
286    if WideControlHelper <> nil then
287      Result := GetSyncedWideString(WideControlHelper.FWideHint, Control.Hint)
288    else
289      Result := Control.Hint;
290  end;
291end;
292
293procedure TntControl_SetHint(Control: TControl; const Value: WideString);
294begin
295  if (not Win32PlatformIsUnicode) then
296    Control.Hint := Value
297  else
298    with FindWideControlHelper(Control) do
299      SetSyncedWideString(Value, FWideHint, Control.Hint, SetAnsiHint);
300end;
301
302function WideGetHint(Control: TControl): WideString;
303begin
304  while Control <> nil do
305    if TntControl_GetHint(Control) = '' then
306      Control := Control.Parent
307    else
308    begin
309      Result := TntControl_GetHint(Control);
310      Exit;
311    end;
312  Result := '';
313end;
314
315function WideGetShortHint(const Hint: WideString): WideString;
316var
317  I: Integer;
318begin
319  I := Pos('|', Hint);
320  if I = 0 then
321    Result := Hint else
322    Result := Copy(Hint, 1, I - 1);
323end;
324
325function WideGetLongHint(const Hint: WideString): WideString;
326var
327  I: Integer;
328begin
329  I := Pos('|', Hint);
330  if I = 0 then
331    Result := Hint else
332    Result := Copy(Hint, I + 1, Maxint);
333end;
334
335//----------------------------------------------------------------------------------------
336
337var UnicodeCreationControl: TWinControl = nil;
338
339function IsUnicodeCreationControl(Handle: HWND): Boolean;
340begin
341  Result := (UnicodeCreationControl <> nil)
342        and (UnicodeCreationControl.HandleAllocated)
343        and (UnicodeCreationControl.Handle = Handle);
344end;
345
346function WMNotifyFormatResult(FromHandle: HWND): Integer;
347begin
348  if Win32PlatformIsUnicode
349  and (IsWindowUnicode(FromHandle) or IsUnicodeCreationControl(FromHandle)) then
350    Result := NFR_UNICODE
351  else
352    Result := NFR_ANSI;
353end;
354
355function IsTextMessage(Msg: UINT): Boolean;
356begin
357  // WM_CHAR is omitted because of the special handling it receives
358  Result := (Msg = WM_SETTEXT)
359         or (Msg = WM_GETTEXT)
360         or (Msg = WM_GETTEXTLENGTH);
361end;
362
363const
364  ANSI_UNICODE_HOLDER = $FF;
365
366procedure MakeWMCharMsgSafeForAnsi(var Message: TMessage);
367begin
368  with TWMChar(Message) do begin
369    Assert(Msg = WM_CHAR);
370    if not _IsShellProgramming then
371      Assert(Unused = 0)
372    else begin
373      Assert((Unused = 0) or (CharCode <= Word(High(AnsiChar))));
374      // When a Unicode control is embedded under non-Delphi Unicode
375      //   window something strange happens
376      if (Unused <> 0) then begin
377        CharCode := (Unused shl 8) or CharCode;
378      end;
379    end;
380    if (CharCode > Word(High(AnsiChar))) then begin
381      Unused := CharCode;
382      CharCode := ANSI_UNICODE_HOLDER;
383    end;
384  end;
385end;
386
387procedure RestoreWMCharMsg(var Message: TMessage);
388begin
389  with TWMChar(Message) do begin
390    Assert(Message.Msg = WM_CHAR);
391    if (Unused > 0)
392    and (CharCode = ANSI_UNICODE_HOLDER) then
393      CharCode := Unused;
394    Unused := 0;
395  end;
396end;
397
398function GetWideCharFromWMCharMsg(Message: TWMChar): WideChar;
399begin
400  if (Message.CharCode = ANSI_UNICODE_HOLDER)
401  and (Message.Unused <> 0) then
402    Result := WideChar(Message.Unused)
403  else
404    Result := WideChar(Message.CharCode);
405end;
406
407procedure SetWideCharForWMCharMsg(var Message: TWMChar; Ch: WideChar);
408begin
409  Message.CharCode := Word(Ch);
410  Message.Unused := 0;
411  MakeWMCharMsgSafeForAnsi(TMessage(Message));
412end;
413
414//-----------------------------------------------------------------------------------
415type
416  TWinControlTrap = class(TComponent)
417  private
418    WinControl_ObjectInstance: Pointer;
419    ObjectInstance: Pointer;
420    DefObjectInstance: Pointer;
421    function IsInSubclassChain(Control: TWinControl): Boolean;
422    procedure SubClassWindowProc;
423  private
424    FControl: TAccessWinControl;
425    Handle: THandle;
426    PrevWin32Proc: Pointer;
427    PrevDefWin32Proc: Pointer;
428    PrevWindowProc: TWndMethod;
429  private
430    LastWin32Msg: UINT;
431    Win32ProcLevel: Integer;
432    IDEWindow: Boolean;
433    DestroyTrap: Boolean;
434    TestForNull: Boolean;
435    FoundNull: Boolean;
436    {$IFDEF TNT_VERIFY_WINDOWPROC}
437    LastVerifiedWindowProc: TWndMethod;
438    {$ENDIF}
439    procedure Win32Proc(var Message: TMessage);
440    procedure DefWin32Proc(var Message: TMessage);
441    procedure WindowProc(var Message: TMessage);
442  private
443    procedure SubClassControl(Params_Caption: PAnsiChar);
444    procedure UnSubClassUnicodeControl;
445  protected
446    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
447  public
448    constructor Create(AOwner: TComponent); override;
449    destructor Destroy; override;
450  end;
451
452constructor TWinControlTrap.Create(AOwner: TComponent);
453begin
454  FControl := TAccessWinControl(AOwner as TWinControl);
455  inherited Create(nil);
456  FControl.FreeNotification(Self);
457
458  WinControl_ObjectInstance := Classes.MakeObjectInstance(FControl.MainWndProc);
459  ObjectInstance := Classes.MakeObjectInstance(Win32Proc);
460  DefObjectInstance := Classes.MakeObjectInstance(DefWin32Proc);
461end;
462
463destructor TWinControlTrap.Destroy;
464begin
465  Classes.FreeObjectInstance(ObjectInstance);
466  Classes.FreeObjectInstance(DefObjectInstance);
467  Classes.FreeObjectInstance(WinControl_ObjectInstance);
468  inherited;
469end;
470
471procedure TWinControlTrap.Notification(AComponent: TComponent; Operation: TOperation);
472begin
473  inherited;
474  if (AComponent = FControl) and (Operation = opRemove) then begin
475    FControl := nil;
476    if Win32ProcLevel = 0 then
477      Free
478    else
479      DestroyTrap := True;
480  end;
481end;
482
483procedure TWinControlTrap.SubClassWindowProc;
484begin
485  if not IsInSubclassChain(FControl) then begin
486    PrevWindowProc := FControl.WindowProc;
487    FControl.WindowProc := Self.WindowProc;
488  end;
489  {$IFDEF TNT_VERIFY_WINDOWPROC}
490  LastVerifiedWindowProc := FControl.WindowProc;
491  {$ENDIF}
492end;
493
494procedure TWinControlTrap.SubClassControl(Params_Caption: PAnsiChar);
495begin
496  // initialize trap object
497  Handle := FControl.Handle;
498  PrevWin32Proc := Pointer(GetWindowLongW(FControl.Handle, GWL_WNDPROC));
499  PrevDefWin32Proc := FControl.DefWndProc;
500
501  // subclass Window Procedures
502  SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(ObjectInstance));
503  FControl.DefWndProc := DefObjectInstance;
504  SubClassWindowProc;
505
506  // For some reason, caption gets garbled after calling SetWindowLongW(.., GWL_WNDPROC).
507  TntControl_SetText(FControl, TntControl_GetStoredText(FControl, Params_Caption));
508end;
509
510function SameWndMethod(A, B: TWndMethod): Boolean;
511begin
512  Result := @A = @B;
513end;
514
515var
516  PendingRecreateWndTrapList: TComponentList = nil;
517
518procedure TWinControlTrap.UnSubClassUnicodeControl;
519begin
520  // remember caption for future window creation
521  if not (csDestroying in FControl.ComponentState) then
522    TntControl_SetStoredText(FControl, TntControl_GetText(FControl));
523
524  // restore window procs (restore WindowProc only if we are still the direct subclass)
525  if SameWndMethod(FControl.WindowProc, Self.WindowProc) then
526    FControl.WindowProc := PrevWindowProc;
527  TAccessWinControl(FControl).DefWndProc := PrevDefWin32Proc;
528  SetWindowLongW(FControl.Handle, GWL_WNDPROC, Integer(PrevWin32Proc));
529
530  if IDEWindow then
531    DestroyTrap := True
532  else if not (csDestroying in FControl.ComponentState) then
533    // control not being destroyed, probably recreating window
534    PendingRecreateWndTrapList.Add(Self);
535end;
536
537var
538  Finalized: Boolean; { If any tnt controls are still around after finalization it must be due to a memory leak.
539                        Windows will still try to send a WM_DESTROY, but we will just ignore it if we're finalized. }
540
541procedure TWinControlTrap.Win32Proc(var Message: TMessage);
542begin
543  if (not Finalized) then begin
544    Inc(Win32ProcLevel);
545    try
546      with Message do begin
547        {$IFDEF TNT_VERIFY_WINDOWPROC}
548        if not SameWndMethod(FControl.WindowProc, LastVerifiedWindowProc) then begin
549          SubClassWindowProc;
550          LastVerifiedWindowProc := FControl.WindowProc;
551        end;
552        {$ENDIF}
553        LastWin32Msg := Msg;
554        Result := CallWindowProcW(PrevWin32Proc, Handle, Msg, wParam, lParam);
555      end;
556    finally
557      Dec(Win32ProcLevel);
558    end;
559    if (Win32ProcLevel = 0) and (DestroyTrap) then
560      Free;
561  end else if (Message.Msg = WM_DESTROY) or (Message.Msg = TNT_WM_DESTROY) then
562    FControl.WindowHandle := 0
563end;
564
565procedure TWinControlTrap.DefWin32Proc(var Message: TMessage);
566
567  function IsChildEdit(AHandle: HWND): Boolean;
568  var
569    AHandleClass: WideString;
570  begin
571    Result := False;
572    if (FControl.Handle = GetParent(Handle)) then begin
573      // child control
574      SetLength(AHandleClass, 255);
575      SetLength(AHandleClass, GetClassNameW(AHandle, PWideChar(AHandleClass), Length(AHandleClass)));
576      Result := WideSameText(AHandleClass, 'EDIT');
577    end;
578  end;
579
580begin
581  with Message do begin
582    if Msg = WM_NOTIFYFORMAT then
583      Result := WMNotifyFormatResult(HWND(Message.wParam))
584    else begin
585      if (Msg = WM_CHAR) then begin
586        RestoreWMCharMsg(Message)
587      end;
588      if (Msg = WM_IME_CHAR) and (not _IsShellProgramming) and (not Win32PlatformIsXP) then
589      begin
590        { In Windows XP, DefWindowProc handles WM_IME_CHAR fine for VCL windows. }
591        { Before XP, DefWindowProc will sometimes produce incorrect, non-Unicode WM_CHAR. }
592        { Also, using PostMessageW on Windows 2000 didn't always produce the correct results. }
593        Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam)
594      end else if (Msg = WM_IME_CHAR) and (_IsShellProgramming) then begin
595        { When a Tnt control is hosted by a non-delphi control, DefWindowProc doesn't always work even on XP. }
596        if IsChildEdit(Handle) then
597          Message.Result := Integer(PostMessageW(Handle, WM_CHAR, wParam, lParam)) // native edit child control
598        else
599          Message.Result := SendMessageW(Handle, WM_CHAR, wParam, lParam);
600      end else begin
601        if (Msg = WM_DESTROY) then begin
602          UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. }
603        end;
604        { Normal DefWindowProc }
605        Result := CallWindowProcW(PrevDefWin32Proc, Handle, Msg, wParam, lParam);
606      end;
607    end;
608  end;
609end;
610
611procedure ProcessCMHintShowMsg(var Message: TMessage);
612begin
613  if Win32PlatformIsUnicode then begin
614    with TCMHintShow(Message) do begin
615      if (HintInfo.HintWindowClass = THintWindow)
616      or (HintInfo.HintWindowClass.InheritsFrom(TTntCustomHintWindow)) then begin
617        if (HintInfo.HintWindowClass = THintWindow) then
618          HintInfo.HintWindowClass := TTntCustomHintWindow;
619        HintInfo.HintData := HintInfo;
620        HintInfo.HintStr := WideGetShortHint(WideGetHint(HintInfo.HintControl));
621      end;
622    end;
623  end;
624end;
625
626function TWinControlTrap.IsInSubclassChain(Control: TWinControl): Boolean;
627var
628  Message: TMessage;
629begin
630  if SameWndMethod(Control.WindowProc, TAccessWinControl(Control).WndProc) then
631    Result := False { no subclassing }
632  else if SameWndMethod(Control.WindowProc, Self.WindowProc) then
633    Result := True { directly subclassed }
634  else begin
635    TestForNull := True;
636    FoundNull := False;
637    ZeroMemory(@Message, SizeOf(Message));
638    Message.Msg := WM_NULL;
639    Control.WindowProc(Message);
640    Result := FoundNull; { indirectly subclassed }
641  end;
642end;
643
644procedure TWinControlTrap.WindowProc(var Message: TMessage);
645var
646  CameFromWindows: Boolean;
647begin
648  if TestForNull and (Message.Msg = WM_NULL) then
649    FoundNull := True;
650
651  if (not FControl.HandleAllocated) then
652    FControl.WndProc(Message)
653  else begin
654    CameFromWindows := LastWin32Msg <> WM_NULL;
655    LastWin32Msg := WM_NULL;
656    with Message do begin
657      if Msg = CM_HINTSHOW then
658        ProcessCMHintShowMsg(Message);
659      if (not CameFromWindows)
660      and (IsTextMessage(Msg)) then
661        Result := SendMessageA(Handle, Msg, wParam, lParam)
662      else begin
663        if (Msg = WM_CHAR) then begin
664          MakeWMCharMsgSafeForAnsi(Message);
665        end;
666        PrevWindowProc(Message)
667      end;
668      if (Msg = TNT_WM_DESTROY) then 
669        UnSubClassUnicodeControl; {The reason for doing this in DefWin32Proc is because in D9, TWinControl.WMDestroy() does a perform(WM_TEXT) operation. }
670    end;
671  end;
672end;
673
674//----------------------------------------------------------------------------------
675
676function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap;
677var
678  i: integer;
679begin
680  // find or create trap object
681  Result := nil;
682  for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin
683    if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin
684      Result := TWinControlTrap(PendingRecreateWndTrapList[i]);
685      PendingRecreateWndTrapList.Delete(i);
686      break; { found it }
687    end;
688  end;
689  if Result = nil then
690    Result := TWinControlTrap.Create(Control);
691end;
692
693procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False);
694var
695  WinControlTrap: TWinControlTrap;
696begin
697  if not IsWindowUnicode(Control.Handle) then
698    raise ETntInternalError.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.');
699
700  WinControlTrap := FindOrCreateWinControlTrap(Control);
701  WinControlTrap.SubClassControl(Params_Caption);
702  WinControlTrap.IDEWindow := IDEWindow;
703end;
704
705
706//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE
707
708var
709  WindowAtom: TAtom;
710  ControlAtom: TAtom;
711  WindowAtomString: AnsiString;
712  ControlAtomString: AnsiString;
713
714type
715  TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall;
716
717function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall;
718
719    function GetObjectInstance(Control: TWinControl): Pointer;
720    var
721      WinControlTrap: TWinControlTrap;
722    begin
723      WinControlTrap := FindOrCreateWinControlTrap(Control);
724      PendingRecreateWndTrapList.Add(WinControlTrap);
725      Result := WinControlTrap.WinControl_ObjectInstance;
726    end;
727
728var
729  ObjectInstance: Pointer;
730begin
731  TAccessWinControl(CreationControl).WindowHandle := HWindow;
732  ObjectInstance := GetObjectInstance(CreationControl);
733  {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!}
734  SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance));
735  if  (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0)
736  and (GetWindowLongW(HWindow, GWL_ID) = 0) then
737    SetWindowLongW(HWindow, GWL_ID, Integer(HWindow));
738  SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl));
739  SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl));
740  CreationControl := nil;
741  Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam);
742end;
743
744procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False);
745const
746  UNICODE_CLASS_EXT = '.UnicodeClass';
747var
748  TempClass: TWndClassW;
749  WideClass: TWndClassW;
750  ClassRegistered: Boolean;
751  InitialProc: TFNWndProc;
752begin
753  if IDEWindow then
754    InitialProc := @InitWndProc
755  else
756    InitialProc := @InitWndProcW;
757
758  with Params do begin
759    WideWinClassName := WinClassName + UNICODE_CLASS_EXT;
760    ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass);
761    if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc)
762    then begin
763      if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance));
764      // Prepare a TWndClassW record
765      WideClass := TWndClassW(WindowClass);
766      WideClass.hInstance := hInstance;
767      WideClass.lpfnWndProc := InitialProc;
768      if not Tnt_Is_IntResource(PWideChar(WindowClass.lpszMenuName)) then begin
769        WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName));
770      end;
771      WideClass.lpszClassName := PWideChar(WideWinClassName);
772
773      // Register the UNICODE class
774      if RegisterClassW(WideClass) = 0 then RaiseLastOSError;
775    end;
776  end;
777end;
778
779procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams;
780                                        const SubClass: WideString; IDEWindow: Boolean = False);
781var
782  TempSubClass: TWndClassW;
783  WideWinClassName: WideString;
784  Handle: THandle;
785begin
786  if (not Win32PlatformIsUnicode) then begin
787    with Params do
788      TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName,
789        Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);
790  end else begin
791    // SubClass the unicode version of this control by getting the correct DefWndProc
792    if (SubClass <> '')
793    and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then
794      TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc
795    else
796      TAccessWinControl(Control).DefWndProc := @DefWindowProcW;
797
798    // make sure Unicode window class is registered
799    RegisterUnicodeClass(Params, WideWinClassName, IDEWindow);
800
801    // Create UNICODE window handle
802    UnicodeCreationControl := Control;
803    try
804      with Params do
805        Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil,
806          Style, X, Y, Width, Height, WndParent, 0, hInstance, Param);
807      if Handle = 0 then
808        RaiseLastOSError;
809      TAccessWinControl(Control).WindowHandle := Handle;
810      if IDEWindow then
811        SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC));
812    finally
813      UnicodeCreationControl := nil;
814    end;
815
816    SubClassUnicodeControl(Control, Params.Caption, IDEWindow);
817  end;
818end;
819
820procedure ReCreateUnicodeWnd(Control: TWinControl; Subclass: WideString; IDEWindow: Boolean = False);
821var
822  WasFocused: Boolean;
823  Params: TCreateParams;
824begin
825  with TAccessWinControl(Control) do begin
826    WasFocused := Focused;
827    DestroyHandle;
828    CreateParams(Params);
829    CreationControl := Control;
830    CreateUnicodeHandle(Control, Params, SubClass, IDEWindow);
831    StrDispose{TNT-ALLOW StrDispose}(WindowText);
832    WindowText := nil;
833    Perform(WM_SETFONT, Integer(Font.Handle), 1);
834    if AutoSize then AdjustSize;
835    UpdateControlState;
836    if WasFocused and (WindowHandle <> 0) then Windows.SetFocus(WindowHandle);
837  end;
838end;
839
840{ TTntCustomHintWindow procs }
841
842function DataPointsToHintInfoForTnt(AData: Pointer): Boolean;
843begin
844  try
845    Result := (AData <> nil)
846          and (PHintInfo(AData).HintData = AData) {points to self}
847          and (PHintInfo(AData).HintWindowClass.InheritsFrom(TTntCustomHintWindow));
848  except
849    Result := False;
850  end;
851end;
852
853function ExtractTntHintCaption(AData: Pointer): WideString;
854var
855  Control: TControl;
856  WideHint: WideString;
857  AnsiHintWithShortCut: AnsiString;
858  ShortCut: TShortCut;
859begin
860  Result := PHintInfo(AData).HintStr;
861  if Result <> '' then begin
862    Control := PHintInfo(AData).HintControl;
863    WideHint := WideGetShortHint(WideGetHint(Control));
864    if (AnsiString(WideHint) = PHintInfo(AData).HintStr) then
865      Result := WideHint
866    else if Application.HintShortCuts and (Control <> nil)
867    and (Control.Action is TCustomAction{TNT-ALLOW TCustomAction}) then begin
868      ShortCut := TCustomAction{TNT-ALLOW TCustomAction}(Control.Action).ShortCut;
869      if (ShortCut <> scNone) then
870      begin
871        AnsiHintWithShortCut := Format{TNT-ALLOW Format}('%s (%s)', [WideHint, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)]);
872        if AnsiHintWithShortCut = PHintInfo(AData).HintStr then
873          Result := WideFormat('%s (%s)', [WideHint, WideShortCutToText(ShortCut)]);
874      end;
875    end;
876  end;
877end;
878
879{ TTntCustomHintWindow }
880
881procedure TTntCustomHintWindow.CreateWindowHandle(const Params: TCreateParams);
882begin
883  CreateUnicodeHandle(Self, Params, '');
884end;
885
886{$IFNDEF COMPILER_7_UP}
887procedure TTntCustomHintWindow.CreateParams(var Params: TCreateParams);
888const
889  CS_DROPSHADOW = $00020000;
890begin
891  inherited;
892  if Win32PlatformIsXP then { Enable drop shadow effect on Windows XP and later. }
893    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
894end;
895{$ENDIF}
896
897function TTntCustomHintWindow.GetCaption: TWideCaption;
898begin
899  Result := TntControl_GetText(Self)
900end;
901
902procedure TTntCustomHintWindow.SetCaption(const Value: TWideCaption);
903begin
904  TntControl_SetText(Self, Value);
905end;
906
907procedure TTntCustomHintWindow.Paint;
908var
909  R: TRect;
910begin
911  if FBlockPaint then
912    exit;
913  if (not Win32PlatformIsUnicode) then
914    inherited
915  else begin
916    R := ClientRect;
917    Inc(R.Left, 2);
918    Inc(R.Top, 2);
919    Canvas.Font.Color := Screen.HintFont.Color;
920    Tnt_DrawTextW(Canvas.Handle, PWideChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or
921      DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly);
922  end;
923end;
924
925procedure TTntCustomHintWindow.CMTextChanged(var Message: TMessage);
926begin
927  { Avoid flicker when calling ActivateHint }
928  if FActivating then Exit;
929  Width := WideCanvasTextWidth(Canvas, Caption) + 6;
930  Height := WideCanvasTextHeight(Canvas, Caption) + 6;
931end;
932
933procedure TTntCustomHintWindow.ActivateHint(Rect: TRect; const AHint: AnsiString);
934var
935  SaveActivating: Boolean;
936begin
937  SaveActivating := FActivating;
938  try
939    FActivating := True;
940    inherited;
941  finally
942    FActivating := SaveActivating;
943  end;
944end;
945
946procedure TTntCustomHintWindow.ActivateHintData(Rect: TRect; const AHint: AnsiString; AData: Pointer);
947var
948  SaveActivating: Boolean;
949begin
950  if (not Win32PlatformIsUnicode)
951  or (not DataPointsToHintInfoForTnt(AData)) then
952    inherited
953  else begin
954    FBlockPaint := True;
955    try
956      SaveActivating := FActivating;
957      try
958        FActivating := True;
959        inherited;
960        Caption := ExtractTntHintCaption(AData);
961      finally
962        FActivating := SaveActivating;
963      end;
964    finally
965      FBlockPaint := False;
966    end;
967    Invalidate;
968  end;
969end;
970
971function TntHintWindow_CalcHintRect(HintWindow: TTntCustomHintWindow; MaxWidth: Integer; const AHint: WideString): TRect;
972begin
973  Result := Rect(0, 0, MaxWidth, 0);
974  Tnt_DrawTextW(HintWindow.Canvas.Handle, PWideChar(AHint), -1, Result, DT_CALCRECT or DT_LEFT or
975    DT_WORDBREAK or DT_NOPREFIX or HintWindow.DrawTextBiDiModeFlagsReadingOnly);
976  Inc(Result.Right, 6);
977  Inc(Result.Bottom, 2);
978end;
979
980function TTntCustomHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: AnsiString; AData: Pointer): TRect;
981var
982  WideHintStr: WideString;
983begin
984  if (not Win32PlatformIsUnicode)
985  or (not DataPointsToHintInfoForTnt(AData)) then
986    Result := inherited CalcHintRect(MaxWidth, AHint, AData)
987  else begin
988    WideHintStr := ExtractTntHintCaption(AData);
989    Result := TntHintWindow_CalcHintRect(Self, MaxWidth, WideHintStr);
990  end;
991end;
992
993{ TTntHintWindow }
994
995procedure TTntHintWindow.ActivateHint(Rect: TRect; const AHint: WideString);
996var
997  SaveActivating: Boolean;
998begin
999  SaveActivating := FActivating;
1000  try
1001    FActivating := True;
1002    Caption := AHint;
1003    inherited ActivateHint(Rect, AHint);
1004  finally
1005    FActivating := SaveActivating;
1006  end;
1007end;
1008
1009procedure TTntHintWindow.ActivateHintData(Rect: TRect; const AHint: WideString; AData: Pointer);
1010var
1011  SaveActivating: Boolean;
1012begin
1013  FBlockPaint := True;
1014  try
1015    SaveActivating := FActivating;
1016    try
1017      FActivating := True;
1018      Caption := AHint;
1019      inherited ActivateHintData(Rect, AHint, AData);
1020    finally
1021      FActivating := SaveActivating;
1022    end;
1023  finally
1024    FBlockPaint := False;
1025  end;
1026  Invalidate;
1027end;
1028
1029function TTntHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: WideString; AData: Pointer): TRect;
1030begin
1031  Result := TntHintWindow_CalcHintRect(Self, MaxWidth, AHint);
1032end;
1033
1034procedure WideListControl_AddItem(Control: TCustomListControl; const Item: WideString; AObject: TObject);
1035var
1036  WideControl: IWideCustomListControl;
1037begin
1038  if Control.GetInterface(IWideCustomListControl, WideControl) then
1039    WideControl.AddItem(Item, AObject)
1040  else
1041    Control.AddItem(Item, AObject);
1042end;
1043
1044procedure InitControls;
1045
1046  procedure InitAtomStrings_D6_D7_D9;
1047  var
1048    Controls_HInstance: Cardinal;
1049  begin
1050    Controls_HInstance := FindClassHInstance(TWinControl);
1051    WindowAtomString := Format{TNT-ALLOW Format}('Delphi%.8X',[GetCurrentProcessID]);
1052    ControlAtomString := Format{TNT-ALLOW Format}('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]);
1053  end;
1054
1055  {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6
1056  procedure InitAtomStrings;
1057  begin
1058    InitAtomStrings_D6_D7_D9;
1059  end;
1060  {$ENDIF}
1061  {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7
1062  procedure InitAtomStrings;
1063  begin
1064    InitAtomStrings_D6_D7_D9;
1065  end;
1066  {$ENDIF}
1067  {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9
1068  procedure InitAtomStrings;
1069  begin
1070    InitAtomStrings_D6_D7_D9;
1071  end;
1072  {$ENDIF}
1073  {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10
1074  procedure InitAtomStrings;
1075  begin
1076    InitAtomStrings_D6_D7_D9;
1077  end;
1078  {$ENDIF}
1079
1080begin
1081  InitAtomStrings;
1082  WindowAtom := WinCheckH(GlobalAddAtom(PAnsiChar(WindowAtomString)));
1083  ControlAtom := WinCheckH(GlobalAddAtom(PAnsiChar(ControlAtomString)));
1084end;
1085
1086initialization
1087  TNT_WM_DESTROY := RegisterWindowMessage('TntUnicodeVcl.DestroyWindow');
1088  WideControlHelpers := TComponentList.Create(True);
1089  PendingRecreateWndTrapList := TComponentList.Create(False);
1090  InitControls;
1091
1092finalization
1093  GlobalDeleteAtom(ControlAtom);
1094  GlobalDeleteAtom(WindowAtom);
1095  FreeAndNil(WideControlHelpers);
1096  FreeAndNil(PendingRecreateWndTrapList);
1097  Finalized := True;
1098
1099end.
Note: See TracBrowser for help on using the repository browser.