ginsonic
asked on
Image list in my TCustomControl (1.000 points)
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)
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)
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?
ASKER
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.
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.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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('Sample s', [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,FS ize div 2,'Frame 1');
FFilm.Canvas.TextOut(10,FS ize+(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,FFil mRect.Top+ 1,
FFilmRect.Right-1,FFilmRec t.Top+FSiz e+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-FFilmRe ct.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.Botto m div (FSize+2)) then
begin
Inc(FTopNum);
DrawFilm;
FSel.Draw := False;
FSel.SelNum := -1;
FDelSelBut.Enabled := False;
end;
end;
procedure TRollFilm.DelSelClick(Send er: 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.Hand le,0, 0,FFilm.Width,TempBmp.Heig ht,
FFilm.Canvas.Handle,0,((FS el.SelNum+ 1)*FSize)+ (2*(FSel.S elNum+1)), SRCCOPY);
BitBlt(FFilm.Canvas.Handle ,0, (FSel.SelNum*FSize)+(2*FSe l.SelNum), FFilm.Widt h,
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,FFilm Rect.Left, FFilmRect.Top,FFilm.Width,
FFilmRect.Bottom-FFilmRect .Top, FFilm.Canvas.Handle,0,(FTo pNum*FSize )+(FTopNum *2), SRCCOPY);
end;
procedure TRollFilm.Paint;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R ight+8,100 ,IntToStr( FImageNum) +' Images');
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4) ;
DrawEdge(Canvas.Handle,FFi lmRect, EDGE_SUNKEN, BF_RECT);
InflateRect(FFilmRect,-4,- 4);
if FSel.Draw then
Canvas.Rectangle(FSel.sRec t);
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((FSi ze 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.sRec t);
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R ight+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.sRec t);
FSel.Draw := True;
FDelSelBut.Enabled := True;
end;
end;
end.
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('Sample
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,FS
FFilm.Canvas.TextOut(10,FS
FFilmRect := Rect(8,8,FSize+8,(FSize*2)
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,FFil
FFilmRect.Right-1,FFilmRec
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
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-FFilmRe
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
begin
if FTopNum < FImageNum-(FFilmRect.Botto
begin
Inc(FTopNum);
DrawFilm;
FSel.Draw := False;
FSel.SelNum := -1;
FDelSelBut.Enabled := False;
end;
end;
procedure TRollFilm.DelSelClick(Send
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
TempBmp.Height := (FSize*(FImageNum -1-FSel.SelNum))+
((FImageNum -1-FSel.SelNum)*2);
TempBmp.Width := FSize;
BitBlt(TempBmp.Canvas.Hand
FFilm.Canvas.Handle,0,((FS
BitBlt(FFilm.Canvas.Handle
TempBmp.Height, TempBmp.Canvas.Handle,0,0,
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,FFilm
FFilmRect.Bottom-FFilmRect
end;
procedure TRollFilm.Paint;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4)
DrawEdge(Canvas.Handle,FFi
InflateRect(FFilmRect,-4,-
if FSel.Draw then
Canvas.Rectangle(FSel.sRec
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
FSize, Bmp.Canvas.Handle,0,0, SRCCOPY)
else
begin
ThumBmp := TBitmap.Create;
try
ThumBmp.PixelFormat := pf24Bit;
ThumBmp.Canvas.Brush.Color
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
BitBlt(FFilm.Canvas.Handle
FSize, ThumBmp.Canvas.Handle,0,0,
FFilm.Canvas.TextOut(67,((
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.sRec
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R
Canvas.Brush.Style := bsClear;
end;
procedure TRollFilm.MouseDown(Button
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)
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
FSel.sRect.Bottom := FFilmRect.Top+(FSize*(i+1)
end;
Break;
end;
end;
DrawFilm;
Canvas.Rectangle(FSel.sRec
FSel.Draw := True;
FDelSelBut.Enabled := True;
end;
end;
end.
ASKER
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.
I figure out a solution. Still working. But in max. next 24 hours I will accept your comment.
ASKER
Into the new sample nothing happening on up&down action
ASKER
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('Sample s', [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.Colo r := 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,FFil mRect.Top+ 1,
FFilmRect.Right-1,FFilmRec t.Top+FSiz e+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(S hift: 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-FFilmRe ct.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+(FSiz e+2);
FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom +(FSize+2);
DrawSelect;
end;
end;
procedure TRollFilm.DownClick(Sender : TObject);
begin
if FTopNum < FImageNum-(FFilmRect.Botto m div (FSize+2)) then
begin
Inc(FTopNum);
DrawFilm;
FSelectRec.sRect.Top := FSelectRec.sRect.Top-(FSiz e+2);
FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom -(FSize+2);
DrawSelect;
end;
end;
procedure TRollFilm.DelSelClick(Send er: 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.Hand le,0, 0, FFilmBmp.Width,TempBmp.Hei ght,
FFilmBmp.Canvas.Handle,0,( FSelectRec .SelNum+1) *(FSize+2) , SRCCOPY);
BitBlt(FFilmBmp.Canvas.Han dle,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(FSelectRe c.sRect);
end;
procedure TRollFilm.DrawFilm;
begin
if Assigned(FFilmBmp) and (FImageNum >0) then
BitBlt(Canvas.Handle,FFilm Rect.Left, FFilmRect.Top,FFilmBmp.Wid th,
FFilmRect.Bottom-FFilmRect .Top, FFilmBmp.Canvas.Handle,0,F TopNum*(FS ize+2), SRCCOPY);
end;
procedure TRollFilm.Paint;
var
Rect1: TRect;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R ight+8,100 ,IntToStr( FImageNum) +' Images');
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4) ;
DrawEdge(Canvas.Handle,FFi lmRect, EDGE_SUNKEN, BF_RECT);
InflateRect(FFilmRect,-4,- 4);
DrawSelect;
if FGotFocus then
begin
SetRect(Rect1,2,2,ClientWi dth -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.Han dle,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((FSi ze 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.Han dle,0, ((FImageNum-1) * FSize)+((FImageNum) * 2),FFilmBmp.Width,
FSize+2, ThumBmp.Canvas.Handle,0,0, SRCCOPY);
FFilmBmp.Canvas.TextOut(67 ,((FImageN um-1) * FSize)+(FSize-14),IntToStr (FImageNum ));
finally
ThumBmp.Free;
end;
end;
EnableButtons;
DrawFilm;
if FSelectRec.Draw then
Canvas.Rectangle(FSelectRe c.sRect);
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R ight+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(FSelectRe c.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,ClientWi dth -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,ClientWi dth -2,ClientHeight-2);
Canvas.Pen.Mode := pmXor;
Canvas.Rectangle(Rect1);
Canvas.Pen.Mode := pmCopy;
end;
end.
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('Sample
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.Colo
FFilmBmp.Height := 2;
FFilmBmp.Width := FSize;
FFilmBmp.Canvas.Font.Color
FFilmRect := Rect(8,8,FSize+8,(FSize*2)
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,FFil
FFilmRect.Right-1,FFilmRec
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
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
begin
inherited DoMouseWheelDown(Shift, MousePos);
Result := False;
DownClick(FDownBut);
end;
function TRollFilm.DoMouseWheelUp(S
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-FFilmRe
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+(FSiz
FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom +(FSize+2);
DrawSelect;
end;
end;
procedure TRollFilm.DownClick(Sender
begin
if FTopNum < FImageNum-(FFilmRect.Botto
begin
Inc(FTopNum);
DrawFilm;
FSelectRec.sRect.Top := FSelectRec.sRect.Top-(FSiz
FSelectRec.sRect.Bottom := FSelectRec.sRect.Bottom -(FSize+2);
DrawSelect;
end;
end;
procedure TRollFilm.DelSelClick(Send
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
TempBmp.Height := (FSize+2)*(FImageNum -1-FSelectRec.SelNum);
TempBmp.Width := FSize;
BitBlt(TempBmp.Canvas.Hand
FFilmBmp.Canvas.Handle,0,(
BitBlt(FFilmBmp.Canvas.Han
TempBmp.Height, TempBmp.Canvas.Handle,0,0,
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,
EnableButtons;
end;
procedure TRollFilm.DrawSelect;
begin
if FSelectRec.Draw and
(FSelectRec.sRect.Top > -2) and (FSelectRec.sRect.Top < FFilmRect.Bottom - FSize) then
Canvas.Rectangle(FSelectRe
end;
procedure TRollFilm.DrawFilm;
begin
if Assigned(FFilmBmp) and (FImageNum >0) then
BitBlt(Canvas.Handle,FFilm
FFilmRect.Bottom-FFilmRect
end;
procedure TRollFilm.Paint;
var
Rect1: TRect;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R
Canvas.Brush.Style := bsClear;
DrawFilm;
InflateRect(FFilmRect,4,4)
DrawEdge(Canvas.Handle,FFi
InflateRect(FFilmRect,-4,-
DrawSelect;
if FGotFocus then
begin
SetRect(Rect1,2,2,ClientWi
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.Han
FSize+2, Bmp.Canvas.Handle,0,0, SRCCOPY)
else
begin
ThumBmp := TBitmap.Create;
try
ThumBmp.PixelFormat := pf24Bit;
ThumBmp.Canvas.Brush.Color
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
(FSize div 2)-(DWidth div 2)+DWidth,(FSize div 2)-(DHeight div 2)+DHeight), Bmp);
BitBlt(FFilmBmp.Canvas.Han
FSize+2, ThumBmp.Canvas.Handle,0,0,
FFilmBmp.Canvas.TextOut(67
finally
ThumBmp.Free;
end;
end;
EnableButtons;
DrawFilm;
if FSelectRec.Draw then
Canvas.Rectangle(FSelectRe
Canvas.Brush.Color := Color;
Canvas.Brush.Style := bsSolid;
Canvas.TextOut(FFilmRect.R
Canvas.Brush.Style := bsClear;
end;
procedure TRollFilm.MouseDown(Button
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)
begin
if FTopNum+i < FImageNum then
FSelectRec.SelNum := FTopNum+i;
FSelectRec.sRect.Top := FFilmRect.Top+((FSize+2)*i
FSelectRec.sRect.Bottom := FFilmRect.Top+(FSize*(i+1)
Break;
end;
end;
if FSelectRec.SelNum > -1 then
begin
DrawFilm;
Canvas.Rectangle(FSelectRe
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,ClientWi
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,ClientWi
Canvas.Pen.Mode := pmXor;
Canvas.Rectangle(Rect1);
Canvas.Pen.Mode := pmCopy;
end;
end.