Ver Mensaje Individual
  #9  
Antiguo 30-12-2022
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 2.197
Reputación: 20
escafandra Tiene un aura espectacularescafandra Tiene un aura espectacular
Para completar el tema he preparado un ejemplo usando subclassing en un Edit. El subclassing lo realizo estilo VCL con el procedimiento que adjunto SetSubCass


Se cambiará a color rojo la primera palabra del texto del Edit sólo si esta deshabilitado y el subclassing activo

Subo el código completo y el formulario queda como el de la imagen Gif que se muestra con su funcionalidad.


Código Delphi [-]
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    procedure CheckBox1Click(Sender: TObject);
    procedure CheckBox2Click(Sender: TObject);

  private
    oldWndProc: TWndMethod;
  public
    procedure SubClassWndProc(var Message: TMessage);

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//---------------------------------------------------------------------------
// Realiza un subclassing estilo VCL
procedure SetSubCass(WC: TWinControl; newProc: TWndMethod; var oldProc: TWndMethod);
begin
  oldProc:= WC.WindowProc;
  WC.WindowProc:= newProc;
end;


//---------------------------------------------------------------------------
// CORAZÓN DEL ASUNTO

procedure TForm1.SubClassWndProc(var Message: TMessage);
var 
  ps: PAINTSTRUCT; 
  DC: HDC;
  Size: TSize;
  i: integer;
  S: String;
begin
  if (Message.Msg = WM_PAINT) and not Edit1.Enabled then
  with Edit1 do
  begin
    DC:= BeginPaint(Handle, ps);
    // Para la primera palabra del Edit.Text
    SetTextColor(DC, clRed);
    SelectObject(DC, SendMessage(Handle, WM_GETFONT, 0, 0));
    i:= Pos(' ', Text);
    if i = 0 then i:= Length(Text);
    S:= Copy(Text, 1, i);
    TextOutA(DC, 1,1, PChar(S), Length(S));
    // Para el resto del Edit.Text
    SetTextColor(DC, clBlack);
    GetTextExtentPoint32(DC, PChar(S), Length(S), Size);
    SelectObject(DC, SendMessage(Handle, WM_GETFONT, 0, 0));
    S:= Copy(Text, i+1, Length(Text));
    TextOutA(DC, Size.cx+1, 1, PChar(S), Length(S));

    EndPaint(Handle, ps);
  end;
  oldWndProc(Message);
end;
//---------------------------------------------------------------------------


procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  // Hacemos el subclass
  if CheckBox1.Checked then
    SetSubCass(Edit1, SubClassWndProc, oldWndProc)
  // Deshacemos el SubClass
  else
    Edit1.WindowProc:= oldWndProc;
  Edit1.Repaint;
end;

procedure TForm1.CheckBox2Click(Sender: TObject);
begin
  Edit1.Enabled:= CheckBox2.Checked;
end;

end.













Saludos.
Responder Con Cita