Zum Inhalt springen

Photos in Thumbnail-Komponente [Delphi]


Guenzesson

Empfohlene Beiträge

Erfahrung mit einer Thumbnailkomponente aus dem Netz? Nein, da kann ich dir nicht helfen.

Ich hab sowas aber mal selber gemacht. Ich wurde nie ganz fertig, aber soweit funktioniert sie (ich wollte noch ein paar mehr Dinge tun).

Hier erstmal die Thumbnail Unit:


unit JPGThumbUNT;


interface


uses types, classes, controls, ExtCtrls, Graphics, StdCtrls, jpeg,

     frmViewUNT;


type


  TJPGThumb = class(TPanel)

  private

    FPic : tjpegimage;

    FPath: String;

    FlblName: TLabel;

    procedure SetPic(APic: TJPEGImage);

    procedure SetPath(APath: String);

    procedure Enter(Sender: TObject);

    procedure Exit(Sender: TObject);

    procedure Click(Sender: TObject);

    procedure DblClick(Sender: TObject);

  public

    procedure paint; override;

    constructor create(AOwner: TComponent); override;

    destructor destroy; override;

    property Pic: TJPEGImage write Setpic;

    property Path: String read FPath write SetPath;

  end;


  TThumbArray = Array of TJPGThumb;


  TJPGBuffer = class

  private

    FBufferImg: TJPEGImage;

    FThumbs: TThumbArray;


    procedure SetPath(APath: String);


  public

    constructor create;

    destructor destroy; override;

    procedure DrawTo(AParent: TWinControl);

    property Path: string write SetPath;

  end;


const

  cThumbWidth = 120;

  cThumbHeight =120;

  cBorderLeft = 5;

  cBorderRight = 5;

  cBorderTop = 5;

  cBorderBottom = 20;


var

  JPGBuffer: TJPGBuffer;



implementation


uses SysUtils;


{TJPGBuffer}


constructor TJPGBuffer.create;

begin

  inherited;

  FBufferImg:= TJPEGImage.create;

  FBufferImg.Performance:= jpBestSpeed;

end;


destructor TJPGBuffer.destroy;

begin

  FBufferImg.free;

  inherited;

end;


procedure TJPGBuffer.SetPath(APath: String);

begin

  // First load the image

  FBufferImg.LoadFromFile(APath);

  // Add a new thumb

  SetLength(FThumbs, Length(FThumbs)+1);

  FThumbs[High(FThumbs)]:= TJPGThumb.create(nil);

  With FThumbs[High(FThumbs)] do

  begin

    Path:= APath;

    Pic:= FBufferImg;

  end;

end;


procedure TJPGBuffer.DrawTo(AParent: TWinControl);

var i, X, Y, AWidth: Integer;

begin

  X:= 10;

  Y:= 10;

  aWidth:= Aparent.Width;

  for i:= 0 to High(FThumbs) do

  begin

    with FThumbs[i] do

    begin

      Left:= X;

      Top:= Y;

      Width:= cThumbWidth;

      Height:= cThumbHeight;

      Parent:= AParent;

    end;

    Inc(X, cThumbWidth+5);

    if (X+cThumbWidth) > aWidth then

    begin

      x:= 10;

      Inc(Y, cThumbHeight+5);

    end;

  end;

end;


{TJPGThumb}


constructor TJPGThumb.create(AOwner: TComponent);

begin

  inherited;

  FPic:= TJPEGImage.create;

  BevelOuter:= bvRaised;

  FLblName:= TLabel.create(self);

  flblName.Parent:= self;

  FlblName.Height:= cBorderBottom;

  FlblName.Align:= alBottom;

  FlblName.Layout:= tlTop;

  FlblName.Alignment:= taCenter;

  OnEnter:= Enter;

  OnExit:= Exit;

  OnClick:= Click;

  OnDblClick:= DblClick;

  TabStop:= True;

end;


destructor TJPGThumb.destroy;

begin

  FPic.free;

  FlblName.free;

  inherited;

end;


procedure TJPGThumb.SetPic(APic: TJPEGImage);

begin

  FPic.scale:=jshalf;

  FPic.assign(APic);

  FPic.dibneeded;

end;


procedure TJPGThumb.paint;

var ARect : trect;

begin

  inherited;

  ARect.left:=ClientRect.Left+cBorderLeft;

  ARect.Top:= ClientRect.Top+cBorderTop;

  ARect.Right:= ClientRect.Right-cBorderRight;

  ARect.Bottom:= ClientRect.Bottom-cBorderBottom;

  canvas.stretchdraw(arect,FPic);

  frame3d(canvas,ARect,clblack,clwhite,2);

end;


procedure TJPGThumb.SetPath(APath: String);

begin

  FPath:= APath;

  FlblName.Caption:= ExtractFileName(APath);

end;


procedure TJPGThumb.Enter(Sender: TObject);

begin

  self.Color:= clSkyBlue;

end;


procedure TJPGThumb.Exit(Sender: TObject);

begin

  self.Color:= clBtnFace;

end;


procedure TJPGThumb.Click(Sender: TObject);

begin

  self.SetFocus;

end;


procedure TJPGThumb.DblClick(Sender: TObject);

begin

  if Assigned(frmView) then

    if frmView.Visible then

      frmView.close;

  frmView.free;

  frmView:= TfrmView.create(nil);

  frmView.FileName:= self.Path;

end;


initialization

  JPGBuffer:= TJPGBuffer.create;


finalization

  JPGBuffer.Free;


end.


und hier der Aufruf aus dem Formular:


// alle JPEG-Bilder aus dem Verz. der Anwendung laden

procedure TfrmBrowse.amiPicsExecute(Sender: TObject);

var sr: TSearchRec;

    DirPath: String;

begin

  DirPath:= ExtractFilePath(Application.ExeName);

  if FindFirst(DirPath+'\*.jpg', faAnyFile, sr) = 0 then

  begin

    JPGBuffer.Path:= sr.name;

    while FindNext(sr) = 0 do

      JPGBuffer.Path:= sr.name;

    FindClose(sr);

 end;

 Refresh;

end;


// Thumbnails anzeigen

procedure TfrmBrowse.FormPaint(Sender: TObject);

begin

  JPGBuffer.DrawTo(scbMain);

end;

ist nicht kommentiert (die beiden Kommentare habe ich gerade eingefügt), war aber auch nur ein kleines Projekt für mich privat und ist IMHO nicht so schwer zu verstehen.

Der Code ist hiermit Freeware... macht damit was ihr wollt :)

Hoffe es hilft dir, ist zwar nur für JPGs, eine Anpassung für andere sollte aber nicht soo schwer sein.

Anmerkung: scbMain ist eine TScrollBox, in der die Thumbnails angezeigt werden.

Nochwas, ist mit Delphi7 gemacht, sollte aber auch so (also bei anderen Versionen) gehen (kleinere Anpassungen vielleicht nötig, wüsste jetzt auf den ersten blick aber nichts...)

Link zu diesem Kommentar
Auf anderen Seiten teilen

Dein Kommentar

Du kannst jetzt schreiben und Dich später registrieren. Wenn Du ein Konto hast, melde Dich jetzt an, um unter Deinem Benutzernamen zu schreiben.

Gast
Auf dieses Thema antworten...

×   Du hast formatierten Text eingefügt.   Formatierung wiederherstellen

  Nur 75 Emojis sind erlaubt.

×   Dein Link wurde automatisch eingebettet.   Einbetten rückgängig machen und als Link darstellen

×   Dein vorheriger Inhalt wurde wiederhergestellt.   Editor leeren

×   Du kannst Bilder nicht direkt einfügen. Lade Bilder hoch oder lade sie von einer URL.

Fachinformatiker.de, 2024 by SE Internet Services

fidelogo_small.png

Schicke uns eine Nachricht!

Fachinformatiker.de ist die größte IT-Community
rund um Ausbildung, Job, Weiterbildung für IT-Fachkräfte.

Fachinformatiker.de App

Download on the App Store
Get it on Google Play

Kontakt

Hier werben?
Oder sende eine E-Mail an

Social media u. feeds

Jobboard für Fachinformatiker und IT-Fachkräfte

×
×
  • Neu erstellen...