自定义控件

Question

制作构件并不是三言两语就能说清楚的，下面用一个简单的实例来说明。这个新控件从TLabel派生而来，是一个增强型的TLabel控件，当用户单击这个控件时，就会执行一个特殊的操作。该控件增加了一个属性URLString，其值表示要执行的操作。例如，当该属性值为“http://seawave.yeah.net”这个字符串时，如果用户单击该字符串，则会调用系统默认的浏览器来访问我的个人主页。 首先，为这个构件取一个名字，这里我用SWURLLabel（个人喜好，SW表示SeaWave）。 
由于这个控件本质上是一个TLabel，所以它从TLabel类派生而来，继承所有TLabel的属性、方法和事件句柄。 该构件准备放在Delphi的一个新面板上，名为“SeaWave”，因此在Register过程中指明了SeaWave字符串型的参数。 
要为新控件增加一个字符串型的属性，名为URL，其值表示要执行的操作。 
为新控件增加一个事件句柄OnBeforeExecuteURL，指向当执行URL之前要调用的过程。 
　　下面是SWURLLabel.PAS源程序清单。unit SWURLLabel;interfaceuses
  Windows, Classes, Controls, StdCtrls, SysUtils, Forms,
  Graphics, ShellAPI;type
  TSWURLLabel = class(TLabel) // 从TLabel类派生
  private
    FOnBeforeExecuteURL: TNotifyEvent; // 指向执行URL之前要调用的过程    FURL: String;                      // URL字符串
    procedure SetURL(Value:String);
  protected
    procedure Click; override;         // 重载TLabel的Click方法
  public
    constructor Create(AOwner:TComponent); override; // 构造函数
    function ExecuteURL: Boolean; // 方法，执行URL
  published
    property OnBeforeExecuteURL: TNotifyEvent
      read FOnBeforeExecuteURL
      write FOnBeforeExecuteURL default nil;
    property OnExecuteURL: TNotifyEvent
      read FOnExecuteURL
      write FOnExecuteURL default nil;    property URL:String read FURL write SetURL;
  end;procedure Register;implementationconst DefaultURL:String = 'http://seawave.yeah.net';{ 重载TLabel的Click方法 }
procedure TSWURLLabel.Click;
begin
  inherited Click; // 执行TLabel的Click过程
  ExecuteURL;      // 调用ExecuteURL过程来执行URL
end;{ 构造函数，初始化属性 }
constructor TSWURLLabel.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);  // 首先调用父类的构造函数
  FURL := DefaultURL;        // URL属性值初始化为默认值
  Caption := DefaultURL;     // Caption
  Font.Color := clBlue;      // 颜色默认为蓝色  Font.Style := [fsUnderline]; // 字体默认为带下划线
  Cursor := crHandPoint;     // 光标形状默认为手掌形
end;{ 方法，调用Windows API执行URL }
function TSWURLLabel.ExecuteURL;
var
  ZFileName:array[0..255] of char;
begin
  if Assigned(FOnBeforeExecuteURL) then
    FOnBeforeExecuteURL(Self);  // 若指定了事件处理过程则调用它
  if Length(FURL)>0 then begin
    // 当URL不为空时执行
    StrPCopy(ZFileName, FURL);
    ShellExecute(Application.Handle, nil,
                 ZFileName, nil, nil, SW_SHOWNORMAL);  end;end;
{ 登记新构件的过程 }
procedure Register;
begin
  // 第一个参数是面板页的名字，第二个参数是新构件的类名
  RegisterComponents('SeaWave', [TSWURLLabel]);
end;{ 私有方法，设置URL属性值 }
procedure TSWURLLabel.SetURL(Value:String);
begin
  FURL := Value;
  if csDesigning in ComponentState then
    Caption := Value;
end;end.
 　　如果要为你的新控件加一个放在Delphi面板上的图标，请用Delphi的映象编辑器建立一个与构件源程序同名的、后缀名为DCR的资源文件，该资源文件包含一个24乘24的16色位图（即新构件的图标），将此DCR文件与源程序文件放在同一目录下，安装新构件完毕后就会发现新构件的图标了（否则Delphi为新构件建立一个省缺的图标）。

Answer 1

本例子的控件可做为ActiveX控件生成向导的VCL类，编译后则可产生一 
            ActiveX控件，用于ASP程序中，做为列举本地目录文件名之用。 
            unit fnmasksch;            interface            uses
            Classes,SysUtils,controls,graphics;            type
            TfnSearch = class(TWinControl)
            private
            {Private declarations }
            FFileMask:String;
            procedure SetFileMask(const Value: string);//写文件匹配串
            protected
            { Protected declarations }
            public
            { Public declarations }
            constructor Create(AOwner: TComponent); override;
            destructor Destroy; override;
            function Executeftr: string;            published
            { Published declarations }
            property FileMask: string read FFileMask write SetFileMask;
            end;            procedure Register;            implementation            uses bmp2gif;            procedure Register;
            begin
            RegisterComponents('custom', [TfnSearch]);
            end;            //构造子
            constructor Tfnsearch.Create(AOwner: TComponent);
            begin
            inherited Create(AOwner);
            end;            //析构子
            destructor Tfnsearch.Destroy;
            begin
            inherited Destroy;
            end;            procedure Tfnsearch.SetFileMask(const Value: string);
            begin
            FFileMask := Value;
            end;            //普通筛选
            function Tfnsearch.Executeftr: string;
            var optionstr:string;
            SearchRec: TSearchRec;
            Rs,i,fc:integer;
            fstr:TStringList;
            begin
            optionstr:='';
            result:='';
            fstr:=Tstringlist.create;
            Rs:=FindFirst(FileMask,faArchive,SearchRec);
            if Rs=0 then
            begin
            fstr.Add(SearchRec.Name);
            while FindNext(SearchRec)=0 do fstr.Add(SearchRec.Name);
            end;
            FindClose(SearchRec);            fc:=fstr.Count;
            if fc>0 then
            begin
            for i:=0 to fc-1 do optionstr:=optionstr+' '+fstr[i];
            result:=optionstr;
            end;
            fstr.free;
            end;
            end.