tntcontrols.pas

TNT Components Source

  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));