改变文本光标状态

CreateCaret()
showcaret()
destroycaret();
HideCaret();
***********
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
const
wm_newcaret=wm_user+1;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Image1: TImage;
procedure Edit1Enter(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure newcaret(var msg:Tmessage);message wm_newcaret;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Edit1Enter(Sender: TObject);
begin
postmessage(handle,wm_newcaret,0,0);
end;
procedure TForm1.newcaret(var msg: Tmessage);
begin
edit1.setfocus;
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
end;
end.
//利用onenter事件，用postmessage发出一个自定义消息
//在自定义消息中,用sendmessage强制setfocus后，再createcaret就可以了
Edit收到焦点时，光标是变了，但一旦我键入字符，光标又变回原样。我想知道如何在编辑文字时，光标一直不变（自定义的）
只要响应application.onactivate事件可以了
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, AppEvnts;
const
wm_newcaret=wm_user+1;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Image1: TImage;
ApplicationEvents1: TApplicationEvents;
procedure Edit1Enter(Sender: TObject);
procedure ApplicationEvents1Activate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure newcaret(var msg:Tmessage);message wm_newcaret;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Edit1Enter(Sender: TObject);
begin
postmessage(handle,wm_newcaret,0,0);
end;
procedure TForm1.newcaret(var msg: Tmessage);
begin
edit1.setfocus;
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
end;
procedure TForm1.ApplicationEvents1Activate(Sender: TObject);
begin
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
end;
end.
**********************
unit unit1;
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;
end.