下划线和蓝色简单,超链效果可用 ShellExecute函数,注意必需uses ShellAPI单元

解决方案 »

  1.   

    //转贴一篇文章,用Label实现的
    制作构件并不是三言两语就能说清楚的,下面用一个简单的实例来说明。这个新控件从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为新构件建立一个省缺的图标)。
      

  2.   

    unit main;interfaceuses  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,  Menus, StdCtrls, ComCtrls;type  TMainForm = class(TForm)    MainMenu1: TMainMenu;    MenuFile: TMenuItem;    MenuOpen: TMenuItem;    MenuSaveAs: TMenuItem;    N1: TMenuItem;    MenuExit: TMenuItem;    OpenDlg: TOpenDialog;    SaveDlg: TSaveDialog;    Rich: TRichEdit;    StatusBar: TStatusBar;    procedure FormCreate(Sender: TObject);    procedure MenuOpenClick(Sender: TObject);    procedure MenuSaveAsClick(Sender: TObject);    procedure MenuExitClick(Sender: TObject);    procedure MenuPopupPopup(Sender: TObject);    procedure MenuSelectAllClick(Sender: TObject);    procedure MenuCopyClick(Sender: TObject);  private    procedure Progress(Address:LongInt);  end;var  MainForm: TMainForm;implementation{$R *.DFM}type  THexConversion = class(TConversion)  public    function ConvertReadStream(Stream:TStream; Buffer:PChar;                               BufSize:integer): integer; override;  end;// This implements a callback procedure used by TRichEdit when loading// a file.  Gets called repeatedly until stream is empty.//function THexConversion.ConvertReadStream(Stream:TStream; Buffer:PChar;                                          BufSize:integer): integer;var s:string;    buf:array[1..16] of char;    i,n:integer;begin  Result := 0;  if BufSize <= 82 then Exit;  s := Format(';%.5x  ',[Stream.Position]);  n := Stream.Read(buf,16);  if n = 0 then Exit;  for i := 1 to n do    begin      AppendStr(s,IntToHex(ord(buf[i]),2)+' ');      if i mod 4 = 0 then AppendStr(s,' ');    end;  AppendStr(s,StringOfChar(' ',62-length(s)));  for i := 1 to n do    begin      if (buf[i] < #32) or (buf[i] > #126) then        buf[i] := '.';      AppendStr(s,buf[i]);    end;  AppendStr(s,#13#10);  StrPCopy(Buffer,s);  Result := length(s);  if Stream.Position and $FFF = 0 then MainForm.Progress(Stream.Position);end;procedure TMainForm.Progress(Address:LongInt);begin  StatusBar.SimpleText := 'Reading...  $'+IntToHex(Address,5);  StatusBar.Update;end;procedure TMainForm.FormCreate(Sender: TObject);begin  Rich.RegisterConversionFormat('bin',THexConversion);  Rich.RegisterConversionFormat('obj',THexConversion);  Rich.RegisterConversionFormat('exe',THexConversion);end;procedure TMainForm.MenuOpenClick(Sender: TObject);var fname:string;begin if OpenDlg.Execute then   begin     try       Screen.Cursor := crHourglass;       fname := ExtractFileName(OpenDlg.Filename);       StatusBar.SimpleText := 'Reading...';       Rich.Lines.Clear;       Application.ProcessMessages;       try         Rich.Lines.LoadFromFile(OpenDlg.Filename);         StatusBar.SimpleText := fname;       except on E:EFOpenError do         begin           StatusBar.SimpleText := '';           MessageDlg(Format('Can''t open file %s.',[fname]),mtError,[mbOk],0);         end;       end;     finally       Screen.Cursor := crDefault;     end;   end;end;procedure TMainForm.MenuSaveAsClick(Sender: TObject);begin  SaveDlg.Filename := ChangeFileExt(OpenDlg.FileName,'.txt');  if SaveDlg.Execute then    Rich.Lines.SaveToFile(SaveDlg.FileName);end;procedure TMainForm.MenuExitClick(Sender: TObject);begin  Close;end;end.