Create a colored caret in a TMemo

Mirror

Create a colored caret in a TMemo (Views: 704)

Problem/Question/Abstract:

How to create a colored caret in a TMemo

Answer:

It is possible to color the caret. Windows uses inverse color values for its carets. Black for white, white for black, etc. I made a blue caret by making a bitmap 7 pixels wide and 14 pixels tall with a black background and yellow foreground. Here's how I handled it: I'm not sure if I am handling the destruction correctly or not, that is something I will leave up to you to figure out...

unit caret1;

interface

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

const
  MY_POST_ENTER = WM_USER + 500;

type

  TForm1 = class(TForm)
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Memo1Exit(Sender: TObject);
    procedure Memo1Change(Sender: TObject);
    procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure Memo1Enter(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure MyPost_Enter(var Message: TMessage); message MY_POST_ENTER;
  end;

var
  Form1: TForm1;
  hCaret: HBITMAP;

implementation

{$R *.DFM}
{$R caret2.res} // caret2.res has the 7 x 14 bitmap in it

procedure TForm1.MyPost_Enter(var Message: TMessage);
var
  CaretHeight: Integer;
begin
  hCaret := LoadBitmap(hInstance, MAKEINTRESOURCE(150));
  CreateCaret(TWinControl(ActiveControl).Handle, hCaret, 0, 0);
  ShowCaret(TWinControl(ActiveControl).Handle);
end;

procedure TForm1.Memo1Exit(Sender: TObject);
begin
  DestroyCaret;
  CreateCaret(TWinControl(ActiveControl).Handle, 1, 1, 1);
  ShowCaret(TWinControl(ActiveControl).Handle);
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

procedure TForm1.Memo1Enter(Sender: TObject);
begin
  PostMessage(Handle, MY_POST_ENTER, 0, 0);
end;

end.

DFM Text:

object Form1: TForm1
  Left = 270
    Top = 97
    Width = 214
    Height = 192
    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 Edit1: TEdit
    Left = 16
      Top = 112
      Width = 121
      Height = 21
      TabOrder = 0
      Text = 'Edit1'
      OnChange = Memo1Change
      OnEnter = Memo1Enter
      OnExit = Memo1Exit
  end
  object Memo1: TMemo
    Left = 8
      Top = 8
      Width = 185
      Height = 89
      Lines.Strings = ('Memo1')
      TabOrder = 1
      OnChange = Memo1Change
      OnEnter = Memo1Enter
      OnExit = Memo1Exit
  end
end

<< Back to main page