Image list in my TCustomControl (1.000 points)

ginsonic
ginsonic used Ask the Experts™
on
I need to create in my TustomControl a list of images and to be able to scroll these up and down to can select one.

Someone can help me to do this job?

I offer 1.000 points for a real support (codes or very good comments, not just summary ideas)
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
hello ginsonic, maybe you could give some more info about what you need to do and some specs for image sizes and will images be loaded into list at program design time, run time or added to the component. The options for graphical display are really very many. Have you considered a TDrawGrid and A TImageList?

Author

Commented:
My component look alike a vertical band (a photofilm). Into my program I need to make couple snapshots and to add these to my component alike photos (simmilary of thumbnails).

In present I use a TList of TImage32. When I call Add procedure a new image32 is added to my list .Call Delete ...

The problem is when I try to display these thumbnails.

Must show just a number of images what will fit the component area.

I must can scroll the list up ( when press a button, don't wish to use scrollbars)., and simmilary for down.

And when I will delete an image all next images can go up with one position.

For image size I use in this moment 100x75 pixels.

To have an idea about my component just think about a rollfilm what is scrolled up&down to can look at each photo.
well here is some code that I copied and pasted together, that seems to be a start for what you are trying to do. . . First the TCustomControl - - -



unit RollFilm;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Buttons;

type
TRollFilm = class(TCustomControl)
  private
  { Private declarations }
    FFilm: TBitmap;
    FTopNum, FImageNum: Integer;
    FFilmRect: TRect;
    FUpBut, FDownBut: TSpeedButton;
    procedure UpClick(Sender: TObject);
    procedure DownClick(Sender: TObject);
    procedure DrawFilm;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;

  protected
  { Protected declarations }
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure CreateWnd; override;
    property Canvas;

  public
  { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddBitmap(Bmp: TBitmap);

  published
  { Published declarations }

end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TRollFilm]);
end;

constructor TRollFilm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque, csReplicatable];
Width := 144;
Height := 220;
FFilm := TBitmap.Create;
FFilm.PixelFormat := pf24Bit;
FFilm.Canvas.Brush.Color := clBlack;
FFilm.Height := 202;
FFilm.Width := 75;
FFilm.Canvas.Font.Color := clWhite;
FFilm.Canvas.TextOut(10,46,'Frame 1');
FFilm.Canvas.TextOut(10,146,'Frame 2');
FFilmRect := Rect(8,8,75,202);
FTopNum := 0;
FImageNum := 0;
Canvas.Pen.Color := clHighLight;
Canvas.Pen.Width := 2;
Canvas.Brush.Style := bsClear;
end;

destructor TRollFilm.Destroy;
begin
if Assigned(FFilm) then
FFilm.Free;
inherited Destroy;
end;

procedure TRollFilm.CreateWnd;
begin
inherited;
if not Assigned(FUpBut) then
  begin
  FUpBut := TSpeedButton.Create(Self);
  with FUpBut do
    begin
    Parent := Self;
    Caption := 'Up';
    //Font.Style := Font.Style+[fsBold];
    Width := 34;
    Height := 24;
    Top := 14;
    Left := 90;
    Enabled := False;
    OnClick := UpClick;
    end;
  end;

if not Assigned(FDownBut) then
  begin
  FDownBut := TSpeedButton.Create(Self);
  with FDownBut do
    begin
    Parent := Self;
    Caption := 'Down';
    Width := 34;
    Height := 24;
    Top := 170;
    Left := 90;
    Enabled := False;
    OnClick := DownClick;
    end;
  end;
end;

procedure TRollFilm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
  begin
  Style := Style and not WS_BORDER;
  ExStyle := ExStyle or WS_EX_DLGMODALFRAME;
  WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  end;
end;

procedure TRollFilm.WMSize(var Message: TWMSize);
begin
inherited;
if Message.Height > FFilmRect.Bottom+ 110 then
FFilmRect.Bottom :=  FFilmRect.Bottom+ 102{(Message.Height-16) div 100};
Paint;
end;

procedure TRollFilm.UpClick(Sender: TObject);
begin
if FTopNum > 0 then
  begin
  Dec(FTopNum);
  DrawFilm;
  end;
end;

procedure TRollFilm.DownClick(Sender: TObject);
begin
if FTopNum < FImageNum-(FFilmRect.Bottom div 100) then
  begin
  Inc(FTopNum);
  DrawFilm;
  end;
end;

procedure TRollFilm.DrawFilm;
begin
if Assigned(FFilm) then
  BitBlt(Canvas.Handle,FFilmRect.Left, FFilmRect.Top,FFilm.Width,
       FFilmRect.Bottom, FFilm.Canvas.Handle,0,(FTopNum*100)+2, SRCCOPY);
end;

procedure TRollFilm.Paint;
begin
inherited;
Canvas.TextOut(90,100,IntToStr(FImageNum)+' Images');
  //Brush.Color := FColor;
DrawFilm;
end;

procedure TRollFilm.AddBitmap(Bmp: TBitmap);
var
ThumBmp: TBitmap;
Dimention: TPoint;
begin
Dimention.x := 75;
Dimention.y := 100;
if (not Assigned(Bmp)) or Bmp.Empty then Exit;
Inc(FImageNum);
if FImageNum > 2 then
FFilm.Height := FFilm.Height + 102;
if (Bmp.Width = 75) and (Bmp.Height = 100) then
  BitBlt(FFilm.Canvas.Handle,0, ((FImageNum-1) * 100)+((FImageNum-1) * 2),FFilm.Width,
       100, Bmp.Canvas.Handle,0,0, SRCCOPY)
else
  begin
  ThumBmp := TBitmap.Create;
  //TempBmp.Assign(Bmp);
  ThumBmp.Width := 75;
  ThumBmp.Height := 100;
  ThumBmp.Canvas.StretchDraw(Rect(0,0,ThumBmp.Width,ThumBmp.Height), Bmp);
  BitBlt(FFilm.Canvas.Handle,0, ((FImageNum-1) * 100)+((FImageNum-1) * 2),FFilm.Width,
       100, ThumBmp.Canvas.Handle,0,0, SRCCOPY);
  FFilm.Canvas.TextOut(67,((FImageNum-1) * 100)+84,IntToStr(FImageNum));
{I'm not sure how to keep the aspect Ratio with a 100x75 thumb
maybe you should use a Square thumb to keep the aspect ratio}
  {if Pic1.Width < Pic1.Height then
    begin // 2
    ThumBmp.Height := Dimention;
    ThumBmp.Width := Trunc(Dimention.x / (Bmp.Height / Bmp.Width))+2;
    end else // 2
  if Pic1.Width > Pic1.Height then
    begin // 3
    ThumBmp.Width := Dimention;
    ThumBmp.Height := Trunc(Dimention.y / (Bmp.Width / Bmp.Height))+2;
    end  else // 3
    begin // 4
    ThumBmp.Width := Dimention.x;
    ThumBmp.Height := Dimention.y;
    end; // 4
    ThumBmp.Canvas.StretchDraw(Rect(0,0,ThumBmp.Width,ThumBmp.Height), Bmp);}
  end;
if FImageNum > 2 then
  begin
  FUpBut.Enabled := True;
  FDownBut.Enabled := True;
  end else
  DrawFilm;
Canvas.TextOut(90,100,IntToStr(FImageNum)+' Images');
end;

procedure TRollFilm.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
Pt1: TPoint;
begin
inherited MouseDown(Button, Shift, X, Y);
Pt1.x := X;
Pt1.y := Y;
if (Button = mbLeft) AND PtInRect(FFilmRect, Pt1) then
  begin
  if Y < 108 then
    begin
    DrawFilm;
    Canvas.Rectangle(FFilmRect.Left+1,FFilmRect.Top+1,FFilmRect.Left+75,FFilmRect.Top+101);
    end else
    if Y < 210 then
    begin
    DrawFilm;
    Canvas.Rectangle(FFilmRect.Left+1,108,FFilmRect.Left+75,210);
    end else
    if Y < 310 then
    begin
    DrawFilm;
    Canvas.Rectangle(FFilmRect.Left+1,210,FFilmRect.Left+75,312);
    end;
  end;
end;

end.


 - - - - - - - - - - - - -  - - - - - - - -
and some code in the program -


  private
    { Private declarations }
    RollFilm1: TRollFilm;

procedure TForm1.FormCreate(Sender: TObject);
begin
RollFilm1 := TRollFilm.Create(Self);
RollFilm1.Parent := Self;
RollFilm1.Top := 8;
RollFilm1.Left := 8;
end;

procedure TForm1.sbut_AddPicClick(Sender: TObject);
var
Bmp1: TBitmap;
begin
if OpenPicDialog1.Execute then
  begin
  if UpperCase(ExtractFileExt(OpenPicDialog1.FileName)) = '.BMP' then
    begin
    Bmp1 := TBitmap.Create;
    Bmp1.LoadFromFile(OpenPicDialog1.FileName);
    RollFilm1.AddBitmap(Bmp1);
    Bmp1.Free;
    end;
  end;
end;

procedure TForm1.sbut_DoRollSizeClick(Sender: TObject);
begin
RollFilm1.Width := 200;
RollFilm1.Height := 384;
end;
Python 3 Fundamentals

This course will teach participants about installing and configuring Python, syntax, importing, statements, types, strings, booleans, files, lists, tuples, comprehensions, functions, and classes.

I had some time this weekend -


unit RollFilm;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Buttons;

type
TSelRec = Record
  Draw: Boolean;
  SelNum: Integer;
  sRect: TRect;
  end;

TRollFilm = class(TCustomControl)
  private
  { Private declarations }
    FFilm: TBitmap;
    FTopNum, FImageNum: Integer;
    FFilmRect: TRect;
    FUpBut, FDownBut, FDelSelBut: TSpeedButton;
    FSel: TSelRec;
    procedure UpClick(Sender: TObject);
    procedure DownClick(Sender: TObject);
    procedure DelSelClick(Sender: TObject);
    procedure DrawFilm;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;

  protected
  { Protected declarations }
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure CreateWnd; override;
    property Canvas;

  public
  { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddBitmap(Bmp: TBitmap);

  published
  { Published declarations }

end;

procedure Register;

const
FSize = 86;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TRollFilm]);
end;

constructor TRollFilm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque, csReplicatable];
Width := 178;
Height := 210;
FFilm := TBitmap.Create;
FFilm.PixelFormat := pf24Bit;
FFilm.Canvas.Brush.Color := clBlack;
FFilm.Height := (FSize*2)+4;
FFilm.Width := FSize;
FFilm.Canvas.Font.Color := clWhite;
FFilm.Canvas.TextOut(10,FSize div 2,'Frame 1');
FFilm.Canvas.TextOut(10,FSize+(FSize div 2),'Frame 2');
FFilmRect := Rect(8,8,FSize+8,(FSize*2)+12);
FTopNum := 0;
FImageNum := 0;
Canvas.Pen.Color := clHighLight;
Canvas.Pen.Width := 3;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsClear;
FSel.Draw := False;
FSel.SelNum := -1;
FSel.sRect := Rect(FFilmRect.Left+1,FFilmRect.Top+1,
                FFilmRect.Right-1,FFilmRect.Top+FSize+2);
end;

destructor TRollFilm.Destroy;
begin
if Assigned(FFilm) then
FFilm.Free;
inherited Destroy;
end;

procedure TRollFilm.CreateWnd;
begin
inherited;
if not Assigned(FUpBut) then
  begin
  FUpBut := TSpeedButton.Create(Self);
  with FUpBut do
    begin
    Parent := Self;
    Caption := 'Up';
    Width := 34;
    Height := 24;
    Top := 14;
    Left := FSize + 20;
    Enabled := False;
    OnClick := UpClick;
    end;
  end;

if not Assigned(FDownBut) then
  begin
  FDownBut := TSpeedButton.Create(Self);
  with FDownBut do
    begin
    Parent := Self;
    Caption := 'Down';
    Width := 34;
    Height := 24;
    Top := 150;
    Left := FSize + 20;
    Enabled := False;
    OnClick := DownClick;
    end;
  end;

if not Assigned(FDelSelBut) then
  begin
  FDelSelBut := TSpeedButton.Create(Self);
  with FDelSelBut do
    begin
    Parent := Self;
    Caption := 'Delete Sel';
    Width := 60;
    Height := 24;
    Top := 44;
    Left := FSize + 20;
    Enabled := False;
    OnClick := DelSelClick;
    end;
  end;
end;

procedure TRollFilm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
  begin
  Style := Style and not WS_BORDER;
  ExStyle := ExStyle or WS_EX_DLGMODALFRAME;
  end;
end;

procedure TRollFilm.WMSize(var Message: TWMSize);
var
New, More: Integer;
begin

New := Message.Height - FFilmRect.Top;
More := (New div FSize) - ((FFilmRect.Bottom-FFilmRect.Top) div FSize);
if More = 0 then Exit;
if New > FFilmRect.Bottom+ FSize then
FFilmRect.Bottom :=  FFilmRect.Bottom+ (FSize*More)+(2*More);

if New < FFilmRect.Bottom then
if New < (FSize*2)+6 then
FFilmRect.Bottom :=  FFilmRect.Top+(FSize)+2 else
FFilmRect.Bottom :=  FFilmRect.Bottom+ (FSize*More)+(2*More);
Paint;
inherited;
end;

procedure TRollFilm.UpClick(Sender: TObject);
begin
if FTopNum > 0 then
  begin
  Dec(FTopNum);
  DrawFilm;
  FSel.Draw := False;
  FSel.SelNum := -1;
  FDelSelBut.Enabled := False;
  end;
end;

procedure TRollFilm.DownClick(Sender: TObject);
begin
if FTopNum < FImageNum-(FFilmRect.Bottom div (FSize+2)) then
  begin
  Inc(FTopNum);
  DrawFilm;
  FSel.Draw := False;
  FSel.SelNum := -1;
  FDelSelBut.Enabled := False;
  end;
end;

procedure TRollFilm.DelSelClick(Sender: TObject);
var
TempBmp: TBitmap;
begin
if (FSel.SelNum < 0) or (FSel.SelNum > FImageNum -1) then Exit;
if (FSel.SelNum <> FImageNum -1) then
  begin
  TempBmp := TBitmap.Create;
  try
    TempBmp.Canvas.Brush.Color := clBlack;
    TempBmp.Height := (FSize*(FImageNum -1-FSel.SelNum))+
                      ((FImageNum -1-FSel.SelNum)*2);
    TempBmp.Width := FSize;
    BitBlt(TempBmp.Canvas.Handle,0, 0,FFilm.Width,TempBmp.Height,
       FFilm.Canvas.Handle,0,((FSel.SelNum+1)*FSize)+(2*(FSel.SelNum+1)), SRCCOPY);
    BitBlt(FFilm.Canvas.Handle,0, (FSel.SelNum*FSize)+(2*FSel.SelNum),FFilm.Width,
       TempBmp.Height, TempBmp.Canvas.Handle,0,0, SRCCOPY);
    finally
    TempBmp.Free;
    end;
  end;
FFilm.Height := FFilm.Height - FSize - 2;
Dec(FImageNum);
FTopNum := 0;
FSel.Draw := False;
Paint;
end;

procedure TRollFilm.DrawFilm;
begin
if Assigned(FFilm) then
  BitBlt(Canvas.Handle,FFilmRect.Left, FFilmRect.Top,FFilm.Width,
       FFilmRect.Bottom-FFilmRect.Top, FFilm.Canvas.Handle,0,(FTopNum*FSize)+(FTopNum*2), SRCCOPY);
end;

procedure TRollFilm.Paint;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.Right+8,100,IntToStr(FImageNum)+' Images');
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4);
DrawEdge(Canvas.Handle,FFilmRect, EDGE_SUNKEN, BF_RECT);
InflateRect(FFilmRect,-4,-4);
if FSel.Draw then
Canvas.Rectangle(FSel.sRect);
end;

procedure TRollFilm.AddBitmap(Bmp: TBitmap);
var
ThumBmp: TBitmap;
DWidth, DHeight: Integer;
begin
if (not Assigned(Bmp)) or Bmp.Empty then Exit;
Inc(FImageNum);
if FImageNum > 2 then
FFilm.Height := FFilm.Height + 102;
if (Bmp.Width = FSize) and (Bmp.Height = FSize) then
  BitBlt(FFilm.Canvas.Handle,0, ((FImageNum-1) * FSize)+((FImageNum-1) * 2),FFilm.Width,
       FSize, Bmp.Canvas.Handle,0,0, SRCCOPY)
else
  begin
  ThumBmp := TBitmap.Create;
  try
  ThumBmp.PixelFormat := pf24Bit;
  ThumBmp.Canvas.Brush.Color := clBlack;
  ThumBmp.Width := FSize;
  ThumBmp.Height := FSize;
  if Bmp.Width < Bmp.Height then
    begin
    DHeight := FSize;
    DWidth := Trunc(FSize / (Bmp.Height / Bmp.Width));
    end else
  if Bmp.Width > Bmp.Height then
    begin
    DWidth := FSize;
    DHeight := Trunc(FSize / (Bmp.Width / Bmp.Height));
    end  else
    begin
    DWidth := FSize;
    DHeight := FSize;
    end;
    ThumBmp.Canvas.StretchDraw(Rect((FSize div 2)-(DWidth div 2),(FSize div 2)-(DHeight div 2),(FSize div 2)-(DWidth div 2)+DWidth,(FSize div 2)-(DHeight div 2)+DHeight), Bmp);
    BitBlt(FFilm.Canvas.Handle,0, ((FImageNum-1) * FSize)+((FImageNum-1) * 2),FFilm.Width,
       FSize, ThumBmp.Canvas.Handle,0,0, SRCCOPY);
    FFilm.Canvas.TextOut(67,((FImageNum-1) * FSize)+(FSize-14),IntToStr(FImageNum));
    finally
    ThumBmp.Free;
    end;
  end;

if FImageNum > 2 then
  begin
  FUpBut.Enabled := True;
  FDownBut.Enabled := True;
  end else
  DrawFilm;
if FSel.Draw then
Canvas.Rectangle(FSel.sRect);
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.Right+8,100,IntToStr(FImageNum)+' Images');
Canvas.Brush.Style := bsClear;
end;

procedure TRollFilm.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
Pt1: TPoint;
i: Integer;
begin
inherited MouseDown(Button, Shift, X, Y);
Pt1.x := X;
Pt1.y := Y;
if (Button = mbLeft) AND PtInRect(FFilmRect, Pt1) then
  begin
  FSel.SelNum := -1;
  Pt1.x := 0;
  for i := 0 to 20 do
    begin
    if Y < FFilmRect.Top+(FSize*(i+1))+(2*(i+1)) then
      begin
      if FTopNum+i < FImageNum then
      FSel.SelNum := FTopNum+i;
      if i = 0 then
        begin
        FSel.sRect.Top := FFilmRect.Top+1;
        FSel.sRect.Bottom := FFilmRect.Top+FSize+2;
        end else
        begin
        FSel.sRect.Top := FFilmRect.Top+(FSize*i)+(2*i)-1;
        FSel.sRect.Bottom := FFilmRect.Top+(FSize*(i+1)+(2*i)+1);
        end;
      Break;
      end;
    end;
  DrawFilm;
  Canvas.Rectangle(FSel.sRect);
  FSel.Draw := True;
  FDelSelBut.Enabled := True;
  end;
end;

end.

Author

Commented:
I will test the new code. Anyway look alike the points are your :)
I figure out a solution. Still working. But in max. next 24 hours I will accept your comment.

Author

Commented:
Into the new sample nothing happening on up&down action

Author

Commented:
Search for next 500 points :)
OK, I did some updates for the selected number and delete image, I also added the Mouse Wheel thing





unit RollFilm;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Buttons;

type
TSelRec = Record
  Draw: Boolean;
  SelNum: Integer;
  sRect: TRect;
  end;

TRollFilm = class(TCustomControl)
  private
  { Private declarations }
    FTopNum: Integer;
    FFilmRect: TRect;
    FUpBut, FDownBut, FDelSelBut: TSpeedButton;
    FGotFocus: Boolean;

  protected
  { Protected declarations }
    FFilmBmp: TBitmap;
    FSelectRec: TSelRec;
    FImageNum: Integer;
    procedure UpClick(Sender: TObject);
    procedure DownClick(Sender: TObject);
    procedure DelSelClick(Sender: TObject);
    procedure DrawFilm;
    procedure DrawSelect;
    procedure EnableButtons;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure CreateWnd; override;
    property Canvas;

  public
  { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddBitmap(Bmp: TBitmap);

  published
  { Published declarations }

end;

procedure Register;

const
FSize = 86;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TRollFilm]);
end;

constructor TRollFilm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque, csReplicatable];
Width := 178;
Height := 210;
FFilmBmp := TBitmap.Create;
FFilmBmp.PixelFormat := pf24Bit;
FFilmBmp.Canvas.Brush.Color := clBlack;
FFilmBmp.Height := 2;
FFilmBmp.Width := FSize;
FFilmBmp.Canvas.Font.Color := clWhite;
FFilmRect := Rect(8,8,FSize+8,(FSize*2)+14);
FTopNum := 0;
FImageNum := 0;
Canvas.Pen.Color := clHighLight;
Canvas.Pen.Width := 3;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsClear;
FSelectRec.Draw := False;
FSelectRec.SelNum := -1;
FSelectRec.sRect := Rect(FFilmRect.Left+1,FFilmRect.Top+1,
                FFilmRect.Right-1,FFilmRect.Top+FSize+2);
FGotFocus := False;
end;

destructor TRollFilm.Destroy;
begin
if Assigned(FFilmBmp) then
FFilmBmp.Free;
inherited Destroy;
end;

procedure TRollFilm.CreateWnd;
begin
inherited;
if not Assigned(FUpBut) then
  begin
  FUpBut := TSpeedButton.Create(Self);
  with FUpBut do
    begin
    Parent := Self;
    Caption := 'Up';
    Width := 34;
    Height := 24;
    Top := 14;
    Left := FSize + 20;
    Enabled := False;
    OnClick := UpClick;
    end;
  end;

if not Assigned(FDownBut) then
  begin
  FDownBut := TSpeedButton.Create(Self);
  with FDownBut do
    begin
    Parent := Self;
    Caption := 'Down';
    Width := 34;
    Height := 24;
    Top := 150;
    Left := FSize + 20;
    Enabled := False;
    OnClick := DownClick;
    end;
  end;

if not Assigned(FDelSelBut) then
  begin
  FDelSelBut := TSpeedButton.Create(Self);
  with FDelSelBut do
    begin
    Parent := Self;
    Caption := 'Delete Sel';
    Width := 60;
    Height := 24;
    Top := 44;
    Left := FSize + 20;
    Enabled := False;
    OnClick := DelSelClick;
    end;
  end;
end;

procedure TRollFilm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
  begin
  Style := Style and not WS_BORDER;
  ExStyle := ExStyle or WS_EX_DLGMODALFRAME;
  end;
end;

procedure TRollFilm.EnableButtons;
begin
if FImageNum > FFilmRect.Bottom div (FSize+2) then
  begin
  FUpBut.Enabled := True;
  FDownBut.Enabled := True;
  end else
  begin
  FUpBut.Enabled := False;
  FDownBut.Enabled := False;
  end;
end;

function TRollFilm.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
inherited DoMouseWheelDown(Shift, MousePos);
Result := False;
DownClick(FDownBut);
end;

function TRollFilm.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
inherited DoMouseWheelDown(Shift, MousePos);
Result := False;
UpClick(FUpBut);
end;

procedure TRollFilm.WMSize(var Message: TWMSize);
var
New, More: Integer;
begin
New := Message.Height - FFilmRect.Top;
More := (New div FSize) - ((FFilmRect.Bottom-FFilmRect.Top) div FSize);
if More = 0 then Exit;
if New > FFilmRect.Bottom+ FSize then
FFilmRect.Bottom :=  FFilmRect.Bottom+ (FSize*More)+(2*More);

if New < FFilmRect.Bottom then
if New < (FSize*2)+6 then
FFilmRect.Bottom :=  FFilmRect.Top+(FSize)+4 else
FFilmRect.Bottom :=  FFilmRect.Bottom+ (FSize*More)+(2*More);
if Assigned(FUpBut) then
EnableButtons;
Paint;
inherited;
end;

procedure TRollFilm.UpClick(Sender: TObject);
begin
if FTopNum > 0 then
  begin
  Dec(FTopNum);
  DrawFilm;
  FSelectRec.sRect.Top := FSelectRec.sRect.Top+(FSize+2);
  FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom +(FSize+2);
  DrawSelect;
  end;
end;

procedure TRollFilm.DownClick(Sender: TObject);
begin
if FTopNum < FImageNum-(FFilmRect.Bottom div (FSize+2)) then
  begin
  Inc(FTopNum);
  DrawFilm;
  FSelectRec.sRect.Top := FSelectRec.sRect.Top-(FSize+2);
  FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom -(FSize+2);
  DrawSelect;
  end;
end;

procedure TRollFilm.DelSelClick(Sender: TObject);
var
TempBmp: TBitmap;
begin
if (FSelectRec.SelNum < 0) or (FSelectRec.SelNum > FImageNum -1) or (FImageNum < 1) then Exit;
if (FSelectRec.SelNum <> FImageNum -1) then
  begin
  TempBmp := TBitmap.Create;
  try
    TempBmp.Canvas.Brush.Color := clBlack;
    TempBmp.Height := (FSize+2)*(FImageNum -1-FSelectRec.SelNum);
    TempBmp.Width := FSize;
    BitBlt(TempBmp.Canvas.Handle,0, 0, FFilmBmp.Width,TempBmp.Height,
       FFilmBmp.Canvas.Handle,0,(FSelectRec.SelNum+1)*(FSize+2), SRCCOPY);
    BitBlt(FFilmBmp.Canvas.Handle,0, FSelectRec.SelNum*(FSize+2),FFilmBmp.Width,
       TempBmp.Height, TempBmp.Canvas.Handle,0,0, SRCCOPY);
    finally
    TempBmp.Free;
    end;
  end;
FFilmBmp.Height := FFilmBmp.Height - FSize - 2;
Dec(FImageNum);
FTopNum := 0;
FSelectRec.Draw := False;
FSelectRec.SelNum := -1;
FDelSelBut.Enabled := False;
InvalidateRect(Handle,nil, True);
EnableButtons;
end;

procedure TRollFilm.DrawSelect;
begin
if FSelectRec.Draw and
(FSelectRec.sRect.Top > -2) and (FSelectRec.sRect.Top < FFilmRect.Bottom - FSize) then
Canvas.Rectangle(FSelectRec.sRect);
end;

procedure TRollFilm.DrawFilm;
begin
if Assigned(FFilmBmp) and (FImageNum >0) then
  BitBlt(Canvas.Handle,FFilmRect.Left, FFilmRect.Top,FFilmBmp.Width,
       FFilmRect.Bottom-FFilmRect.Top, FFilmBmp.Canvas.Handle,0,FTopNum*(FSize+2), SRCCOPY);
end;

procedure TRollFilm.Paint;
var
Rect1: TRect;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.Right+8,100,IntToStr(FImageNum)+' Images');
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4);
DrawEdge(Canvas.Handle,FFilmRect, EDGE_SUNKEN, BF_RECT);
InflateRect(FFilmRect,-4,-4);
DrawSelect;

if FGotFocus then
  begin
  SetRect(Rect1,2,2,ClientWidth -2,ClientHeight-2);
  Canvas.Pen.Mode := pmXor;
  Canvas.Rectangle(Rect1);
  Canvas.Pen.Mode := pmCopy;
  end;
end;

procedure TRollFilm.AddBitmap(Bmp: TBitmap);
var
ThumBmp: TBitmap;
DWidth, DHeight: Integer;
begin
if (not Assigned(Bmp)) or Bmp.Empty then Exit;
Inc(FImageNum);
FFilmBmp.Height := FFilmBmp.Height + FSize+2;
if (Bmp.Width = FSize) and (Bmp.Height = FSize) then
  BitBlt(FFilmBmp.Canvas.Handle,0, ((FImageNum-1) * FSize)+((FImageNum) * 2),FFilmBmp.Width,
       FSize+2, Bmp.Canvas.Handle,0,0, SRCCOPY)
else
  begin
  ThumBmp := TBitmap.Create;
  try
  ThumBmp.PixelFormat := pf24Bit;
  ThumBmp.Canvas.Brush.Color := clBlack;
  ThumBmp.Width := FSize;
  ThumBmp.Height := FSize;
  if Bmp.Width < Bmp.Height then
    begin
    DHeight := FSize;
    DWidth := Trunc(FSize / (Bmp.Height / Bmp.Width));
    end else
  if Bmp.Width > Bmp.Height then
    begin
    DWidth := FSize;
    DHeight := Trunc(FSize / (Bmp.Width / Bmp.Height));
    end  else
    begin
    DWidth := FSize;
    DHeight := FSize;
    end;
    ThumBmp.Canvas.StretchDraw(Rect((FSize div 2)-(DWidth div 2),(FSize div 2)-(DHeight div 2),
               (FSize div 2)-(DWidth div 2)+DWidth,(FSize div 2)-(DHeight div 2)+DHeight), Bmp);
    BitBlt(FFilmBmp.Canvas.Handle,0, ((FImageNum-1) * FSize)+((FImageNum) * 2),FFilmBmp.Width,
       FSize+2, ThumBmp.Canvas.Handle,0,0, SRCCOPY);
    FFilmBmp.Canvas.TextOut(67,((FImageNum-1) * FSize)+(FSize-14),IntToStr(FImageNum));
    finally
    ThumBmp.Free;
    end;
  end;

EnableButtons;
DrawFilm;
if FSelectRec.Draw then
Canvas.Rectangle(FSelectRec.sRect);
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.Right+8,100,IntToStr(FImageNum)+' Images');
Canvas.Brush.Style := bsClear;
end;

procedure TRollFilm.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
Pt1: TPoint;
i: Integer;
begin
SetFocus;
inherited MouseDown(Button, Shift, X, Y);
Pt1.x := X;
Pt1.y := Y;
if FImageNum = 0 then Exit;
if (Button = mbLeft) AND PtInRect(FFilmRect, Pt1) then
  begin
  FSelectRec.SelNum := -1;
  Pt1.x := 0;
  for i := 0 to 20 do
    begin
    if Y < FFilmRect.Top+(FSize*(i+1))+(2*(i+1)) then
      begin
      if FTopNum+i < FImageNum then
      FSelectRec.SelNum := FTopNum+i;
      FSelectRec.sRect.Top := FFilmRect.Top+((FSize+2)*i)+1;
      FSelectRec.sRect.Bottom := FFilmRect.Top+(FSize*(i+1)+(2*i)+3);
      Break;
      end;
    end;
  if FSelectRec.SelNum > -1 then
    begin
    DrawFilm;
    Canvas.Rectangle(FSelectRec.sRect);
    FSelectRec.Draw := True;
    FDelSelBut.Enabled := True;
    end else
    begin
    FSelectRec.Draw := False;
    DrawFilm;
    FDelSelBut.Enabled := False;
    end;
  end;
end;

procedure TRollFilm.DoEnter;
var
Rect1: TRect;
begin
SetRect(Rect1,2,2,ClientWidth -2,ClientHeight-2);
FGotFocus := True;
Canvas.Pen.Mode := pmXor;
Canvas.Rectangle(Rect1);

Canvas.Pen.Mode := pmCopy;
end;

procedure TRollFilm.DoExit;
var
Rect1: TRect;
begin
FGotFocus := False;
SetRect(Rect1,2,2,ClientWidth -2,ClientHeight-2);
Canvas.Pen.Mode := pmXor;
Canvas.Rectangle(Rect1);
Canvas.Pen.Mode := pmCopy;
end;

end.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial