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: HP ALETTE; 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 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;
DEStructor think.destroy; begin ftive.free;
Function thimage.getpalette: hpalette; begin result: = 0; if ftive.graphic <> nil dam = fpicture.graphic.palette;
Procedure think.SetPicturenormal (Value: tpicture); begin fPicturenormal.Assign (value); fpicture.assign (value);
Procedure think (Value: tpicture); begin ftivehot.assign (value);
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 ;
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;
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 the result: = Tbitmap (Picture.graphic) .canvas;
END;
PROCEDURE THIMAGE.SETCENTER (Value: Boolean); Begin if fcenter <> value dam fCenter: = Value; PictureChanged (Self); end;
Procedure think.SetPicture (value: tpicture); begin ftive.assign (Value);
Procedure think (Value: boolean); begin if value <> fstretch the beginning ;.
ProcedureTTransparent (Value: Boolean); Begin IF Value <> FTRANSPARENT THEN BEGIN FTRANSPARENT: = VALUE; PictureChanged (Self);
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 dam If not (g is Tmetafile) or (g.transparent; if (not g.transparent) and (Stretch OR) .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 Newh Etem: = Picture.height; end;
PROCEDURE THIMAGE.CMMMOLEAVE (VAR Message: TMESSAGE); Begin inherited; if fpicture <> fpicturenormal damal; fpicturenormal);
Procedure thinkage.cmmseenter (Var Message: TMESSAGE); Begin inherited; if fpicture <> fpicturehot kiln (fpicturehot);
Procedure Register; Begin RegisterComponents ('Lee', [THIMAGE]); END;
End.
