{Programı Delphi 6'da hazırladım.Delphi 5'dede çalışır yanlız Treview (TRView1)}
{nesnesinin yerine DirectoryListBox nesnesi koyarsanız TRView1 yazan kodları }
{DirectorList olarak değiştirmeyi unutmayın.Bazı hatalar olsada işe yarayacak }
{form1.dcu altta yer almaktadır }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, ExtCtrls, ExtDlgs,Jpeg, StdCtrls, FileCtrl, Db, DBTables,Math,
ComCtrls,Grids, DBGrids, ShellCtrls;
type
TForm1 = class(TForm)
Boxed: TScrollBox;
Splitter1: TSplitter;
Shape1: TShape;
Panel2: TPanel;
Boxer: TScrollBox;
Image1: TImage;
Splitter2: TSplitter;
Flist1: TFileListBox;
Panel1: TPanel;
PBar1: TProgressBar;
Table1: TTable;
Source1: TDataSource;
Table1ADI: TStringField;
Table1PIC: TBlobField;
TrView1: TShellTreeView;
procedure ResimOnClick(Sender : TObject);
procedure FormCreate(Sender: TObject);
procedure BoxedResize(Sender: TObject);
procedure BoxedClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure nThumbs(Sender: TObject);
procedure Free;
procedure LoadPicture;
procedure FormDestroy(Sender: TObject);
procedure TrView1Change(Sender: TObject; Node: TTreeNode);
private
{ Private declarations }
MyJpg : TJpegImage;
MyBmp : TBitmap;
MyImg : TImage;
Names : Array Of TLabel;
Resim : Array Of TImage;
frmDurum,Durum : Boolean;
Cnt,Toplam,Dik,Yat : LongInt;
Kaynak,Yol : String;
Strm : TMemoryStream;
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.DFM}
procedure TForm1.ResimOnClick(Sender : TObject);
var I : LongInt;
begin
Shape1.Visible:=False;
for I:=0 to Cnt-1 do begin
Names[I].Color:=clWindow;
Names[I].Font.Color:=clbtnText;
end;
For I:=0 to Cnt-1 do
If Sender=Resim[I] then begin
Shape1.Left:=Resim[I].Left-2;
Shape1.Width:=Resim[I].Width+4;
Shape1.Top:=Resim[I].Top-2;
Shape1.Height:=Resim[I].Height+4;
Shape1.Visible:=True;
Names[I].Color:=clHighlight;
Names[I].Font.Color:=clHighlightText;
If Sender=Boxed then exit;
Image1.Picture.LoadFromFile(TRView1.Path+'\'+Names[I].Caption);
end;
end;
procedure TForm1.Free;
begin
Durum:=False;Toplam:=0;Dik:=0;Yat:=0;
Shape1.Visible:=False;
while Boxed.ComponentCount>0 do
Boxed.components[0].free;
Image1.Picture:=nil;
Boxed.Update;
end;
procedure TForm1.LoadPicture;
begin
try
if Durum=True then Free;
SetLength(Resim,Toplam+Cnt);
SetLength(Names,Toplam+Cnt);
Boxed.HorzScrollBar.Position:=0;
Boxed.VertScrollBar.Position:=0;
Table1.Active:=False;
Table1.DatabaseName:=Yol;
Table1.TableName:='picture.db';
Table1.Active:=True;
PBar1.Position:=0;
PBar1.Max:=Table1.RecordCount-1;
PBar1.Visible:=True;
Table1.First;
while not Table1.eof do begin
Resim[Toplam]:=TImage.Create(Boxed);
Resim[Toplam].Parent:=Boxed;
Resim[Toplam].Width:=96;
Resim[toplam].Height:=96;
Resim[Toplam].OnClick:=ResimOnClick;
Resim[Toplam].Top:=(130*Dik)+10;
Resim[Toplam].Left:=(120*Yat)+10;
If (Resim[Toplam].Left+Resim[Toplam].Width) > Boxed.Width then begin
Inc(Dik);yat:=0;
Resim[Toplam].Top:=(130*Dik)+10;
Resim[Toplam].Left:=(120*Yat)+10;
end;
Strm:=TMemoryStream.Create;
MyJpg:=TJpegImage.Create;
Table1PIC.SaveToStream(Strm);
Strm.Position:=0;
MyJpg.LoadFromStream(Strm);
Resim[Toplam].Picture.Graphic:=MyJpg;
Strm.Free;
Names[Toplam]:=TLabel.Create(Boxed);
Names[Toplam].ShowAccelChar:=False;
Names[Toplam].Caption:=Table1.FieldByName('ADI').AsString;
Names[Toplam].Left:=Resim[Toplam].Left+(Resim[Toplam].Width div 2 - Names[Toplam].Width div 2);
Names[Toplam].Top:=Resim[Toplam].Top+Resim[Toplam].Width+4;
Names[Toplam].AutoSize:=True;
Names[Toplam].Parent:=Boxed;
Names[Toplam].Color:=clWindow;
Names[Toplam].Font.Color:=clbtntext;
Inc(Toplam);Inc(Yat);
PBar1.Position:=PBar1.Position+1;
Table1.Next;
end;
Durum:=True;
finally
PBar1.Visible:=False;
end;
end;
procedure TForm1.nThumbs(Sender: TObject);
var
Z : Real;
nRect,R : TRect;
J,Lft,Rgt : LongInt;
Wdth,Hght : LongInt;
begin
if FList1.Items.Count=0 then Free;
if FList1.Items.Count <> 0 then begin
Cnt:=FList1.Items.Count;
Yol:=TRView1.Path;
if FileExists(Yol+'\picture.db') then
LoadPicture
else begin
try
Table1.Active:=False;
CopyFile(Pchar(Kaynak+'\picture.db'), PChar(Yol+'\picture.db'), True);
CopyFile(Pchar(Kaynak+'\picture.mb'), PChar(Yol+'\picture.mb'), True);
Table1.DatabaseName:=Yol;
Table1.TableName:='picture.db';
Table1.Active:=True;
PBar1.Position:=0;
PBar1.Max:=Cnt-1;
PBar1.Visible:=True;
for j:=0 to Cnt-1 do begin
MyJpg := TJpegImage.Create;
MyBmp := TBitmap.Create;
MyImg := TImage.Create(nil);
MyImg.Picture.LoadFromFile(FList1.Items[J]);
Wdth:=MyImg.Picture.Width;
Hght:=MyImg.Picture.Height;
Z:=2.0;
PBar1.Position:=PBar1.Position+1;
repeat
MyImg.Width:=Ceil(Wdth/Z);
MyImg.Height:=ceil(Hght/Z);
Z:=Z+0.4;
until (MyImg.Width<=95) and (MyImg.Height<=95);
Lft:=48-(MyImg.Width div 2);
Rgt:=48-(MyImg.Height div 2);
R:=Rect(0,0,96,96);
nRect := Rect(Lft, Rgt, Lft+MyImg.Width, Rgt+MyImg.Height);
MyJpg.LoadFromFile(FList1.Items[J]);
MyBmp.Canvas.Pen.Style:=psSolid;
MyBmp.Canvas.Pen.Color:=clWhite;
MyBmp.Canvas.Rectangle(R);
with MyBmp do begin
Width := 96;Height := 96;
Canvas.StretchDraw(nRect,MyJpg);
MyBmp.Canvas.Pen.Style:=psSolid;
MyBmp.Canvas.Pen.Color:=clSilver;
MyBmp.Canvas.Brush.Style:=bsClear;
MyBmp.Canvas.Rectangle(R);
MyJpg.Smoothing:=True;
MyJpg.CompressionQuality:=80;
MyJpg.Compress;
MyJpg.Assign(MyBmp);
Strm:= TMemoryStream.Create;
MyJpg.SaveToStream(Strm);
Table1.Insert;
Table1ADI.AsString:=ExtractFileName(FList1.Items[J]);
Strm.Position:=0;
Table1PIC.LoadFromStream(Strm);
Table1.Post;
Strm.Free;
end;
end;
finally
MyJpg.Free;
MyBmp.Free;
end;
LoadPicture;
PBar1.Visible:=False;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Boxed.DoubleBuffered:=True;
Toplam:=0;Dik:=0;Yat:=0;Cnt:=0;
Durum:=False;frmDurum:=False;
Kaynak:=ExtractFilePath(Application.ExeName);Yol:='';
end;
procedure TForm1.BoxedResize(Sender: TObject);
Var Tplm,Dk,Yt,I :LongInt;
begin
If frmDurum=True then begin
Shape1.Visible:=False;
Tplm:=0;Dk:=0;Yt:=0;
Boxed.VertScrollBar.Position:=0;
Boxed.HorzScrollBar.Position:=0;
for I:=0 to Cnt-1 do begin
Resim[Tplm].Top:=(130*Dk)+10;
Resim[Tplm].Left:=(120*Yt)+10;
If (Resim[Tplm].Left+Resim[Tplm].Width) > Boxed.Width then begin
Inc(Dk);Yt:=0;
Resim[Tplm].Top:=(130*Dk)+10;
Resim[Tplm].Left:=(120*Yt)+10;
end;
Names[Tplm].Left:=Resim[Tplm].Left+(Resim[Tplm].Width div 2 - Names[Tplm].Width div 2);
Names[Tplm].Top:=Resim[Tplm].Top+Resim[Tplm].Width+4;
Inc(Tplm);Inc(Yt);
end;
frmDurum:=False;
end;
If (Durum=False) then exit;
Shape1.Visible:=False;
ResimOnClick(Boxed);
Boxed.HorzScrollBar.Position:=0;
Boxed.VertScrollBar.Position:=0;
Tplm:=0;Dk:=0;Yt:=0;
for I:=0 to Cnt-1 do begin
Resim[Tplm].Top:=(130*Dk)+10;
Resim[Tplm].Left:=(120*Yt)+10;
If (Resim[Tplm].Left+Resim[Tplm].Width) > Boxed.Width then begin
Inc(Dk);Yt:=0;
Resim[Tplm].Top:=(130*Dk)+10;
Resim[Tplm].Left:=(120*Yt)+10;
end;
Names[Tplm].Left:=Resim[Tplm].Left+(Resim[Tplm].Width div 2 - Names[Tplm].Width div 2);
Names[Tplm].Top:=Resim[Tplm].Top+Resim[Tplm].Width+4;
Inc(Tplm);Inc(Yt);
end;
end;
procedure TForm1.BoxedClick(Sender: TObject);
Var I : LongInt;
begin
Shape1.Visible:=False;
for I:=0 to Cnt-1 do begin
Names[I].Color:=clWindow;
Names[I].Font.Color:=clbtntext;
end;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
frmDurum:=True;
BoxedResize(Sender);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Table1.Active:=False;
end;
procedure TForm1.TrView1Change(Sender: TObject; Node: TTreeNode);
begin
Flist1.Directory:=TRView1.Path;
nThumbs(Sender);
end;
end.
{******************************************************************************}
object Form1: TForm1
Left = 280
Top = 116
Width = 664
Height = 543
Caption = 'Resim Kutusu'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Splitter1: TSplitter
Left = 193
Top = 0
Width = 3
Height = 491
Cursor = crHSplit
Beveled = True
end
object Boxed: TScrollBox
Left = 196
Top = 0
Width = 460
Height = 401
Align = alClient
HorzScrollBar.Smooth = True
VertScrollBar.Smooth = True
VertScrollBar.Tracking = True
Color = clWindow
ParentColor = False
TabOrder = 0
OnClick = BoxedClick
OnResize = BoxedResize
object Shape1: TShape
Left = 160
Top = 0
Width = 65
Height = 65
Brush.Style = bsClear
Pen.Color = clHighlight
Pen.Width = 2
Visible = False
end
object Flist1: TFileListBox
Left = 0
Top = 0
Width = 145
Height = 217
ItemHeight = 13
Mask = '*.gif;*.jpg;*.jpeg;*.bmp;*.ico;*.emf;*.wmf;'
MultiSelect = True
TabOrder = 0
Visible = False
end
end
object Panel2: TPanel
Left = 0
Top = 0
Width = 193
Height = 491
Align = alLeft
BevelOuter = bvNone
TabOrder = 1
object Splitter2: TSplitter
Left = 0
Top = 257
Width = 193
Height = 3
Cursor = crVSplit
Align = alTop
end
object Image1: TImage
Left = 0
Top = 260
Width = 193
Height = 231
Align = alClient
Center = True
DragMode = dmAutomatic
Stretch = True
end
object TrView1: TShellTreeView
Left = 0
Top = 0
Width = 193
Height = 257
ObjectTypes = [otFolders]
Root = 'rfDesktop'
UseShellImages = True
Align = alTop
AutoRefresh = True
Indent = 19
ParentColor = False
RightClickSelect = True
ShowRoot = False
TabOrder = 0
OnChange = TrView1Change
end
end
object Panel1: TPanel
Left = 0
Top = 491
Width = 656
Height = 18
Align = alBottom
BevelOuter = bvLowered
TabOrder = 2
object PBar1: TProgressBar
Left = 1
Top = 1
Width = 150
Height = 16
Align = alLeft
Min = 0
Max = 100
Smooth = True
TabOrder = 0
Visible = False
end
end
object Table1: TTable
Left = 390
Top = 242
object Table1ADI: TStringField
FieldName = 'ADI'
Size = 255
end
object Table1PIC: TBlobField
FieldName = 'PIC'
Size = 240
end
end
object Source1: TDataSource
DataSet = Table1
Left = 360
Top = 240
end
end