StringGrid行列的增加和删除
type
TExCell = class(TStringGrid)

public
procedure DeleteRow(ARow: Longint);
procedure DeleteColumn(ACol: Longint);
procedure InsertRow(ARow: LongInt);
procedure InsertColumn(ACol: LongInt);
end;

procedure TExCell.InsertColumn(ACol: Integer);
begin
ColCount :=ColCount +1;
MoveColumn(ColCount-1, ACol);
end;

procedure TExCell.InsertRow(ARow: Integer);
begin
RowCount :=RowCount +1;
MoveRow(RowCount-1, ARow);
end;

procedure TExCell.DeleteColumn(ACol: Longint);
begin
MoveColumn(ACol, ColCount -1);
ColCount := ColCount - 1;
end;

procedure TExCell.DeleteRow(ARow: Longint);
begin
MoveRow(ARow, RowCount - 1);
RowCount := RowCount - 1;
end;

如何编写使StringGrid中的一列具有Check功能，和CheckBox效果一样
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids;

type
TForm1 = class(TForm)
grid: TStringGrid;
procedure FormCreate(Sender: TObject);
procedure gridDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure gridClick(Sender: TObject);

private
{ Private declarations }

public
{ Public declarations }

end;

var
Form1: TForm1;
fcheck,fnocheck:tbitmap;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
i:SmallInt;
bmp:TBitmap;
begin
FCheck:= TBitmap.Create;
FNoCheck:= TBitmap.Create;
bmp:= TBitmap.create;
try
　 bmp.handle := LoadBitmap( 0, PChar(OBM_CHECKBOXES ));
　 With FNoCheck Do Begin
　　 width := bmp.width div 4;
　　 height := bmp.height div 3;
　　 canvas.copyrect( canvas.cliprect, bmp.canvas, canvas.cliprect );
　 End;
With FCheck Do Begin
　 width := bmp.width div 4;
　 height := bmp.height div 3;
　 canvas.copyrect(canvas.cliprect, bmp.canvas, rect( width, 0, 2*width, height ));
End;
finally
　 bmp.free
end;
end;

procedure TForm1.gridDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
if not (gdFixed in State) then
　 with TStringGrid(Sender).Canvas do
begin
　 brush.Color:=clWindow;
　 FillRect(Rect);
　 if Grid.Cells[ACol,ARow]='yes' then
　　 Draw( (rect.right + rect.left - FCheck.width) div 2, (rect.bottom + rect.top - FCheck.height) div 2, FCheck )
　 else
　　 Draw( (rect.right + rect.left - FCheck.width) div 2, (rect.bottom + rect.top - FCheck.height) div 2, FNoCheck );
end;
end;

procedure TForm1.gridClick(Sender: TObject);
begin
if grid.Cells[grid.col,grid.row]='yes' then
　 grid.Cells[grid.col,grid.row]:='no'
else
　 grid.Cells[grid.col,grid.row]:='yes';
end;

end.

StringGrid组件Cells内容分行显示在Tstringgrid.ondrawcell事件中

DrawText(StringGrid1.Canvas.Handle,pchar(StringGrid1.Cells[Acol,Arow]),Length(StringGrid1.Cells[Acol,Arow]),Rect,DT_WORDBREAK or DT_LEFT);

可以实现文字换行！

在StringGrid怎样制作只读的列在 OnSelectCell事件处理程序中,加入: (所有的列均设成可修改的)

if Col mod 2 = 0 then
　 grd.Options := grd.Options + [goEditing]
else
　 grd.Options := grd.Options - [goEditing];

stringgrid从文本读入的问题（Save/Load a TStringGrid to/from a file?）stringgrid从文本读入的问题

// Save a TStringGrid to a file
procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
i, k: Integer;
begin
AssignFile(f, FileName);
Rewrite(f);
with StringGrid do
begin
　 // Write number of Columns/Rows
　 Writeln(f, ColCount);
　 Writeln(f, RowCount);
　 // loop through cells
　 for i := 0 to ColCount - 1 do
　　 for k := 0 to RowCount - 1 do
　　　 Writeln(F, Cells[i, k]);
end;
CloseFile(F);
end;

// Load a TStringGrid from a file
procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
iTmp, i, k: Integer;
strTemp: String;
begin
AssignFile(f, FileName);
Reset(f);
with StringGrid do
begin
　 // Get number of columns
　 Readln(f, iTmp);
　 ColCount := iTmp;
　 // Get number of rows
　 Readln(f, iTmp);
　 RowCount := iTmp;
　 // loop through cells & fill in values
　 for i := 0 to ColCount - 1 do
　　 for k := 0 to RowCount - 1 do
　　 begin
　　　 Readln(f, strTemp);
　　　 Cells[i, k] := strTemp;
　　 end;
　 end;
CloseFile(f);
end;

// Save StringGrid1 to 'c:.txt':
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveStringGrid(StringGrid1, 'c:.txt');
end;

// Load StringGrid1 from 'c:.txt':
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadStringGrid(StringGrid1, 'c:.txt');
end;

*******************************************

打开一个已有的文本文件,并将内容放到stringgrid中,文本行与stringgrid行一致;
在文本中遇到空格则放入下一cells.
搞定！注意，我只写了一个空格间隔的，你自己修改一下splitstring可以用多个空格分隔！

procedure TForm1.Button1Click(Sender: TObject);
var
aa,bb:tstringlist;
i:integer;
begin
aa:=tstringlist.Create;
bb:=tstringlist.Create;
aa.LoadFromFile('c:.txt');
for i:=0 to aa.Count-1 do
begin
　 bb:=SplitString(aa.Strings[i],' ');
　 stringgrid1.Rows[i]:=bb;
end;
aa.Free;
bb.Free;
end;

其中splitstring为：

function SplitString(const source,ch:string):tstringlist;
var
temp:string;
i:integer;
begin
result:=tstringlist.Create;
temp:=source;
i:=pos(ch,source);
while i<>0 do
begin
　 result.Add(copy(temp,0,i-1));
　 delete(temp,1,i);
　 i:=pos(ch,temp);
end;
result.Add(temp);
end;

StringGrid组件Cells内容对齐

在StringGrid的DrawCell事件中添加类似的代码就可以了：

VAR
vCol, vRow : LongInt;
begin
vCol := ACol; vRow := ARow;
WITH Sender AS TStringGrid, Canvas DO
　 IF vCol = 2 THEN BEGIN ///对于第2列设置为右对齐
　　 SetTextAlign(Handle, TA_RIGHT);
　　 FillRect(Rect);
　　 TextRect(Rect, Rect.RIGHT-2, Rect.Top+2, Cells[vCol, vRow]);
　 END;
end;

当我将StringGird的options属性中包含goRowSelect项时每当我选中StringGrid中一行， 则选中行用深蓝色显示，我想将深蓝色改为其他颜色应怎样该？当我将StringGird的options属性中包含goRowSelect项时每当我选中 StringGrid中一行， 则选中行用深蓝色显示，我想将深蓝色改为其他颜色应怎样该？
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
With StringGrid1 do
begin
　 If　(ARow= Krow) and not (acol = 0) then
　 begin
　　　Canvas.Brush.Color :=clYellow;// ClBlue;
　　　Canvas.FillRect(Rect);
　　　Canvas.font.color:=ClBlack;
　　　Canvas.TextOut(rect.left , rect.top, cells[acol, arow]);
　 end;
end;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
begin
krow := Arow;　//*
kcol := Acol;
end;　

注意：必须把变量KROW的值初始为1或其他不为0的值，否则如果锁定第一行的话，第一行的颜色将被自设颜色取代，而锁定行不会被重画。

怎么改变StringGrid控件某一列的背景和某一列的只读属性,StringGrid控件标题栏的对齐.怎么改变StringGrid控件某一列的背景和某一列的只读属性,StringGrid控件标题栏的对齐.
请参考以下代码：
在OnDrawCell事件中处理背景色。程序如下：
//将第二列背景变为红色。
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
if not((acol=1) and (arow>=stringgrid1.fixedrows)) then exit;
with stringgrid1 do
begin
　 canvas.Brush.color:=clRed;
　 canvas.FillRect(Rect);
　 canvas.TextOut(rect.left+2,rect.top+2,cells[acol,arow])
end;
end;

//加入如下代码,那么StringGrid的第四列就只读了.其他列非只读
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
begin
with StringGrid1 do begin
　 if ACol = 4 then
　　 Options := Options - [goEditing]
　 else Options := Options + [goEditing];
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
var
dx,dy:byte;
begin
if (acol = 4) and not (arow = 0) then
　 with stringgrid1 do
　 begin
　　 canvas.Brush.color := clYellow;
　　 canvas.FillRect(Rect);
　　 canvas.font.color := clblue;
　　 dx:=2;//调整此值，控制字在网格中显示的水平位置
　　 dy:=2;//调整此值，控制字在网格中显示的垂直位置
　　 canvas.TextOut(rect.left+dx , rect.top+dy , cells[acol, arow]);
　 end;
//控制标题栏的对齐
if (arow = 0) then
　 with stringgrid1 do
　 begin
　　 canvas.Brush.color := clbtnface;
　　 canvas.FillRect(Rect);
　　 dx := 12; //调整此值，控制字在网格中显示的水平位置
　　 dy := 5; //调整此值，控制字在网格中显示的垂直位置
　　 canvas.TextOut(rect.left + dx, rect.top + dy, cells[acol, arow]);
　 end;
end;　

在stringGrid中使用回车键模拟TAB键切换单元格的功能实现......procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
label
nexttab;
begin
if key=#13 then
begin
　 key:=#0;
　 nexttab:
　 if (stringgrid1.Col　　 begin
　　　 stringgrid1.Col:=stringgrid1.Col+1;
　　 end
　 else
　 begin
　　 if stringgrid1.Row>=stringgrid1.RowCount-1 then
　　　 stringgrid1.RowCount:=stringgrid1.rowCount+1;
　　 stringgrid1.Row:=stringgrid1.Row+1;
　　 stringgrid1.Col:=0;
　　 goto nexttab;
　 end;
end;
end;
.........　

stringgrid如何清空
with StringGrid1 do for I := 0 to ColCount - 1 do Cols[I].Clear;

选中某单元格,然后在该单元格中修改-> 选中某单元格,然后在该单元格中修改设置属性:
　 StringGrid1.Options:=StringGrid1.Options+[goEditing];

让记录在StringGrid中分页显示在Uses中加入： ADOInt
//首先设定PageSize，取出PageCount
procedure TForm1.Button1Click(Sender: TObject);
begin
ADoquery1.Recordset.PageSize :=spinedit1.Value;
Edit1.Text := IntToStr(ADoquery1.Recordset.PageCount);
ShowData(spinedit2.Value);
end;

//然后将AbsolutePage的数据乾坤大挪移到StringGrid1中
procedure TForm1.ShowData(page:integer);
var
iRow, iCol, iCount : Integer;
rs : ADOInt.Recordset;
begin
ADoquery1.Recordset.AbsolutePage:=Page;
Currpage:=page;　
iRow := 0;
iCol := 1;
stringgrid1.Cells[iCol, iRow] := 'FixedCol1';
Inc(iCol);
stringgrid1.Cells[iCol, iRow] := 'FixedCol2';
Inc(iRow);
Dec(iCol);
rs := adoquery1.Recordset;
for iCount := 1 to SpinEdit1.Value do
begin
　 stringgrid1.Cells[iCol, iRow] := rs.Fields.Get_Item('FieldName1').Value;
　 Inc(iCol);
　 stringgrid1.Cells[iCol, iRow] := rs.Fields.Get_Item('FieldName1').Value;
　 Inc(iRow);
　 Dec(iCol);
　 rs.MoveNext;
end;
　
//上一页
procedure TForm1.Button2Click(Sender: TObject);
begin
If (CurrPage)<>1 then
　 ShowData(CurrPage-1);
end;

//下一页
procedure TForm1.Button3Click(Sender: TObject);
begin
If CurrPage<>ADoquery1.Recordset.PageCount then
　 ShowData(CurrPage+1);
end;

打印StringGrid的程序源码这段代码没有看懂，但是可能有的朋友需要，所以共享一下子 ：）
procedure TForm1.SpeedButton11Click(Sender: TObject);
Var
Index_R ,ALeft: Integer;
Index : Integer;
begin
StringGrid_File('D:\AAA.TXT');
if Not LinkTextFile then
begin
　 ShowMessage('失败');
　 Exit;
end;
//
QuickRep1.DataSet := ADOTable1;
Index_R := ReSize(StringGrid1.Width);
ALeft := 13;
Create_Title(TitleBand1,ALeft,24,HeaderControl1.Sections.Items[0].Width,20,
　　HeaderControl1.Sections[0].Text,taLeftJustify);
with Create_QRDBText(DetailBand1,ALeft,8,StringGrid1.ColWidths[0],20,
　　　　StringGrid1.Font,taLeftJustify) do
begin
　 DataSet := ADOTable1;
　 DataField := ADOTable1.Fields[0].DisplayName;
end;
ALeft := ALeft + StringGrid1.ColWidths[0] * Index_R + Index_R;
For Index := 1 to ADOTable1.FieldCount - 1 do
begin
　 Create_VLine(TitleBand1,ALeft - 13,16,1,40);
　 Create_Title(TitleBand1,ALeft,24,HeaderControl1.Sections.Items[Index].Width,20,
　　 HeaderControl1.Sections[Index].Text,taLeftJustify);
　 Create_VLine(DetailBand1,ALeft - 13,-1,1,31);
　 with Create_QRDBText(DetailBand1,ALeft ,8,StringGrid1.ColWidths[Index] * Index_R,20,
　　　　StringGrid1.Font,taLeftJustify) do
　 begin
　　 DataSet := ADOTable1;
　　 DataField := ADOTable1.Fields[Index].DisplayName;
　 end;
　 ALeft := ALeft + StringGrid1.ColWidths[Index] *　Index_R + Index_R;
end;
QuickRep1.Preview;
end;

function TForm1.ReSize(AGridWidth: Integer): Integer;
begin
Result := Trunc(718 / AGridWidth);
end;

function TForm1.StringGrid_File(AFileName: String): Boolean;
var
StrValue : String;
Index : Integer;
ACol , ARow : Integer;
AFileValue : System.TextFile;
begin
StrValue := '';
Try
　 AssignFile(AFileValue , AFileName);
　 ReWrite(AFileValue);
　 StrValue := HeaderControl1.Sections[0].Text;
　 For Index := 1 to HeaderControl1.Sections.Count - 1 do
　　 StrValue := StrValue + ',' + HeaderControl1.Sections[Index].Text;
　 Writeln(AFileValue,StrValue);
　 StrValue := '';
　 For　ARow := 0 To StringGrid1.RowCount - 1 do
　 begin
　　 StrValue := '';
　　 StrValue := StringGrid1.Cells[0,ARow];
　　 For ACol := 1 To StringGrid1.ColCount - 1 do
　　 begin
　　　 StrValue := StrValue + ', ' + StringGrid1.Cells[ACol,ARow];
　　 end;
　　 Writeln(AFileValue,StrValue);
　 end;
Finally
　 CloseFile(AFileValue);
end;
end;

function TForm1.LinkTextfile: Boolean;
begin
Result := False;
with ADOTable1 do
begin
　 {ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;' +
　　　　　　　　　　　 'Data Source= D:\;Extended Properties=Text;' +
　　　　　　　　　　　 'Persist Security Info=False';
　 TableName := 'AAA#TXT';
　 Open;　　　 }
　 if Active then
　　 Result := True;
end;
end;

function TForm1.Create_QRDBText(Sender: TWinControl; ALeft, ATop, AWidth,
AHight: Integer; AFont: TFont; AAlignMent: TAlignment): TQRDBText;
var
AQRDBText : TQRDBText;
begin
AQRDBText := TQRDBText.Create(Nil);
with AQRDBText do
begin
　 Parent := Sender;
　 Left := ALeft;
　 Top := ATop;
　 Width := AWidth;
　 Height := AHight;
　 AlignMent := AAlignMent;
　 Font.Assign(AFont);
end;
Result := AQRDBText;
end;

function TForm1.Create_VLine(Sender: TWinControl; ALeft, ATop, AWidth,
AHight: Integer): TQRShape;
var
AQRShapeV : TQRShape;
begin
AQRShapeV := TQRShape.Create(Nil);
with AQRShapeV do
begin
　 Parent := Sender;
　 Left := ALeft;
　 Top := ATop;
　 Width := AWidth;
　 Height := AHight;
end;
Result := AQRShapeV;
end;

procedure TForm1.Create_Title(Sender: TWinControl; ALeft, ATop, AWidth,
AHight: Integer; ACaption: String; AAlignMent: TAlignment);
var
AQRLabel : TQRLabel;
begin
AQRLabel := TQRLabel.Create(Nil);
with AQRLabel do
begin
　 Parent := Sender;
　 Left := ALeft;
　 Top := ATop;
　 Width := AWidth;
　 AlignMent := AAlignMent;
　 Caption := ACaption;
end;
end;
-----------------------------
2004年7月28日 16:00

TreeView由节点构成，建树通过对TreeView.items属性进行操作。Items是一个TTreeNodes对象，这是一个TTreeNode集。

一、针对TTreeNodes,也就是 TreeView.Items,有这些属性：
1、count，节点个数。
2、item[index] ,通过index得到节点。

二、针对TTreeNodes,也就是 TreeView.Items,常用的添加节点的操作有：
AddFirst添加第一个根节点。由此函数添加的节点总排在前面，除非后来又使用此函数添加了一个节点，则后添加的节点将排在前面。该函数返回新添加的节点。
AddChildFirst添加第一个子节点，要求有父节点作为其参数。返回新添加的节点。
AddChild添加一个子节点，要求有父节点作为其参数。返回新添加的节点。
Add添加一个兄弟节点，要求有兄弟节点作为其参数。返回新添加的节点。

三、针对TTreeNodes,也就是 TreeView.Items,常用的得到节点的操作有：
GetFirstNode() 得到根节点。
然后配合TTreeNode.GetNext(),就可以访问所有的节点。

四、建树举例：

var
root_node,cur_node:TTreeNode;
begin
root_node:=AddFirst(nil,'根节点1');
cur_node:=addChildfirst(root_node,nil,'根节点1_child1');
add(cur_node,'根节点1_child2');
root_node:=Add(nil,'根节点2');
AddChildFirst(root_node,''根节点2_child1');
end;

五、事件触发：
当从一个节点跳到另一个节点，会触发TTreeView.OnChange事件。该事件中，将传递node,即当前被选中的节点。

当修改一个节点的text时，会触发TTreeView.onEdit事件。

六、将节点和节点所对应的数据联系起来
对于每个TTreeNode,有个Data属性，可以存放一个指针。我们可以利用这个域来存放与节点对应的自己的数据。
1.我们先定义一个数据结构，作为记录我们要记录的数据。如：
type
PMyData=^TMyData;
TMyData=Record
sFName:string;
sLName:String;
nIndex:integer;
end;

2.然后，创建数时，将节点和节点数据联系起来：
procedure TForm1.Button1Click(Sender: TObject);
var
myshuju: PMyData
cur_node:TTreeNode;
begin
New(MyRecPtr); //记住，一定要先分配内存。有几个节点，就要分配几次内存。
myshuju^.FName:=Edit1.Text;
Myshuju^.LName := Edit2.Text;
TreeViewIndex := StrToInt(Edit3.Text);
with TreeView1 do
begin
cur_node:=items.AddFirst(nil,'first');
cur_node.data:=myshuju;
end;
end;

3.当我们选中一个节点时，就可以使用我们的数据了。
procedure TForm1.TreeView1Change(Sender:TObject;Node:TTreeNode);
begin
if node.data<>nil then
self.label1.caption:=pmyData(node.data)^.Fname+pmyData(node.data)^.Lname
end;

七、一般使用流程：
1、添加全局变量：
b_first:boolean; //记录是否是第一次访问节点，因为此时数据还未准备好，而一旦访问节点就会触发OnChange事件，在此事件处理函数中也许会出错。
2、在FormCreate中，
a、设置b_first:=true;
b. 创建数并将节点与数据联系。
3、在FormShow中
设置b_first:=false;
4.在事件OnChange中处理节点被选中事件。
5.在Edit中处理节点被修改Text事件。
并调用OnChange.
6.在 TreeView.Destory中
释放Data 中指向的内存空间。

二、Self和Sender的区别：

　　在事件处理程序参数表中，至少含有一个参数Sender,它代表触发事件处理程序的构件，如在上例中，Sender就指Button2，有了Sender参数，可以使多个构件共用相同的事件处理程序，如下例：
　　Procedure Tform1.Buttonclick(Sender:Tobject);
　　Begin
　　If sender=button1 then
　            　Label1.caption:='看庭前花开花落 '
　　Else Label2.caption:='望天上云卷云舒'
　　End；
　　在此例中，Button1,Button2共用了Buttonclick事件处理程序。
　　Self是指所编的程序范围是在哪一个类中，Delphi中 大都在窗体范围内编程，因此，self即指窗体，如果在编写一个类或是一个组件，则self指该类或组件。我们在函数或过程的声明中可看出self是代表 哪个组件，即self代表‘.’号之前的组件，如在第一个例子中，self代表Tform1。另外应注意，self只能用在类方法中，而不能用在过程或函 数中，如下例用法是错的:
Function a1(B:Integer):Integer;
　　Begin
　　……
　　Button:=tbutton.create(self)；……
　　End；　　

三、Clientheight和Height,Clientwidth和Width的区别：

对于一般的构件而言，Height就是Clientheight,Width就是Clientwidth，而对于窗体而言，Height是包括标题条在 内的高度，而Clientheight是指窗体工作区的高度。同理，Clientwidth是指定窗体工作区的宽度。
　　从上面陈述可知，理解Ower和Parent,Self和Sender，Clientheight和Height,Clientwidth和Width区别，对于Delphi中正确编程是重要的。

ChuckJ's Blog Please read my disclaimer. It is better to be silent and thought a fool, than to speak and remove all doubt." -- Silvan Engel

...Removing All Doubt

Chuck Jazdzewski

　　首先解释一下这个题目。在我使用Delphi 7的过程中发现，一个对象的事件只能被一个过程处理。如果多次给这个对象的事件赋给处理事件的过程，最后真正处理事件的将是最后赋值的那个过程。例如，有 类TMyClass中定义了一个事件OnSomeFired，在类TClientClass中该类被实例化，它的事件被处理。如下所示：
constructor TClientClass.Create;
var
  myObj: TMyClass;
begin
  //…
  myObj:= TMyClass.Create;
  myObj.OnSomeFired:= SomeFired1;
  myObj.OnSomeFired:= SomeFired2;
　　这里的SomeFired1与SomeFired2都是TClientClass中定义的处理过程。其最终的结果是当OnSomeFired事件发生时，只有SomeFired2被调用。
　　但在编程的实际中，往往需要一个事件被多个方法所处理。为此，我参考了一些对这个问题的解决办法，总结得出了一个自己的方法，称为事件的多处理机制。

原理
　　Delphi 7中的事件本质上是一种过程指针。但事件类型在定义时要比一般过程指针在最后多一个“of object”，如常用的TNotifyEvent的定义是：
TNotifyEvent = procedure(Sender: TObject) of object;
因此，给一个事件属性赋值，也就是给一个类的过程指针类型的成员变量赋值，当然是最后一次的赋值才有效。要想多次赋值有效就必须有一个数据结构把每次赋 值赋给的过程指针变量都记录下来，最合适的数据结构当然是列表TList。但如果在每一个有事件的类中都加一个记录事件赋值的列表对象，自然是不方便的， 而且使用这个列表的代码在不同类中也差不多，应该抽取出来形成一个类。这个类就是事件多处理机制的核心内容。

做法
　　要记录事件处理过程，就需要将过程指 针变量放入列表对象中。但列表对象只能添加指针类型对象（也就是引用类型），而过程指针变量是指类型变量，不能直接添加。这就需要有一个类对过程指针变量 进行包装，转化为指针类型对象。于是，先要定义包装类TCallMethod，如下所示：
TCallMethod = class
  private
    _callback: TMethod;
  public
    property Callback: TMethod read _callback write _callback;
  end;
　　这里的TMethod是Delphi预定义的记录类型，任何过程指针变量都可以强制转化为这种类型。之后，再定义记录处理过程的类，如下所示：
  TEventObject = class
  private
    callList: TList;
    function GetItem(i: Integer): TMethod;
    function GetCount: Integer;
  public
    constructor Create;

    procedure Add(p: TMethod);
    procedure Remove(p: TMethod);

    property Count: Integer read GetCount;
    property Items[i: Integer]: TMethod read GetItem;  default;
  end;
　　下面是实现部分：
constructor TEventObject.Create;
begin
  callList:= TList.Create;
end;

procedure TEventObject.Add(p: TMethod);
var
  a: TCallMethod;
begin
  a:= TCallMethod.Create;
  a.Callback:= p;
  callList.Add(a);
end;

procedure TEventObject.Remove(p: TMethod);
var
  i: Integer;
begin
  for i:= 0 to GetCount - 1 do
    if (TCallMethod(callList[i]).Callback.Code = p.Code) and
      (TCallMethod(callList[i]).Callback.Data = p.Data) then
      callList.Delete(i);
end;

function TEventObject.GetCount: Integer;
begin
  Result:= callList.Count;
end;

function TEventObject.GetItem(i: Integer): TMethod;
var
  a: TCallMethod;
begin
  a:= TCallMethod(callList[i]);
  Result:= a.Callback;
end;
　　从上面的代码可以看到，TEventObject的目的是包装TList对象，屏蔽了TList类的大多数方法，只对外暴露了2个过程、1个属性与1个索引，分别用于添加、删除处理事件过程、获得过程个数及通过序号检索记录的过程变量。

使用
　　使用时，在需要使用事件的类中将事件的类型由过程指针改为TEventObject，即可使该事件拥有多处理的能力。如下面代码所示：
  TMyClass=class
  private
    someFired: TEventObject;
  public
    constructor Create;
    procedure DoSth;
    property OnSomeFired: TEventObject read someFired write someFired; // 多处理事件
  end;
　　以下是实现代码：
constructor TMyClass.Create;
begin
  Self.someFired:= TEventObject.Create;
end;

procedure TMyClass.DoSth;
var
  i: Integer;
  method: TNotifyEvent;
begin
  if someFired.Count > 0 then
    for i:= 0  to someFired.Count - 1 do
    begin
      method:= TNotifyEvent(someFired[i]); // 在该类中事件的真正类型是TNotifyEvent，因此在触发事件时先要转成这种类型的过程指针后再进行调用
      method(Self);
    end;
end;
　　定义了一个包含多处理事件的类后，再看看这种类如果在其客户类中被调用。如以下代码：
{类TClientClass中}
var
  myObj: TMyClass;
  //…
  myObj:= TMyClass.Create;
  myObj.OnSomeFired.Add(SomeFired1);
  myObj.OnSomeFired.Add(SomeFired2);
　　当客户类代码中调用TMyClass的DoSth方法时，事件将被触发，而2个处理过程SomeFired1与SomeFired2则会依次调用，实现多处理的目的。

再发展一步
　　上面的TEventObject 类可以实现事件多处理的目的，但它对加入其中的过程指针类型没有检查，这是一个隐患。因此可以针对每一种事件要求的过程指针类型从 TEventObject继承一个类，实现类型检查。如要求事件的类型是TNotifyEvent，就可以继承一个TNotifyEventObject 类，如下面代码：
  TNotifyEventObject = class(TEventObject)
  public
    procedure Add(p: TNotifyEvent); overload;
    procedure Remove(p: TNotifyEvent); overload;
  end;
　　以下是实现部分：
procedure TNotifyEventObject.Add(p: TNotifyEvent);
begin
  inherited Add(TMethod(p));
end;

procedure TNotifyEventObject.Remove(p: TNotifyEvent);
begin
  inherited Remove(TMethod(p));
end;
　　在这个类中重载了添加与移除方法，可以有效地对过程指针类型进行检查。

Action高级开发

Action开发篇

    在讨论Action的开发前，我想先讨论一下为什么要使用TActionList及TAction。从Delphi 4开始Borland提供了TActionList控件，ActionList提供了一种全新的设计用户界面交互模式的方法。传统的事件模式无法解决命令 状态更新的问题，因为任何情况下命令都是有效的。Delphi 4通过使用ActionList及Action提供了新的方法来处理命令的实现，即命令的有效性问题。ActionList是一个非可视的控件里面包含了 一组TAction对象。两者的关系有点像菜单项同菜单的关系。

    一个TAction对象提供一个命令，比如删除一个目标的选项（例如删除列表框的一个列表项），当Action控制的控件相应某些用户的输入会激发相应的 Action命令，通常是鼠标键盘点击等动作。Action通常用来控制按钮和菜单项这类控件，通过设定这类控件的Action属性可以把两者关联起来。

    图3.18显示了一个关联Action和控件的例子，EditCut1 Action被指定给SpeedButton1的Action属性。当关联完成后，Speedbutton的属性会根据对应的EditCut1的属性作出 相应的变化，比如按钮的Caption会自动变成“Cu&t.”，当用户点击Cut按钮时，由EditCut1 Action实现的相应命令就会被调用。当Memo1中有文本被选中的时候，Cut按钮才是有效的，这是因为Delphi内置的EditCut Action实现了Action的OnUpdate事件，在那里对相关联的Memo1进行了判断，只有当Memo1中有文本被选择了，Action对应剪 切操作才有效。

    参看前面在OTA部分实现的Winamp专家中，大量使用TAction对系统进行了管理，可以发现只需要在Action的OnUpdate事件中写很少 的代码甚至不写代码（对系统内置的Action而言），就可以对一些基本界面操作的有效性进行判断，同时使用ActionList容器类使得命令更容易维 护。另外，除了以上功能，还可以利用Action的OnHint事件对关联控件的飞跃提示的显示进行控制。

    虽然Action的使用是非常方便的，但如果想得到最佳的性能和表现，我们还是需要更深入地了解Action的工作原理。比如注意到 TActionList和TAction都定义了OnExecute和OnUpdate事件。两者有什么区别呢？在Borland的文档中并没有很清楚的 说明，所以还是需要研究一下Action工作的内部机制。

    当在程序中使用了ActionList和Action后，Delphi 中的Application对象会在系统空闲的时候产生OnUpdate事件。对于每一个ActionList， TActionList.OnUpdate事件会最先生成，然后系统传递给事件两个参数。Action参数代表正在更新状态的Action， Handled参数用来控制相应的Action的OnUpdate事件是否被调用。如果不想相应的Action的Update事件被调用，需要设定 Handled参数为真。

    TActionList.OnUpdate事件对每一个列表中的Action相关联的每一个控件都要产生一遍。换句话，假设ActionList1包含 Action1和Action2。现在假定Button1和SpeedButton1的 Action 属性设定为Action1，同时SpeedButton2的Action属性设定为Action2。在这种情况下，每个循环下来， ActionList1.OnUpdate事件将会产生1+2＝3次。

    什么时候用Action.OnUpdate事件，什么时候用ActionList.OnUpdate事件没有什么绝对的准则。但一般来说， TActionList.OnUpdate事件更容易控制，因为把全部的状态控制代码写在一个地方更清楚，而且写起来更简洁，当然这只是我的看法。

    另外，大家可能会注意到可以在一个窗体上放多个ActionList。比如Delphi带的RichEdit的演示程序中就使用了两个 ActionList，为什么使用两个ActionList呢?其实这是出于运行效率的考虑，因为按照ActionList更新状态的方式，如果你有一组 Action并不需要进行有效性校验。这时就应该把它们放到单独的ActionLis中去，这样就不需要生成OnUpdate事件了。这是因为不管 Action是否生成了OnUpdate事件，只要ActionList中有一个Action定义了OnUpdate事件，其他Action的 OnUpdate都会被调用。

    同时由于OnUpdate事件会产生很多次，所以不要在OnUpdate事件处理函数中写耗时很长的代码，这样会严重影响应用程序的运行效率。

    同OnUpdate事件相反，我推荐为每一个Action对象生成一个OnExecute的事件，而不是全部写到 TActionList.OnExecute事件中去，它不同于OnUpdate事件之处在于只有当相应操作需要执行时，事件才会被调用，而 OnUpdate事件是只要系统空闲就会被调用。

    在Delphi的在线帮助中，关于Action执行过程中事件产生的顺序有点模糊不清。图3.19显示了一个更加清晰的顺序图。注意Action的 OnExecute事件发生在ActionList和Application 对象获得一个机会去处理Action之后。

    除了OnUpdate和OnExecute事件外，TActionList还定义了OnChange事件，这是一个非常奇怪的事件，只有当Action的 Category属性改变的时候或者是当ActionList的Images属性改变的时候才会被调用，我不清楚有什么必要生成这么样一个事件，因为 Category只是在设计时才有效，Images也极少在运行时改变，所以我觉得这个事件定义的好像没有必要。相比之下，OnHint事件更有用些，生 成一个OnHint事件处理过程使我们可以比较容易定制要显示的飞跃提示。OnHint事件有两个参数：第一个是HintStr，用它来返回要显示的提示 字符串；第二个参数CanShow用来确定是否显示提示。这个事件处理有点问题，在无焦点的控件如SpeedButton定义的OnHint事件中， CanShow参数只在Action的Hint属性设置为空字符串的情况下才有效，如果Hint属性指定了一个字符串，那么不管CanShow如何设置， 控件只会显示缺省的Hint字符串。

    Action还具有给菜单项或SpeedButton添加图标的功能。但要注意仅仅设定TActiongList.Images属性是不够的，还需要同时 设定Menu的Images属性为相同的图像列表。另外假设我们要修改同Action关联的图像，仅仅修改对应的图像列表是不够的，不像Action的其 他属性（如：Caption或ShortCut），只要修改了，就会通知相应控件作出改变。我们必须先清除对应控件的Action属性，在重置 Action属性达到刷新控件的Glyph属性的目的。

    如果不想让Action的图像出现在对应的SpeedButton上时，我们必须在运行时（如在窗体的OnCreate事件中）清除SpeedButton的Glyph属性，在设计时清空Glyph属性是无效的。

    下一节将探讨如何重用现有Action源代码来实现新的Action类。

设计新武器 ——Action的开发

    这节将探讨如何编写新的Action。

    首先，必须清楚Action是控件，我们可以像写其它VCL控件一样，编写并能注册它。

    其次，编写新的Action是有一定前提条件的，要编写的Action必须是对应于比较普遍的操作，可重用性要强，比如从一个列表框中删除列表项的操作以 及上下移动列表项都是在界面交互时会经常碰到的需求。当然通过在普通的TAction的OnExecute和OnUpdate事件中也可以实现这类操作， 但如果能通过编写对应于这样操作的Action，就可以省去重复编写OnUpdate和OnExecute事件处理过程的工作。

    另外要弄清，要编写的Action不同于一般意义上的Action的，我们定制的Action是用户可以不需要写OnExecute事件处理过程的，它提 供了一个内置的缺省功能，就好像TEditCutAction一样，只要把它同编辑框相关联，无需写一行代码它就可以正确处理剪切操作了。同样对于 OnUpdate事件，用户定制的Action也提供了内置的命令有效性校验机制，用户可以无需修改直接使用。但最重要的区别恐怕是用户定制的 Action可以用于很多不同的控件并能在不同程序中重用。

1. 预定义的Action

    在开始编写定制的Action前，先来看看Delphi已经实现了的定制的Action。图3.20中列出了Delphi自带的标准Action， Edit Action处理剪贴板操作，Window Action处理多文档界面（MDI）的子窗体的管理操作，DataSet Action则处理数据库导航命令。

    预定义的Action提供了很强大的功能。比如假定把一个SpeedButton的Action属性同一个TEditCut Action相关联，当任何编辑框中的文本被选择后，SpeedButton就处于有效状态，这时点击SpeedButton，被选的文本将被删除并复制 到剪贴板上。所有这些功能不需要写任何代码。

    虽然预定义的Action功能很强大，但还是有一些应用上的限制。为了这些限制存在的原因，我们需要了解定制的Action是如何定位操作目标控件的。比 如当一个TEditCut Action 被激发的时候，它是如何知道操作是在Memo1上而不是在Edit2上的，也就是如何区分需要剪切的控件的？

2. 定位目标

    回忆一下前面讲过的，当一个Action被激发时，有4种可能的响应会发生：第一，Action List在它的OnExecute事件中处理Action；第二，Application对象会处理Action；第三，Action调用本身的 OnExecute事件处理过程；如果这时Action还没有被处理，一个cm_ActionExecute 消息被发送到Application对象。

    当Application对象接收到这个消息，它首先把消息发到Screen对象管理的当前激活的窗体，如果当前没有活动的窗体，消息就发给应用程序的主窗体。

    消息由TCustomForm.CM-ActionExecute 消息处理过程进行处理。首先，处理过程检查窗体的ActiveControl属性。如果不为nil，当前活动控件的ExecuteAction方法就会被 调用，如果ActiveControl属性为nil，窗体的ExecuteAction方法会被调用(见图3.21)。

    ExecuteAction是一个布尔函数，定义在TComponent类中。如果控件对Action做出了响应，ExecuteAction 函数就返回真值。ExecuteAction函数会调用Action的HandlesTarget方法，并把它的引用参考传给控件。 HandlesTarget方法决定控件是否是Action的一个有效的操作对象。比如TEditAction对象HandlesTarget只有当目标 控件是从TCustomEdit继承下来的时候才返回真值。

    如果控件是一个有效的操作对象，Action的ExecuteTarget方法将被调用，同HandlesTarget类似，它接收一个目标控件的引用参 考作为一个参数，ExecuteTarget方法对目标控件执行相应的Action。图3.21举例说明了这一处理流程。

    如果ActiveControl和窗体都不是一个有效的操作目标，这种情况下，窗体的CM-ActionExecute方法会遍历窗体上的全部控件并对每一个控件都调用ExecuteAction方法直到一个有效的目标控件被找到或是找不到满足要求的控件为止。

3. 定制Action的局限性

    理解了定制的Action如何定位它的目标控件，就可以讨论它们的局限性了。第一个局限来自于对ActiveControl的依赖性。因为当激发 Action的控件改变了输入焦点的时候，定制的Action可能无法正常工作，这对于SpeedButton和菜单项是没有影响的，因为它们没有输入焦 点，不会改变ActiveControl。然而普通的按钮却会改变输入焦点。

    假定Button1的Action属性设定为EditCut1。同时假定Edit1当前获得了焦点，并且其中的文本被选择了。当用户点击了 Button1，发生的第一件事是输入焦点切换到了按钮上。这时， EditCut1.OnUpdate事件被自动调用。因为现在Button1成了ActiveControl，而它并不是TCustomEdit的子类， EditCut1.Enabled的属性将设为False。结果Action变成无效的了， Button1也同样失效了。当用户松开鼠标后，由于Button1无效了，结果OnClick事件就无法调用了，也就无法激发EditCut1的操作 了。

    这里还有一些其他限制，特别当这些编辑操作只能工作在TCustomEdit子类上时，它无法支持很多支持剪贴板操作的其他控件。比如，Edit Action不能工作在csDropDown样式的组合列表框，而且在设计时，无法控制Edit Action只对某个编辑框起作用。它只对所有的控件起作用（不过在运行时倒是可以通过TeditAction的Control属性进行控制）。

    指出这些限制并不会影响这些Action的重要性，这只是为了理解整个Action的工作流程。

4. 创建用户定制的Action

    创建Action同创建VCL控件非常类似，其实这并不奇怪，因为Action实际上就是控件的一种。编写控件的规则同样适用于Action。不过编写Action之前，先看一下Action类的继承关系。

    图3.22是非数据库Action的继承关系。编写新的Action，通常是从TAction开始的，但也应该了解一下全部的4个Action基类之间的 关系： TBasicAction、TContainedAction、TcustomAction和TAction。

    TBasicAction是最低层的类，如果想要创建一个同非菜单或控件相关的Action，可以由它开始继承。

    TContainedAction是直接从TbasicAction继承的类，增加了分类的功能，支持TActionList中的分类(Category)。

    TCustomAction直接从TContainedAction继承下来，增加了针对菜单项和控件的功能， TcustomAction没有公开它的属性，仅仅是实现了它们。

    TAction仅仅是公开了TcustomAction实现了的属性。它没有引进新的功能，除非需要使特定的属性隐藏，通常Action都是从TAction继承的。

l                      

图3.22

5. 定制Action

    现在就可以开始编写Action了，创建一个定制的Action包括以下几个步骤：

    (1) 需要创建一个新单元，在单元中要从一个基类（比如TAction）继承我们的Action。

    (2) 然后，需要重载一些关键的方法像HandlesTarget、UpdateTarget和ExecuteTarget方法。

    (3) 最后注册新的Action把它安装到Delphi中去。

    在线帮助建议使用StdActns单元作为创建定制的Action的一个指导。但是如果按照StdActns单元来写的话，生成的Action同 Delphi预定义的Action工作的方式无法完全一样。比如，用Action List Editor创建一个TEditPaste Action，然后选择这个Action，对象编辑器显示的Caption已经初始化为“&Paste”，提示初始化为“Paste”、 ImageIndex为2以及ShortCut为Ctrl+V。而生成的Action却无法做到对缺省属性值的初始化。

    如果创建一个基于StdActns单元中代码的Action，唯一能够初始化的属性是Caption，而且这个Caption被初始化为同Name一样的 无意义的值，像“MyAction1”这样无聊的名字。造成这种情况的根本原因将在后面的Action的安装部分讲到，这里通过提供一个 Constructor来初始化缺省的属性值。

    另外，StdActns单元比较糟糕的地方是在这些单元中并没有如何注册和安装Action的内容。Action虽然是一种控件，但它的注册同普通控件是不同的。更离谱的是在线帮助中关于如何注册Action是错误的。

6. 列表框Action

    虽然StdActns单元不是一个很好的指导文件，但只能从它开始研究。下面将创建一组Action用来提供对列表框的操作。后面的程序清单1显示了实现这组Action的源代码。

    类似标准的Edit Action，从一个TListBoxAction基类开始处理目标控件的确定过程。这个类重载了HandlesTarget和UpdateTarget 方法。如果目标控件是TCustomListBox的子类，HandlesTarget方法将返回真值，如果列表框不是空的，有列表项存在， UpdateTarget方法设定Action的Enabled属性为真。相应代码如下：

    function TListBoxAction.HandlesTarget( Target: TObject ): Boolean;

    begin

      //当Target为TCustomListbox的子类时，相应的命令才有效

      Result := ( ( Control <> nil ) and ( Target = Control ) or

              ( Control = nil ) and ( Target is TCustomListBox ) ) and

              TCustomListBox( Target ).Focused;

    end;

    procedure TListBoxAction.UpdateTarget( Target: TObject );

    begin

      //当相应的列表框不为空，包含列表项时，命令才有效

      Enabled := GetControl( Target ).Items.Count > 0;

    end;

    TlistBoxAction剩下的部分用来支持Control属性。 TeditAction同样实现了一个Control 属性，可以使Action只对某一控件起作用，不过它的缺点是它声明为public属性，这样只能在运行时才能对它进行设置。这里声明Control为 published属性，这样在设计时就可以方便地进行设置了。不设定Control属性的话，Action将作用于窗体上全部的列表框。

    所有的派生类在结构上都比较类似，他们从同一个基类继承并且都重载了Constructor来初始化自身属性，还都重载了ExecuteTarget方法 来实现内置的执行功能。下面是TListBoxDelete的ExecuteTarget方法的实现，用来删除当前被选的列表项：

    procedure TListBoxDelete.ExecuteTarget(Target: TObject);

    var

      Idx: Integer;

    begin

      Idx := GetControl( Target ).ItemIndex;

      if Idx <> -1 then

        GetControl( Target ).Items.Delete( Idx );

    end;

    一部分子类还重载了UpdateTarget方法，因为确定命令是否有效的规则对不同操作是不同的，同在TListBoxAction中实现的有可能不 同。例如，TListBoxMoveUp.UpdateTarget方法 判断Enabled属性是否为真是以被选的列表项是否是列表中的第一项为依据的，如果为第一项则上移的操作是无效的。代码示意如下：

    procedure TListBoxMoveUp.UpdateTarget( Target: TObject );

    begin

      Enabled := GetControl( Target ).ItemIndex > 0;

    end;

7. 注册和安装Action

    完成Action的定义和编码后，需要注册安装Action到Delphi。这里使用一个单独的单元来进行注册。清单2列出了注册单元代码。

    同一般控件不同，注册Action我们需要使用RegisterActions过程，而不是RegisterComponents过程。 RegisterActions过程需要三个参数：第一个是一个描述Action分类的字符串，由于Action是专门针对列表框的，所以设定这个参数为 “ListBox.”；第二个参数是一组要注册的Action的类；最后一个参数称为Resource参数，这个参数在在线帮助里没有提到，它的类型是 TComponentClass，稍后会详细研究这个参数的具体用意，这里先不管它，把它直接设成TlistBox就可以。

    因为Action实际上是一种控件，要安装的话，必须把实现的单元放到包中然后进行注册。一旦安装到了Delphi里，新定制的Action就会出现在标准Action对话框中，如图3.23所示。

    最后还剩下一点问题那就是因为TCustomAction.DoHint（提示事件分发方法）在Delphi 4中声明为静态方法，而在Delphi 5声明为动态方法。这样在Delphi 5中就可以对提示处理进行重载，提供一个用户定制的提示处理，而在Delphi 4这是办不到的。本文的例子没有实现提示的定制部分，这个问题留给读者去实现。

    程序清单1 – ListActn.pas如下：

    unit ListActn;

    interface

    uses

      Classes, ActnList, StdCtrls;

    type

      TListBoxAction = class( TAction )

      private

        FControl: TCustomListBox;

        procedure SetControl( Value: TCustomListBox );

      protected

        function GetControl( Target: TObject ): TCustomListBox; virtual;

        procedure Notification( AComponent: TComponent; Operation: TOperation ); override;

      public

        function HandlesTarget( Target: TObject ): Boolean; override;

        procedure UpdateTarget( Target: TObject ); override;

      published

        property Control: TCustomListBox

          read FControl

          write SetControl;

      end;

      TListBoxDelete = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure UpdateTarget( Target: TObject ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

      TListBoxClear = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

      TListBoxMoveUp = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure UpdateTarget( Target: TObject ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

      TListBoxMoveDown = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure UpdateTarget( Target: TObject ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

      TListBoxSelectAll = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

      TListBoxUnselectAll = class( TListBoxAction )

      public

        constructor Create( AOwner: TComponent ); override;

        procedure ExecuteTarget( Target: TObject ); override;

      end;

    implementation

    uses

      Windows, Messages;

      {== TListBoxAction Methods ==}

    function TListBoxAction.GetControl( Target: TObject ): TCustomListBox;

    begin

      Result := Target as TCustomListBox;

    end;

    function TListBoxAction.HandlesTarget( Target: TObject ): Boolean;

    begin

      Result := ( ( Control <> nil ) and ( Target = Control ) or

        ( Control = nil ) and ( Target is TCustomListBox ) ) and

        TCustomListBox( Target ).Focused;

    end;

    procedure TListBoxAction.Notification( AComponent: TComponent; Operation: TOperation );

    begin

      inherited Notification( AComponent, Operation );

      if ( Operation = opRemove ) and ( AComponent = Control ) then

        Control := nil;

    end;

    procedure TListBoxAction.UpdateTarget( Target: TObject );

    begin

      Enabled := GetControl( Target ).Items.Count > 0;

    end;

    procedure TListBoxAction.SetControl( Value: TCustomListBox );

    begin

      if Value <> FControl then

      begin

        FControl := Value;

        if Value <> nil then

          Value.FreeNotification( Self );

      end;

    end;

    {== TListBoxDelete Methods ==}

    constructor TListBoxDelete.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Delete';

      ImageIndex := 1;

      Hint := 'Delete Item';

    end;

    procedure TListBoxDelete.ExecuteTarget(Target: TObject);

    var

      Idx: Integer;

    begin

      Idx := GetControl( Target ).ItemIndex;

      if Idx <> -1 then

        GetControl( Target ).Items.Delete( Idx );

    end;

    procedure TListBoxDelete.UpdateTarget( Target: TObject );

    begin

      Enabled := ( GetControl( Target ).Items.Count > 0 ) and

                 ( GetControl( Target ).ItemIndex <> -1 );

    end;

    {== TListBoxClear Methods ==}

    constructor TListBoxClear.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Clear';

      ImageIndex := 2;

      Hint := 'Clear List';

    end;

    procedure TListBoxClear.ExecuteTarget( Target: TObject );

    begin

      GetControl( Target ).Clear;

    end;

    {== TListBoxMoveUp Methods ==}

    constructor TListBoxMoveUp.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Move Up';

      ImageIndex := 3;

      Hint := 'Move Item Up';

    end;

    procedure TListBoxMoveUp.ExecuteTarget( Target: TObject );

    var

      Idx: Integer;

    begin

      Idx := GetControl( Target ).ItemIndex;

      GetControl( Target ).Items.Exchange( Idx, Idx - 1 );

      GetControl( Target ).ItemIndex := Idx - 1;

    end;

    procedure TListBoxMoveUp.UpdateTarget( Target: TObject );

    begin

      Enabled := GetControl( Target ).ItemIndex > 0;

    end;

    {== TListBoxMoveDown Methods ==}

    constructor TListBoxMoveDown.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Move Down';

      ImageIndex := 4;

      Hint := 'Move Item Down';

    end;

    procedure TListBoxMoveDown.ExecuteTarget( Target: TObject );

    var

      Idx: Integer;

    begin

      Idx := GetControl( Target ).ItemIndex;

      GetControl( Target ).Items.Exchange( Idx, Idx + 1 );

      GetControl( Target ).ItemIndex := Idx + 1;

    end;

    procedure TListBoxMoveDown.UpdateTarget( Target: TObject );

    var

      L: TCustomListBox;

    begin

      L := GetControl( Target );

      Enabled := ( L.ItemIndex <> -1 ) and

             ( L.ItemIndex < L.Items.Count - 1 );

    end;

    {== TListBoxSelectAll Methods ==}

    constructor TListBoxSelectAll.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Select All';

      ImageIndex := 5;

      Hint := 'Select All Items';

    end;

    procedure TListBoxSelectAll.ExecuteTarget( Target: TObject );

    begin

      SendMessage( GetControl( Target ).Handle, LB_SETSEL, 1, -1 );

    end;

    {== TListBoxUnselectAll Methods ==}

    constructor TListBoxUnselectAll.Create( AOwner: TComponent );

    begin

      inherited Create( AOwner );

      Caption := 'Unselect All';

      ImageIndex := 6;

      Hint := 'Unselect All Items';

    end;

    procedure TListBoxUnselectAll.ExecuteTarget( Target: TObject );

    begin

      SendMessage( GetControl( Target ).Handle, LB_SETSEL, 0, -1 );

    end;

    end.

    程序清单2 - ListActnReg.pas如下：

    unit listActnReg;

    interface

    procedure Register;

    implementation

    uses

      Classes, ActnList, StdCtrls,ListActn;

    procedure Register;

    begin

      RegisterActions( 'ListBox', [ TListBoxDelete, TListBoxClear, TListBoxMoveUp, TListBoxMoveDown,

                   TListBoxSelectAll, TListBoxUnselectAll ], TListBox );

    end;

    end.

    Resource 参数：

    上面留了一个问题，就是Resource参数到底是干什么用的？现在是该揭开谜底的时候了。

    其实Resource参数可以为我们的Action属性初始化，并且可以在Action中嵌入指定的图像。实际上就是起到了Constructor过程的作用，它还能给Action添加缺省图标。下面就是使用Resource参数的步骤：

    （1）给原来的安装包添加一个资源窗体。

    （2）重新编译和安装Action。

    第一步，添加一个新的窗体，把它命名为TListBoxRes。然后添加一个图像列表控件，一个ActionList并添加我们先前创建的Action。 最后，向ImageList中添加图标，并设定Action的各项缺省属性，包括图标、Capition等等，最后把它保存为ListRes.Pas。

    第二步，因为要使用Resource参数来重新注册，这回系统会根据资源窗体的内容设定Action的缺省属性。这时就不再需要Action中的 Constructor过程了（这回终于明白为什么Borland的StdActns单元中实现的Action都没有constructor过程），把这 些过程去掉。并把先前RegisterAction中Resource参数的Tlistbox改成TlistBoxRes，然后把TlistBoxRes 对应的单元添加到注册单元的Uses列表中，下面是修改后的注册部分代码：

    uses

      Classes, ActnList, StdCtrls,ListActn,ListRes;

      ……………………………………………

    procedure Register;

    begin

      RegisterActions( 'ListBox', [ TListBoxDelete, TListBoxClear, TListBoxMoveUp, TListBoxMoveDown, TListBoxSelectAll, TListBoxUnselectAll ], TListBoxRes );

    end;

    最后重新编译包。如果安装成功的话，让我们来测试一下。新建一个窗体，添加一个ActionList，再放上一个TimageList控件，指定 ActionList的Images属性为Imagelist1。然后添加Listbox Action，如图3.24所示，你会发现Action的右边都有一个漂亮的图标，并且在没有Contructor的情况下，Action的属性都设定了 正确的缺省属性值。除此之外，即使ImageList中已经有了图像，Delphi也会自动复制Action资源中的图标到Imagelist，并能很智 能地调节Action的ImageIndex。到此为止，我们才算真的大功告成了。