How to create a TGraphicControl that displays an image from a TImageList

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.