分享
 
 
 

一个超链接Image控件!(For D3,D4,D5,D6)源代码

王朝delphi·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

unit HImage;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

THImage = class(TGraphicControl)

private

{ Private declarations }

FPictureNormal:TPicture;

FPictureHot:TPicture;

FPicture:TPicture;

FOnProgress: TProgressEvent;

FStretch: Boolean;

FCenter: Boolean;

FIncrementalDisplay: Boolean;

FTransparent: Boolean;

FDrawing: Boolean;

function GetCanvas: TCanvas;

procedure PictureChanged(Sender: TObject);

procedure SetCenter(Value: Boolean);

procedure SetStretch(Value: Boolean);

procedure SetTransparent(Value: Boolean);

procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

procedure CMMouseLeave(var Message:TMessage); message CM_MOUSELEAVE;

procedure SetPictureNormal(value:TPicture);

procedure SetPictureHot(value:TPicture);

procedure SetPicture(value:Tpicture);

protected

{ Protected declarations }

function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;

function DestRect: TRect;

function DoPaletteChange: Boolean;

function GetPalette: HPALETTE; override;

procedure Paint; override;

procedure Progress(Sender: TObject; Stage: TProgressStage;

PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Picture:TPicture read FPicture write SetPicture;

property Canvas: TCanvas read GetCanvas;

published

{ Published declarations }

property Align;

property Anchors;

property AutoSize;

property Center: Boolean read FCenter write SetCenter default False;

property Constraints;

property DragCursor;

property DragKind;

property DragMode;

property Enabled;

property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property Stretch: Boolean read FStretch write SetStretch default False;

property Transparent: Boolean read FTransparent write SetTransparent default False;

property Visible;

property OnClick;

// property OnContextPopup;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnProgress: TProgressEvent read FOnProgress write FOnProgress;

property OnStartDock;

property OnStartDrag;

property PictureNormal:TPicture read FPictureNormal Write SetPictureNormal;

property PictureHot:TPicture read FPictureHot Write SetPictureHot;

end;

procedure Register;

implementation

constructor THImage.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle := ControlStyle + [csReplicatable];

FPictureNormal := TPicture.Create;

FPictureHot := TPicture.Create;

FPicture := TPicture.Create;

FPicture.OnChange := PictureChanged;

FPicture.OnProgress := Progress;

Height := 105;

Width := 105;

end;

destructor THImage.Destroy;

begin

FPicture.Free;

inherited Destroy;

end;

function THImage.GetPalette: HPALETTE;

begin

Result := 0;

if FPicture.Graphic <> nil then

Result := FPicture.Graphic.Palette;

end;

procedure THImage.SetPictureNormal(value:TPicture);

begin

FPictureNormal.Assign(value);

FPicture.Assign(value);

end;

procedure THImage.SetPictureHot(value:TPicture);

begin

FPictureHot.Assign(value);

end;

function THImage.DestRect: TRect;

begin

if Stretch then

Result := ClientRect

else if Center then

Result := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,

Picture.Width, Picture.Height)

else

Result := Rect(0, 0, Picture.Width, Picture.Height);

end;

procedure THImage.Paint;

var

Save: Boolean;

begin

if csDesigning in ComponentState then

with inherited Canvas do

begin

Pen.Style := psDash;

Brush.Style := bsClear;

Rectangle(0, 0, Width, Height);

end;

Save := FDrawing;

FDrawing := True;

try

with inherited Canvas do

StretchDraw(DestRect, Picture.Graphic);

finally

FDrawing := Save;

end;

end;

function THImage.DoPaletteChange: Boolean;

var

ParentForm: TCustomForm;

Tmp: TGraphic;

begin

Result := False;

Tmp := Picture.Graphic;

if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and

(Tmp.PaletteModified) then

begin

if (Tmp.Palette = 0) then

Tmp.PaletteModified := False

else

begin

ParentForm := GetParentForm(Self);

if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then

begin

if FDrawing then

ParentForm.Perform(wm_QueryNewPalette, 0, 0)

else

PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);

Result := True;

Tmp.PaletteModified := False;

end;

end;

end;

end;

procedure THImage.Progress(Sender: TObject; Stage: TProgressStage;

PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);

begin

if FIncrementalDisplay and RedrawNow then

begin

if DoPaletteChange then Update

else Paint;

end;

if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);

end;

function THImage.GetCanvas: TCanvas;

var

Bitmap: TBitmap;

begin

if Picture.Graphic = nil then

begin

Bitmap := TBitmap.Create;

try

Bitmap.Width := Width;

Bitmap.Height := Height;

Picture.Graphic := Bitmap;

finally

Bitmap.Free;

end;

end;

if Picture.Graphic is TBitmap then

Result := TBitmap(Picture.Graphic).Canvas;

end;

procedure THImage.SetCenter(Value: Boolean);

begin

if FCenter <> Value then

begin

FCenter := Value;

PictureChanged(Self);

end;

end;

procedure THImage.SetPicture(Value: TPicture);

begin

FPicture.Assign(Value);

end;

procedure THImage.SetStretch(Value: Boolean);

begin

if Value <> FStretch then

begin

FStretch := Value;

PictureChanged(Self);

end;

end;

procedure THImage.SetTransparent(Value: Boolean);

begin

if Value <> FTransparent then

begin

FTransparent := Value;

PictureChanged(Self);

end;

end;

procedure THImage.PictureChanged(Sender: TObject);

var

G: TGraphic;

begin

if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then

SetBounds(Left, Top, Picture.Width, Picture.Height);

G := Picture.Graphic;

if G <> nil then

begin

if not ((G is TMetaFile) or (G is TIcon)) then

G.Transparent := FTransparent;

if (not G.Transparent) and (Stretch or (G.Width >= Width)

and (G.Height >= Height)) then

ControlStyle := ControlStyle + [csOpaque]

else

ControlStyle := ControlStyle - [csOpaque];

if DoPaletteChange and FDrawing then Update;

end

else ControlStyle := ControlStyle - [csOpaque];

if not FDrawing then Invalidate;

end;

function THImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;

begin

Result := True;

if not (csDesigning in ComponentState) or (Picture.Width > 0) and

(Picture.Height > 0) then

begin

if Align in [alNone, alLeft, alRight] then

NewWidth := Picture.Width;

if Align in [alNone, alTop, alBottom] then

NewHeight := Picture.Height;

end;

end;

procedure THImage.CMMouseLeave(var Message:TMessage);

begin

inherited;

if FPicture<>FPictureNormal then

Picture.Assign(FPictureNormal);

end;

procedure THImage.CMMouseEnter(var Message: TMessage);

begin

inherited;

if FPicture<>FPictureHot then

Picture.Assign(FPictureHot);

end;

procedure Register;

begin

RegisterComponents('Lee', [THImage]);

end;

end.

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有