求助 ，我怎么实现我下面需要的那个功能，谢谢 |
|
尚未結案
|
|
lsh998
中階會員   發表：163 回覆：138 積分：60 註冊：2005-01-07 發送簡訊給我 |
|
|
wameng
版主 發表：31 回覆：1336 積分：1188 註冊：2004-09-16 發送簡訊給我 |
|
|
lsh998
中階會員 發表：163 回覆：138 積分：60 註冊：2005-01-07 發送簡訊給我 |
|
|
wameng
版主 發表：31 回覆：1336 積分：1188 註冊：2004-09-16 發送簡訊給我 |
|
|
lsh998
中階會員 發表：163 回覆：138 積分：60 註冊：2005-01-07 發送簡訊給我 |
wameng 大哥
我下了一个： { DanHint
Version 1.02
Designed and developed by
Dan Ho
danho@cs.nthu.edu.tw First version: 3-25-1996
Last modified: 4-5-1996 version 1.021
Tom Lee ( tom@libra.aaa.hinet.net)
modified for Delphi 3
5-6-1997
} unit Danhint; interface uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs; type
THintDirection=(hdUpRight,hdUpLeft,hdDownRight,hdDownLeft);
TOnSelectHintDirection=procedure(HintControl:TControl;var HintDirection:THintDirection) of object; TDanHint = class(TComponent)
private
{ Private declarations }
FHintDirection:THintDirection;
FHintColor:TColor;
FHintShadowColor:TColor;
FHintFont:TFont;
FHintPauseTime:Integer;
FOnSelectHintDirection:TOnSelectHintDirection;
procedure SetHintDirection(Value:THintDirection);
procedure SetHintColor(Value:TColor);
procedure SetHintShadowColor(Value:TColor);
procedure SetHintFont(Value:TFont);
procedure CMFontChanged(var Message:TMessage); message CM_FONTCHANGED;
procedure SetHintPauseTime(Value:Integer);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure Loaded;override;
procedure SetNewHintFont;
published
{ Published declarations }
property HintDirection:THintDirection read FHintDirection write SetHintDirection default hdUpRight;
property HintColor:TColor read FHintColor write SetHintColor default clYellow;
property HintShadowColor:TColor read FHintShadowColor write SetHintShadowColor default clPurple;
property HintFont:TFont read FHintFont write SetHintFont;
property HintPauseTime:Integer read FHintPauseTime write SetHintPauseTime default 600;
property OnSelectHintDirection:TOnSelectHintDirection read FOnSelectHintDirection write FOnSelectHintDirection;
end; TNewHint = class(THintWindow)
private
{ Private declarations }
FDanHint:TDanHint;
FHintDirection:THintDirection;
procedure SelectProperHintDirection(ARect:TRect);
procedure CheckUpRight(Spot:TPoint);
procedure CheckUpLeft(Spot:TPoint);
procedure CheckDownRight(Spot:TPoint);
procedure CheckDownLeft(Spot:TPoint);
function FindDanHint:TDanHint;
function FindCursorControl:TControl;
protected
{ Protected declarations }
procedure Paint;override;
procedure CreateParams(var Params: TCreateParams);override;
public
{ Public declarations }
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure ActivateHint(Rect: TRect; const AHint: string);override;
property HintDirection:THintDirection read FHintDirection write FHintDirection default hdUpRight;
published
{ Published declarations }
end; procedure Register; implementation const
SHADOW_WIDTH=6;
N_PIXELS=5;
var
MemBmp:TBitmap;
UpRect,DownRect:TRect;
SelectHintDirection:THintDirection;
ShowPos:TPoint; procedure Register;
begin
RegisterComponents('Custom', [TDanHint]);
end; procedure TDanHint.SetNewHintFont;
var
I:Integer;
begin
for I:=0 to Application.ComponentCount-1 do
if Application.Components[I] is TNewHint then
begin
TNewHint(Application.Components[I]).Canvas.Font.Assign(FHintFont);
Exit;
end;
end; constructor TDanHint.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FHintDirection:=hdUpRight;
FHintColor:=clYellow;
{ $0080FFFF is Delphi's original setting }
FHintShadowColor:=clPurple;
FHintPauseTime:=600;
Application.HintPause:=FHintPauseTime;
FHintFont:=TFont.Create;
FHintFont.Name:='MS Sans Serif';
FHintFont.Size:=12;
FHintFont.Color:=clBlue;
FHintFont.Pitch:=fpDefault;
FHintFont.Style:=FHintFont.Style+[fsBold,fsItalic]; if not (csDesigning in ComponentState) then
begin
HintWindowClass:=TNewHint;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ in TApplication's SetShowHint, the private
FHintWindow is allocated according to
HintWindowClass, so here do so actions to
call SetShowHint and keep ShowHint property
the same value }
SetNewHintFont;
end;
end; destructor TDanHint.Destroy;
begin
FHintFont.Free;
inherited Destroy;
end; procedure TDanHint.Loaded;
begin
if not (csDesigning in ComponentState) then
begin
inherited Loaded;
HintWindowClass:=TNewHint;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end;
end; procedure TDanHint.SetHintDirection(Value:THintDirection);
begin
FHintDirection:=Value;
end; procedure TDanHint.SetHintColor(Value:TColor);
begin
FHintColor:=Value;
end; procedure TDanHint.SetHintShadowColor(Value:TColor);
begin
FHintShadowColor:=Value;
end; procedure TDanHint.SetHintFont(Value:TFont);
begin
FHintFont.Assign(Value);
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end; procedure TDanHint.CMFontChanged(var Message:TMessage);
begin
inherited;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end; procedure TDanHint.SetHintPauseTime(Value:Integer);
begin
if (Value<>FHintPauseTime) then
begin
FHintPauseTime:=Value;
Application.HintPause:=Value;
end;
end; function TNewHint.FindDanHint:TDanHint;
var
I:Integer;
begin
Result:=nil;
for I:=0 to Application.MainForm.ComponentCount-1 do
if Application.MainForm.Components[I] is TDanHint then
begin
Result:=TDanHint(Application.MainForm.Components[I]);
Exit;
end;
end; constructor TNewHint.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
{if (Application<>nil) and (Application.MainForm<>nil) then
FDanHint:=FindDanHint;}
ControlStyle:=ControlStyle-[csOpaque];
with Canvas do
begin
{ Font.Name:='MS Sans Serif';
Font.Size:=10;}
{if (FDanHint<>nil) then Font.Assign(FDanHint.HintFont);}
Brush.Style:=bsClear;
Brush.Color:=clBackground;
Application.HintColor:=clBackground;
end;
FHintDirection:=hdUpRight;
end; destructor TNewHint.Destroy;
begin
inherited Destroy;
end; procedure TNewHint.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
{Style := WS_POPUP or WS_BORDER or WS_DISABLED;}
Style := Style-WS_BORDER;
{ExStyle:=ExStyle or WS_EX_TRANSPARENT;}
{Add the above makes the beneath window overlap hint}
WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
end;
end; procedure TNewHint.Paint;
var
R: TRect;
CCaption: array[0..255] of Char;
FillRegion,ShadowRgn:HRgn;
AP:array[0..2] of TPoint; { Points of the Arrow }
SP:array[0..2] of TPoint; { Points of the Shadow }
X,Y:Integer;
AddNum:Integer; { Added num for hdDownXXX }
begin
R := ClientRect;
{ R is for Text output }
Inc(R.Left,5+3);
Inc(R.Top,3);
AddNum:=0;
if FHintDirection>=hdDownRight then AddNum:=15;
Inc(R.Top,AddNum); case HintDirection of
hdUpRight:begin
AP[0]:=Point(10,Height-15);
AP[1]:=Point(20,Height-15);
AP[2]:=Point(0,Height);
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
hdUpLeft:begin
AP[0]:=Point(Width-SHADOW_WIDTH-20,Height-15);
AP[1]:=Point(Width-SHADOW_WIDTH-10,Height-15);
AP[2]:=Point(Width-SHADOW_WIDTH,Height);
SP[0]:=Point(Width-SHADOW_WIDTH-27,Height-15);
SP[1]:=Point(Width-SHADOW_WIDTH-5,Height-15);
SP[2]:=Point(Width-SHADOW_WIDTH,Height);
end;
hdDownRight:begin
AP[0]:=Point(10,15);
AP[1]:=Point(20,15);
AP[2]:=Point(0,0);
{ for hdDownXXX, SP not used now }
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
hdDownLeft:begin
AP[0]:=Point(Width-SHADOW_WIDTH-20,15);
AP[1]:=Point(Width-SHADOW_WIDTH-10,15);
AP[2]:=Point(Width-SHADOW_WIDTH,0);
{ for hdDownXXX, SP not used now }
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
end; { Draw Shadow of the Hint Rect}
if (FHintDirection<=hdUpLeft) then
begin
ShadowRgn:=CreateRoundRectRgn(0+10,0+8,Width,Height-9,8,8);
{ 8 is for RoundRect's corner }
for X:=Width-SHADOW_WIDTH-8 to Width do
for Y:=8 to Height-14 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
for X:=10 to Width do
for Y:=Height-14 to Height-9 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
end
else { for hdDownXXX }
begin
ShadowRgn:=CreateRoundRectRgn(0+10,0+8+15,Width,Height-2,8,8);
for X:=Width-SHADOW_WIDTH-8 to Width do
for Y:=23 to Height-8 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
for X:=10 to Width do
for Y:=Height-8 to Height-2 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
end;
DeleteObject(ShadowRgn); { Draw the shadow of the arrow }
if (HintDirection<=hdUpLeft) then
begin
ShadowRgn:=CreatePolygonRgn(SP,3,WINDING);
for X:=SP[0].X to SP[1].X do
for Y:=SP[0].Y to SP[2].Y do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
DeleteObject(ShadowRgn);
end; { Draw HintRect }
MemBmp.Canvas.Pen.Color:=clBlack;
MemBmp.Canvas.Pen.Style:=psSolid;
MemBmp.Canvas.Brush.Color:=FDanHint.HintColor; MemBmp.Canvas.Brush.Style:=bsSolid;
if (FHintDirection<=hdUpLeft) then
MemBmp.Canvas.RoundRect(0,0,Width-SHADOW_WIDTH,Height-14,9,9)
else
MemBmp.Canvas.RoundRect(0,0+AddNum,Width-SHADOW_WIDTH,Height-14+6,9,9);
{ Draw Hint Arrow }
MemBmp.Canvas.Pen.Color:=FDanHint.HintColor;
MemBmp.Canvas.MoveTo(AP[0].X,AP[0].Y);
MemBmp.Canvas.LineTo(AP[1].X,AP[1].Y);
MemBmp.Canvas.Pen.Color:=clBlack;
FillRegion:=CreatePolygonRgn(AP,3,WINDING);
FillRgn(MemBmp.Canvas.Handle,FillRegion,MemBmp.Canvas.Brush.Handle);
DeleteObject(FillRegion);
MemBmp.Canvas.LineTo(AP[2].X,AP[2].Y);
MemBmp.Canvas.LineTo(AP[0].X,AP[0].Y); { SetBkMode makes DrawText's text be transparent }
SetBkMode(MemBmp.Canvas.Handle,TRANSPARENT);
MemBmp.Canvas.Font.Assign(FDanHint.HintFont);
DrawText(MemBmp.Canvas.Handle, StrPCopy(CCaption, Caption), -1, R,
DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
Canvas.CopyMode:=cmSrcCopy;
Canvas.CopyRect(ClientRect,MemBmp.Canvas,ClientRect);
MemBmp.Free;
end; procedure TNewHint.CheckUpLeft(Spot:TPoint);
var
Width,Height:Integer;
begin
Dec(Spot.Y,N_PIXELS);
Width:=UpRect.Right-UpRect.Left;
Height:=UpRect.Bottom-UpRect.Top;
SelectHintDirection:=hdUpLeft;
if (Spot.X+SHADOW_WIDTH-Width)<0 then
begin
Inc(Spot.Y,N_PIXELS);{back tp original}
CheckUpRight(Spot);
Exit;
end;
if (Spot.Y-Height)<0 then
begin
Inc(Spot.Y,N_PIXELS);
CheckDownLeft(Spot);
Exit;
end;
ShowPos.X:=Spot.X SHADOW_WIDTH-Width;
ShowPos.Y:=Spot.Y-Height;
end; procedure TNewHint.CheckUpRight(Spot:TPoint);
var
Width,Height:Integer;
begin
Dec(Spot.Y,N_PIXELS);
Width:=UpRect.Right-UpRect.Left;
Height:=UpRect.Bottom-UpRect.Top;
SelectHintDirection:=hdUpRight;
if (Spot.X Width)>Screen.Width then
begin
Inc(Spot.Y,N_PIXELS);
CheckUpLeft(Spot);
Exit;
end;
if (Spot.Y-Height)<0 then
begin
Inc(Spot.Y,N_PIXELS);
CheckDownRight(Spot);
Exit;
end;
ShowPos.X:=Spot.X;
ShowPos.Y:=Spot.Y-Height;
end; procedure TNewHint.CheckDownRight(Spot:TPoint);
var
Width,Height:Integer;
begin
Inc(Spot.Y,N_PIXELS*3);
Width:=DownRect.Right-DownRect.Left;
Height:=DownRect.Bottom-DownRect.Top;
SelectHintDirection:=hdDownRight;
if (Spot.X Width)>Screen.Width then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckDownLeft(Spot);
Exit;
end;
if (Spot.Y Height)>Screen.Height then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckUpRight(Spot);
Exit;
end;
ShowPos.X:=Spot.X;
ShowPos.Y:=Spot.Y;
end; procedure TNewHint.CheckDownLeft(Spot:TPoint);
var
Width,Height:Integer;
begin
Inc(Spot.Y,N_PIXELS*3);
Width:=DownRect.Right-DownRect.Left;
Height:=DownRect.Bottom-DownRect.Top;
SelectHintDirection:=hdDownLeft;
if (Spot.X SHADOW_WIDTH-Width)<0 then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckDownRight(Spot);
Exit;
end;
if (Spot.Y Height)>Screen.Height then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckUpLeft(Spot);
Exit;
end;
ShowPos.X:=Spot.X SHADOW_WIDTH-Width;
ShowPos.Y:=Spot.Y;
end; function TNewHint.FindCursorControl:TControl;
begin
{ControlAtPos}
end; procedure TNewHint.SelectProperHintDirection(ARect:TRect);
var
Spot:TPoint;
OldHintDirection,SendHintDirection:THintDirection;
HintControl:TControl;
begin
GetCursorPos(Spot);
HintCOntrol:=FindDragTarget(Spot,True);
Inc(ARect.Right,10 SHADOW_WIDTH);
Inc(ARect.Bottom,20);
UpRect:=ARect;
Inc(ARect.Bottom,9);
DownRect:=ARect;
OldHintDirection:=FDanHint.HintDirection;
SendHintDirection:=FDanHint.HintDirection;
{ Tricky, why here can't use FDanHint.OnSe...? }
if Assigned(FDanHint.FOnSelectHintDirection) then
begin
FDanHint.FOnSelectHintDirection(HintControl,SendHintDirection);
FDanHint.HintDirection:=SendHintDirection;
end;
case FDanHint.HintDirection of
hdUpRight:CheckUpRight(Spot);
hdUpLeft:CheckUpLeft(Spot);
hdDownRight:CheckDownRight(Spot);
hdDownLeft:CheckDownLeft(Spot);
end;
FDanHint.HintDirection:=OldHintDirection;
end; procedure TNewHint.ActivateHint(Rect: TRect; const AHint: string);
var
ScreenDC:HDC;
LeftTop:TPoint;
tmpWidth,tmpHeight:Integer;
begin
MemBmp:=TBitmap.Create;
Caption := AHint;
{ add by Dan from Here }
FDanHint:=FindDanHint; SelectProperHintDirection(Rect);
HintDirection:=SelectHintDirection;
{ if the following changes, make sure to modify
SelectProperHintDirection also }
Inc(Rect.Right,10 SHADOW_WIDTH);
Inc(Rect.Bottom,20);
if (FHintDirection>=hdDownRight) then Inc(Rect.Bottom,9);
{ to expand the rect }
tmpWidth:=Rect.Right-Rect.Left;
tmpHeight:=Rect.Bottom-Rect.Top;
Rect.Left:=ShowPos.X;
Rect.Top:=ShowPos.Y;
Rect.Right:=Rect.Left tmpWidth;
Rect.Bottom:=Rect.Top tmpHeight;
BoundsRect := Rect; MemBmp.Width:=Width;
MemBmp.Height:=Height; ScreenDC:=CreateDC('DISPLAY',nil,nil,nil);
LeftTop.X:=0;
LeftTop.Y:=0;
LeftTop:=ClientToScreen(LeftTop);
{ use MemBmp to store the original bitmap
on screen }
BitBlt(MemBmp.Canvas.Handle,0,0,Width,Height,ScreenDC,
LeftTop.X,LeftTop.Y,SRCCOPY);
{ SetBkMode(Canvas.Handle,TRANSPARENT);} SetWindowPos(Handle, HWND_TOPMOST, ShowPos.X, ShowPos.Y, 0,
0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
BitBlt(Canvas.Handle,0,0,Width,Height,MemBmp.Canvas.Handle,
0,0,SRCCOPY);
DeleteDC(ScreenDC);
end; initialization end. 可是我怎么用他呢？ 在 Unit1 中 implementation
uses
Danhint; 可是没有效果啊
是不是还要做别的事情啊？ 谢谢 wameng 大哥！
|
|
wameng
版主 發表：31 回覆：1336 積分：1188 註冊：2004-09-16 發送簡訊給我 |
元件必須透過註冊及打包至Package。才會出現在Delphi元件分頁欄中。 以下是動態建立元件的方式，依然有效。
Type
TForm1 = Class(Tform)
...
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
DanHint1 :TDanHint;
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
DanHint1 := TDanHint.Create(Self);
end; procedure TForm1.FormDestroy(Sender: TObject);
begin
DanHint1.Free;
end; 試試！ ～～～～～～～～～～～
難得聰明，常常糊塗。
～～～～～～～～～～～
|
|
taishyang
站務副站長  發表：377 回覆：5490 積分：4563 註冊：2002-10-08 發送簡訊給我 |
發表時間：2005-06-07 18:24:02
IP:219.128.xxx.xxx 未訂閱
系統時間：2024-07-03 14:15:00
聯絡我們 | Delphi K.Top討論版
| 本站聲明 |
|
1. 本論壇為無營利行為之開放平台，所有文章都是由網友自行張貼，如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權，而損及您的利益，請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨，是藍是綠本站無權干涉，但這裡不是政治性論壇！ |