Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?

Previous  Top  Next

    
 

 

 

Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

Code:

unit caret1;

 

interface

 

{$IFDEF WIN32}

uses

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

{$ELSE}

uses

WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

{$ENDIF}

 

type

TForm1 = class(TForm)

   Edit1: TEdit;

   procedure FormCreate(Sender: TObject);

   procedure FormDestroy(Sender: TObject);

private

{Private declarations}

public

{Public declarations}

   CaretBm: TBitmap;

   CaretBmBk: TBitmap;

   OldEditsWindowProc: Pointer;

end;

 

var

Form1: TForm1;

 

implementation

{$R *.DFM}

 

type

{$IFDEF WIN32}

WParameter = LongInt;

{$ELSE}

WParameter = Word;

{$ENDIF}

LParameter = LongInt;

 

{New windows procedure for the edit control}

 

function NewWindowProc(WindowHandle: hWnd; TheMessage: WParameter; ParamW: WParameter;

ParamL: LParameter): LongInt

{$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}

begin

{Call the old edit controls windows procedure}

NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,

   TheMessage, ParamW, ParamL);

if TheMessage = WM_SETFOCUS then

   begin

     CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);

     ShowCaret(WindowHandle);

   end;

if TheMessage = WM_KILLFOCUS then

   begin

     HideCaret(WindowHandle);

     DestroyCaret;

   end;

if TheMessage = WM_KEYDOWN then

   begin

     if ParamW = VK_BACK then

       CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)

     else

       CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);

     ShowCaret(WindowHandle);

   end;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

{Create a smiling bitmap using the wingdings font}

CaretBm := TBitmap.Create;

CaretBm.Canvas.Font.Name := 'WingDings';

CaretBm.Canvas.Font.Height := Edit1.Font.Height;

CaretBm.Canvas.Font.Color := clWhite;

CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;

CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;

CaretBm.Canvas.Brush.Color := clBlue;

CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));

CaretBm.Canvas.TextOut(1, 1, 'J');

{Create a frowming bitmap using the wingdings font}

CaretBmBk := TBitmap.Create;

CaretBmBk.Canvas.Font.Name := 'WingDings';

CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;

CaretBmBk.Canvas.Font.Color := clWhite;

CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;

CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;

CaretBmBk.Canvas.Brush.Color := clBlue;

CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));

CaretBmBk.Canvas.TextOut(1, 1, 'L');

{Hook the edit controls window procedure}

OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC,

   LongInt(@NewWindowProc)));

end;

 

procedure TForm1.FormDestroy(Sender: TObject);

begin

{Unhook the edit controls window procedure and clean up}

SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));

CaretBm.Free;

CaretBmBk.Free;

end;

©Drkb::02338


 

Code:

{

The example below demonstrates creating custom caret:

}

 

unit Unit1;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls;

 

type

TForm1 = class(TForm)

   Memo1: TMemo;

   Image1: TImage;

   Edit1: TEdit;

   procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

   procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

private

   { Private declarations }

public

   { Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.DFM}

 

procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

CreateCaret(Memo1.Handle, Image1.Picture.Bitmap.Handle, 0, 0);

ShowCaret(Memo1.Handle);

end;

 

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

CreateCaret(Edit1.Handle, 0, 10, 4);

ShowCaret(Edit1.Handle);

end;

 

end.

 

Code:

{The form file source (*.dfm) }

 

object Form1: TForm1

   Left = 192

   Top = 107

   Width = 544

   Height = 375

   Caption = 'Form1'

   Color = clBtnFace

   Font.Charset = DEFAULT_CHARSET

   Font.Color = clWindowText

   Font.Height = -11

   Font.Name = 'MS Sans Serif'

   Font.Style = []

   OldCreateOrder = False

   PixelsPerInch = 96

   TextHeight = 13

   object Image1: TImage

     Left = 12

     Top = 4

     Width = 16

     Height = 16

     AutoSize = True

     Picture.Data =

     07544269746D6170B6020000424DB602000000000000B6000000280000001000 

     0000100000000100100000000000000200000000000000000000100000000000 

     000000000000000080000080000000808000800000008000800080800000C0C0 

     C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF 

     FF00000000000000000000000000000000000000000000000000000000000000 

     0000000000000000000000000000000000000000000000000000000000000000 

     000000000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F 

     00000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000 

     0000FF7FFF7FFF7FFF7FFF7F00000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000 

     000000000000FF7FFF7FFF7F0000000000000000FF7FFF7FFF7FFF7F00000000 

     0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000 

     0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F000000000000 

     0000000000000000FF7FFF7FFF7F00000000FF7FFF7FFF7FFF7F000000000000 

     00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000 

     00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000 

     000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000000000000000 

     000000000000000000000000FF7FFF7FFF7FFF7FFF7F00000000000000000000 

     0000000000000000000000000000FF7FFF7FFF7FFF7F00000000000000000000 

     0000000000000000000000000000FF7FFF7FFF7F000000000000000000000000 

     00000000000000000000000000000000FF7F0000000000000000000000000000 

     0000}

   end

   object Memo1: TMemo

     Left = 12

     Top = 36

     Width = 149

     Height = 149

     Lines.Strings = ('Memo1')

     TabOrder = 0

     OnMouseDown = Memo1MouseDown

   end

   object Edit1: TEdit

     Left = 220

     Top = 60

     Width = 121

     Height = 21

     TabOrder = 1

     Text = 'Edit1'

     OnMouseDown = Edit1MouseDown

   end

end

 

©Drkb::02337

Взято с сайта: http://www.swissdelphicenter.ch