tntcontrols.pas

TNT Components Source

  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.