How to create a TGraphicControl that displays an image from a TImageList (Views: 29)
Problem/Question/Abstract: How to create a TGraphicControl that displays an image from a TImageList Answer: Below is a TImage like component, which draws pictures from the imagelist. It works fine for me in D5: unit ImageFL; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, ImgList; type TLFImage = class; TLFCustomImage = class; TLFAlignmentTypeH = (lh_LeftJustify, lh_Center, lh_RightJustify); TLFAlignmentTypeV = (lv_BottomJustify, lv_Center, lv_TopJustify); TLFCustomImage = class(TGraphicControl) private FImageList: TImageList; FBufBitMap: TBitMap; FImageIndex: TImageIndex; FDrawing: boolean; FCenter: boolean; FXStart, FYStart: integer; FTransparent: boolean; FAlignmentH: TLFAlignmentTypeH; FAlignmentV: TLFAlignmentTypeV; procedure ReCountXYValues; procedure PaintOneImage(AImage: integer); procedure SetAlignmentH(AValue: TLFAlignmentTypeH); procedure SetAlignmentV(AValue: TLFAlignmentTypeV); procedure SetImageList(Value: TImageList); procedure SetImageIndex(Value: TImageIndex); procedure SetCenter(Value: boolean); procedure SetTransparent(Value: boolean); protected function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override; procedure Paint; override; protected property AlignmentH: TLFAlignmentTypeH read FAlignmentH write SetAlignmentH; property AlignmentV: TLFAlignmentTypeV read FAlignmentV write SetAlignmentV; property ImageList: TImageList read FImageList write SetImageList; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex; property Center: boolean read FCenter write SetCenter; property Transparent: boolean read FTransparent write SetTransparent; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; TLFImage = class(TLFCustomImage) published property Align; property AlignmentH; property AlignmentV; property Anchors; property AutoSize; property Constraints; property Color; property DragCursor; property DragKind; property DragMode; property Enabled; property Hint; property ImageIndex; property ImageList; property ParentColor; property ParentShowHint; property PopupMenu; property ShowHint; property Transparent; property Visible; property OnClick; property OnContextPopup; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; procedure Register; implementation procedure Register; begin RegisterComponents('My Components', [TLFImage]); end; constructor TLFCustomImage.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csReplicatable]; FImageList := nil; FXStart := 0; FYStart := 0; Height := 105; Width := 105; FAlignmentH := lh_LeftJustify; FAlignmentV := lv_TopJustify; FBufBitMap := TBitMap.Create; FBufBitMap.Height := Height; FBufBitMap.Width := Width; FBufBitMap.Canvas.Brush.Color := Color; FBufBitMap.Transparent := FTransparent; end; destructor TLFCustomImage.Destroy; begin FBufBitMap.Free; inherited Destroy; end; procedure TLFCustomImage.Paint; var Save: Boolean; begin if csDesigning in ComponentState then begin with Canvas do begin Pen.Style := psDash; Brush.Style := bsClear; Rectangle(0, 0, Width, Height); end; end; ReCountXYValues; Save := FDrawing; FDrawing := True; try PaintOneImage(ImageIndex); finally FDrawing := Save; end; end; procedure TLFCustomImage.PaintOneImage(AImage: integer); begin if not Assigned(ImageList) then exit; FBufBitMap.Height := Height; FBufBitMap.Width := Width; FBufBitMap.Canvas.Brush.Color := Color; FBufBitMap.Transparent := FTransparent; FBufBitMap.Canvas.FillRect(GetClientRect); FImageList.DrawOverlay(FBufBitMap.Canvas, FXStart, FYStart, AImage, 0); Canvas.Draw(0, 0, FBufBitMap); end; function TLFCustomImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; begin Result := True; if not Assigned(ImageList) then exit; if not (csDesigning in ComponentState) or (ImageList.Width > 0) and (ImageList.Height > 0) then begin if Align in [alNone, alLeft, alRight] then NewWidth := ImageList.Width; if Align in [alNone, alTop, alBottom] then NewHeight := ImageList.Height; end; end; procedure TLFCustomImage.ReCountXYValues; begin FYStart := 0; FXStart := 0; if not Assigned(ImageList) then exit; case FAlignmentV of lv_BottomJustify: FYStart := Height - ImageList.Height; lv_Center: FYStart := (Height - ImageList.Height) div 2; lv_TopJustify: FYStart := 0; end; case FAlignmentH of lh_LeftJustify: FXStart := 0; lh_Center: FXStart := (Width - ImageList.Width) div 2; lh_RightJustify: FXStart := Width - ImageList.Width; end; end; procedure TLFCustomImage.SetAlignmentH(AValue: TLFAlignmentTypeH); begin if FAlignmentH <> AValue then begin FAlignmentH := AValue; Invalidate; end; end; procedure TLFCustomImage.SetAlignmentV(AValue: TLFAlignmentTypeV); begin if FAlignmentV <> AValue then begin FAlignmentV := AValue; Invalidate; end; end; procedure TLFCustomImage.SetImageList(Value: TImageList); begin FImageList := Value; Invalidate; end; procedure TLFCustomImage.SetImageIndex(Value: TImageIndex); begin if FImageIndex <> Value then begin FImageIndex := Value; Invalidate; end; end; procedure TLFCustomImage.SetCenter(Value: Boolean); begin if FCenter <> Value then begin FCenter := Value; Invalidate; end; end; procedure TLFCustomImage.SetTransparent(Value: boolean); begin if FTransparent <> Value then begin FTransparent := Value; Invalidate; end; end; end. |