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.
