怎样在窗体的标题栏上放一个超级链接 ( 积分: 50 )

怎样在窗体的标题栏上放一个超级链接？像360安全卫士一样。

链接要打开什么东西？

窗口关掉标题栏，放个panel或工具条之类的....

TO:cyndi_blue
随便，比如 www.163.com


TO:gxw

我不想关闭标题栏

要自已画和截获鼠标事件
－－－－－－－－－－－－－－－－－－－－－－－－－－－
www.waibaoinfo.com

怎样划？

这只是一个链接，需要调用系统函数
var
filename :String;
begin
//链接网站
filename :='http://www.gjch.com.cn';
shellexecute(Application.Handle,nil,pchar(filename),nil,nil,SW_SHOWNORMAL);
end;

WinExec(pchar('C:/Program Files/Internet Explorer/IEXPLORE.EXE http://www.163.com/'),sw_show);

楼上的两位，我不想要这种效果。

我想在窗体的 标题栏 上放一个超级链接。

TForm1 = class(TForm)
mem: TMemo;
procedure FormCreate(Sender: TObject);
private
FURL : string;
FURLRect : TRect;
procedure WMNCPAINT(var Message: TMessage); message WM_NCPAINT;
procedure WMNCLBUTTONDOWN(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
procedure WMNCHitTest(var Msg:TWMNCHitTest);message WM_NCHittest;
procedure DrawCaptionText;
end;

const
htCaptionURL = htSizeLast + 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
FURL := 'http://www.sina.com';
FURLRect.Top := 6;
end;

procedure TForm1.WMNCLBUTTONDOWN(var Message: TWMNCLButtonDown);
begin
inherited;
if(message.HitTest = htCaptionURL) then
mem.Lines.Add('URL Click');
end;

procedure TForm1.WMNCPAINT(var Message: TMessage);
begin
inherited;
DrawCaptionText;
end;

procedure TForm1.DrawCaptionText;
var
dc : HDC;
cvs : TCanvas;
begin
dc := GetWindowDC(handle);
cvs := TCanvas.Create;
try
cvs.Handle:=dc;
cvs.Brush.Style := bsClear;
cvs.Font.Color := clBlue;
cvs.Font.Style := [fsBold, fsUnderline];
FURLRect.Bottom := FURLRect.Top + cvs.TextHeight(FURL);
FURLRect.Right := Self.Width - 70;
FURLRect.Left := FURLRect.Right - cvs.TextWidth(FURL);
cvs.TextOut(FURLRect.Left, FURLRect.Top, FURL);
finally
ReleaseDC(Handle, dc);
end;
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
with Msg do
if PtInRect(FURLRect,Point(xPos - Left, yPos - Top)) then
Result := htCaptionURL;
end;

to:ysai
你的代码已经基本实现了超级链接的效果，但还有一些问题。
1、鼠标移到链接上时，应该将光标变为手形，移出时变为正常。
2、点了超级链接后，比如打开了一个网页，把网页关闭后，标题栏上的超级链接会消失。
3、我在窗体一放了一个VclSkin组件，用上边的代码超级链接不会出现在标题栏上。

學一下。

unit main;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);

private
{ Private declarations }

CBBtnRect: TRect; // Caption Bar Button Rectangle
CBBtnFont: TFont; // Caption Bar Button Font
procedure DrawCaptionBtn(uEdge: UINT);
// 当在标题栏上按下鼠标左按钮时进入该过程
procedure WMNcLButtonDown(var m: TMessage);
message WM_NCLBUTTONDOWN;
// 当在标题栏上放开鼠标左按钮时进入该过程
procedure WMNcLButtonUp(var m: TMessage);
message WM_NCLBUTTONUP;
// 当在标题栏上移动鼠标时进入该过程
procedure WMNcMouseMove(var m: TMessage);
message WM_NCMOUSEMOVE;
// 当在标题栏上双击鼠标左铵钮时进入该过程
procedure WMNcLButtonDBLClk
(var m: TMessage); message WM_NCLBUTTONDBLCLK;
// 当在标题栏上按下鼠标右按钮时进入该过程
procedure WMNcRButtonDown(var m: TMessage);
message WM_NCRBUTTONDOWN;
// 当画标题栏时进入该过程
procedure WMNcPaint(var m: TMessage);
message WM_NCPAINT;
// 当标题栏在激活与非激活之间切换时进入该过程
procedure WMNcActivate(var m: TMessage);
message WM_NCACTIVATE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DrawCaptionBtn(uEdge: UINT);
var
hCaptionDC: HDC; // 标题条Device Context
hOldFont: HFONT; // 原来的字体
r: TRect;
begin
hCaptionDC := GetWindowDC(Self.Handle);
// 注意不能用GetDC,那样的话，将得不到标题栏
// 的设备上下文
//画按钮的样子，如果uEdge=EDGE_RAIS，
则画出的样子为凸起；如果
//uEdge=EDGE_SUNKEN，则画出的样子为凹下。
DrawEdge(hCaptionDC, CBBtnRect, uEdge,
BF_RECT or BF_MIDDLE or
BF_SOFT);

//设置标题栏的设备上下文为透明状态
SetBkMode(hCaptionDC, TRANSPARENT);

//设置标题栏设备上下文的字体
hOldFont:= SelectObject(hCaptionDC, CBBtnFont.Handle);

//画按钮
if uEdge = EDGE_RAISED then
DrawText(hCaptionDC, 'Caption Bar Button',
18, CBBtnRect, DT_CENTER)
else begin
r := CBBtnRect;
OffsetRect(r, 1, 1);
DrawText(hCaptionDC, 'Caption Bar Button', 18, r, DT_CENTER);
end;

//还原为原来的字体
SelectObject(hCaptionDC, hOldFont);
end;

procedure TForm1.WMNcActivate(var m: TMessage);
begin
inherited;
DrawCaptionBtn(EDGE_RAISED);
end;


procedure TForm1.WMNcPaint(var m: TMessage);
begin
inherited;
DrawCaptionBtn(EDGE_RAISED);
end;


procedure TForm1.WMNcLButtonDBLClk(var m: TMessage);
var
p: TPoint;
begin
p.x := LOWORD(m.lParam) - Self.Left;
p.y := HIWORD(m.lParam) - Self.Top;
if not PtInRect(CBBtnRect, p) then // 如果不在按钮区域内
inherited; // 执行默认的操作
end;

procedure TForm1.WMNcMouseMove(var m: TMessage);
var
p: TPoint;
begin
p.x := LOWORD(m.lParam) - Self.Left;
p.y := HIWORD(m.lParam) - Self.Top;
if not PtInRect(CBBtnRect, p) then // 如果不在按钮区域
DrawCaptionBtn(EDGE_RAISED)
else
inherited; // 执行默认的操作
end;


procedure TForm1.WMNcLButtonDown(var m: TMessage);
var
p: TPoint;
begin
p.x := LOWORD(m.lParam) - Self.Left;
p.y := HIWORD(m.lParam) - Self.Top;
if PtInRect(CBBtnRect, p) then // 如果按在了按钮区域
begin
Self.BringToFront;
DrawCaptionBtn(EDGE_SUNKEN);
end
else
inherited; // 执行默认的操作
end;


procedure TForm1.WMNcLButtonUp(var m: TMessage);
var
p: TPoint;
begin
p.x := LOWORD(m.lParam) - Self.Left;
p.y := HIWORD(m.lParam) - Self.Top;
if PtInRect(CBBtnRect, p) then //
如果在标题栏按钮区域释放鼠标
begin
DrawCaptionBtn(EDGE_RAISED);
end
else
inherited; // 执行默认的操作
end;


procedure TForm1.WMNcRButtonDown(var m: TMessage);
var
p: TPoint;
begin
p.x := LOWORD(m.lParam) - Self.Left;
p.y := HIWORD(m.lParam) - Self.Top;
if not PtInRect(CBBtnRect, p) then // 如果不在标题栏按钮区域
inherited; // 执行默认的操作
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
// 这个大小大家可以得用GetSystemMetrics
函数来进行更精确的计算。这里
// 只是用来示例
with CBBtnRect do
begin
left := 100;
top := 6;
right := 450;
bottom := 20;
end;

// 标题栏按钮字体。
CBBtnFont:= TFont.Create;
with CBBtnFont do
begin
Name := '宋体';
Size := 9;
Color := clRed;
end;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
CBBtnFont.Free;
end;

end.

学习~~

方法有多种,把窗口类型改bsnone,然后放个Tpanel,设置成top作个假的标题栏,在panel上放个label就可以了.

高见

xubin4456说的办法简单一点

To :xubin4456 你说的的确是简单的方法，但人家有说过不想关了标题栏

TO:xubin4456
能做个例子吗？

工程文件：Project1.dpr
program Project1;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

窗体文件：Unit1.dfm
object Form1: TForm1
Left = 254
Top = 185
BorderStyle = bsNone
Caption = 'Form1'
ClientHeight = 349
ClientWidth = 537
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnMouseMove = Panel1MouseMove
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 537
Height = 30
Align = alTop
Alignment = taLeftJustify
Caption = ' Form1'
Color = clNavy
Font.Charset = DEFAULT_CHARSET
Font.Color = clWhite
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
OnMouseDown = Panel1MouseDown
OnMouseMove = Panel1MouseMove
object Label1: TLabel
Left = 208
Top = 8
Width = 90
Height = 14
Cursor = crHandPoint
Caption = #25105#30340#38142#25509#22320#22336
Font.Charset = GB2312_CHARSET
Font.Color = clWhite
Font.Height = -14
Font.Name = #23435#20307
Font.Style = [fsBold, fsUnderline]
ParentFont = False
OnClick = Label1Click
OnMouseMove = Label1MouseMove
end
object SpeedButton1: TSpeedButton
Left = 508
Top = 4
Width = 23
Height = 22
Caption = 'X'
Font.Charset = DEFAULT_CHARSET
Font.Color = clRed
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
OnClick = SpeedButton1Click
end
end
end

单元文件：Unit1.pas
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons;

type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
SpeedButton1: TSpeedButton;
procedure Label1Click(Sender: TObject);
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure SpeedButton1Click(Sender: TObject);
procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Label1Click(Sender: TObject);
begin
showmessage('这里放你需要的地址链接');
//这里放你需要的地址链接
end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
SendMessage(self.Handle, WM_SYSCOMMAND,SC_MOVE or HTCAPTION,0)
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
label1.Font.Style:=[fsItalic,fsUnderline];
end;

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
label1.Font.Style:=[fsUnderline]
end;

end.