不使用ListBox的方法，总之为了不闪烁必须增加不少工作量。实在写的累，不加注解了，
应该没有大的问题。
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Math;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure FormMouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
private
{ Private declarations }
FMouseDown : Boolean;
FFocused : integer;
function GetSelected(Index: integer): Boolean;
procedure SetSelected(Index: integer;
const Value: Boolean);
public
{ Public declarations }
FStrings : TStringList;
property Selected[Index: integer]: Boolean read GetSelected write SetSelected;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FStrings := TStringList.Create;
FMouseDown := False;
FFocused := -1;
with FStringsdo
begin
AddObject('红藕香残玉簟秋', TObject(0));
AddObject('轻解罗裳', TObject(0));
AddObject('独上兰洲', TObject(0));
AddObject('云中谁寄锦书来', TObject(0));
AddObject('雁字回时', TObject(0));
AddObject('月满西楼', TObject(0));
AddObject('花自飘零水自流', TObject(0));
AddObject('一种相思', TObject(0));
AddObject('两处闲愁', TObject(0));
AddObject('此情无计可消除', TObject(0));
AddObject('才下眉头', TObject(0));
AddObject('却上心头', TObject(0));
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(FStrings);
end;
procedure TForm1.FormPaint(Sender: TObject);
var
i : integer;
begin
with Canvasdo
begin
Brush.Color := clBlack;
Font.Color := clGreen;
FillRect(ClientRect);
for i:=0 to FStrings.Count-1do
begin
if Integer(FStrings.Objects)=0 then
Brush.Color := clBlack
else
Brush.Color := clBlue;
FillRect(Rect(0,i*40,ClientWidth,(i+1)*40));
TextOut(0, i*40, FStrings);
end;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
var
i, Index : integer;
rc : TRect;
begin
if Button<>mbLeft then
Exit;
Index := Y div 40;
if Index>=FStrings.Count then
Exit;
FMouseDown := True;
if ssCtrl in Shift then
begin
Selected[Index] := not Selected[Index];
rc := Rect(0, Index*40, ClientWidth, (Index+1)*40);
InvalidateRect(Handle, @rc, False);
FFocused := Index;
end
else
if ssShift in Shift then
begin
for i:=0 to FStrings.Count-1do
if Selected then
begin
Selected := False;
rc := Rect(0, i*40, ClientWidth, (i+1)*40);
InvalidateRect(Handle, @rc, False);
end;
if FFocused<0 then
begin
for i:=0 to Indexdo
Selected := True;
rc := Rect(0, 0, ClientWidth, (Index+1)*40);
InvalidateRect(Handle, @rc, False);
end
else
begin
if Index>=FFocused then
begin
for i:=FFocused to Indexdo
Selected := True;
rc := Rect(0, FFocused*40, ClientWidth, (Index+1)*40);
end
else
begin
for i:=FFocuseddo
wnto Indexdo
Selected := True;
rc := Rect(0, Index*40, ClientWidth, (FFocused+1)*40);
end;
InvalidateRect(Handle, @rc, False);
end;
FFocused := Index;
end
else
begin
if Selected[Index]=False then
begin
for i:=0 to FStrings.Count-1do
if Selected then
begin
Selected := False;
rc := Rect(0, i*40, ClientWidth, (i+1)*40);
InvalidateRect(Handle, @rc, False);
end;
Selected[Index] := True;
rc := Rect(0, Index*40, ClientWidth, (Index+1)*40);
InvalidateRect(Handle, @rc, False);
end;
FFocused := Index;
end;
end;
function TForm1.GetSelected(Index: integer): Boolean;
begin
if Index>=FStrings.Count then
Raise Exception.Create('Error:Index out of bounds');
Result := (Integer(FStrings.Objects[Index])<>0);
end;
procedure TForm1.SetSelected(Index: integer;
const Value: Boolean);
begin
if Index>=FStrings.Count then
Raise Exception.Create('Error:Index out of Bounds');
if Value then
FStrings.Objects[Index] := TObject(1)
else
FStrings.Objects[Index] := TObject(0);
end;
procedure TForm1.FormMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
var
i, NewFocus : integer;
rc : TRect;
begin
FMouseDown := False;
NewFocus := Y div 40;
if NewFocus>=FStrings.Count then
Exit;
if (NewFocus=FFocused) and not(ssCtrl in Shift) and
not(ssShift in Shift) then
begin
for i:=0 to FStrings.Count-1do
if (Selected) and (i<>FFocused) then
begin
Selected := False;
rc := Rect(0, i*40, ClientWidth, (i+1)*40);
InvalidateRect(Handle, @rc, False);
end;
FFocused := NewFocus;
Selected[FFocused] := True;
rc := Rect(0, NewFocus*40, ClientWidth, (NewFocus+1)*40);
InvalidateRect(Handle, @rc, False);
end;
end;
procedure TForm1.FormMouseMove(Sender: TObject;
Shift: TShiftState;
X,
Y: Integer);
var
NewFocus, i, Delta : integer;
rc : TRect;
begin
if not FMouseDown then
Exit;
NewFocus := Y div 40;
if NewFocus=FFocused then
Exit;
Delta := NewFocus - FFocused;
if Delta<0 then
begin
for i:=0 to FStrings.Count-1do
if Selected then
begin
Delta := Max(-i,Delta);
Break;
end;
if Delta=0 then
Exit;
for i:=0 to FStrings.Count-1do
if Selected then
begin
FStrings.Move(i, i+Delta);
rc := Rect(0, i*40, ClientWidth, (i+1)*40);
InvalidateRect(Handle, @rc, False);
rc := Rect(0, (i+Delta)*40, ClientWidth, (i+Delta+1)*40);
InvalidateRect(Handle, @rc, False);
end;
end
else
begin
for i:=FStrings.Count-1do
wnto 0do
if Selected then
begin
Delta := Min(FStrings.Count-1-i, Delta);
end;
if Delta=0 then
Exit;
for i:= FStrings.Count-1do
wnto 0do
if Selected then
begin
FStrings.Move(i, i+Delta);
rc := Rect(0, i*40, ClientWidth, (i+1)*40);
InvalidateRect(Handle, @rc, False);
rc := Rect(0, (i+Delta)*40, ClientWidth, (i+Delta+1)*40);
InvalidateRect(Handle, @rc, False);
end;
end;
FFocused := FFocused + Delta;
end;
end.
