本例測試修改光標的形色, 效果圖:
代碼文件:unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
RadioGroup1: TRadioGroup;
procedure FormCreate(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure RadioGroup1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
bit: TBitmap;
procedure TForm1.FormCreate(Sender: TObject);
const
c = '★';
begin
RadioGroup1.Caption := '光標形色';
RadioGroup1.Items.CommaText := '黑色,灰度,自定義';
RadioGroup1.ItemIndex := 0;
bit := TBitmap.Create;
bit.Canvas.Font.Size := 16;
bit.Width := bit.Canvas.TextWidth(c);
bit.Height := bit.Canvas.TextHeight(c);
bit.Canvas.TextOut(0, 0, c);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SetCaretBlinkTime(530);
bit.Free;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
h: HBITMAP;
begin
DestroyCaret;
h := 0;
case RadioGroup1.ItemIndex of
1: h := 1;
2: h := bit.Handle;
end;
CreateCaret(Handle, h, 4, 32);
SetCaretPos(X,Y);
ShowCaret(Handle);
end;
procedure TForm1.RadioGroup1Click(Sender: TObject);
var
h: HBITMAP;
pt: TPoint;
begin
GetCaretPos(pt);
DestroyCaret;
h := 0;
case RadioGroup1.ItemIndex of
1: h := 1;
2: h := bit.Handle;
end;
CreateCaret(Handle, h, 4, 32);
SetCaretPos(pt.X, pt.Y);
ShowCaret(Handle);
end;
end.
窗體文件:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 137
ClientWidth = 228
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnMouseUp = FormMouseUp
PixelsPerInch = 96
TextHeight = 13
object RadioGroup1: TRadioGroup
Left = 137
Top = 16
Width = 80
Height = 113
Caption = 'RadioGroup1'
TabOrder = 0
OnClick = RadioGroup1Click
end
end
