Own cool text cursor in Editbox
Standard text cursor is boring. What about replacing default vertical line with some cool shape?
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; 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; type WParameter = LongInt; LParameter = LongInt; var Form1: TForm1; implementation {$R *.dfm} function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt stdcall; begin 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 //normal cursor 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'); //backspace cursor 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'); OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); end; procedure TForm1.FormDestroy(Sender: TObject); begin SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc)); CaretBm.Free; CaretBmBk.Free; end; end. |