setfrm.pas

一个酒店房间图片介绍的小软件

unit setfrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellApi, ImgList, ExtCtrls,jpeg, Spin;

type
  TForm2 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    ListBox1: TListBox;
    ScrollBox1: TScrollBox;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    Button7: TButton;
    ColorBox1: TColorBox;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure oncreate(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure onclose(Sender: TObject; var Action: TCloseAction);
    procedure onactive(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure ColorBox1Change(Sender: TObject);
    procedure onexit(Sender: TObject);
   
  private
    { Private declarations }

  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  preimage:array[1..30] of TImage;
  prebitmap:array[1..30] of TBitmap;
  nimage:integer;
  selectimg:integer;
  currentdiridx:integer;

    procedure deldir(dirname:string);
    procedure RenameDir(DirFrom, DirTo: string);
    function LoadThumb(filename:shortstring):TBitmap;
    function CopyFile(const sourcefilename, targetfilename: string):integer;
implementation

{$R *.dfm}

uses
   main;


procedure TForm2.Button1Click(Sender: TObject);
var
   temp:string;
   newpath:string;
begin
//showmessage(workpath);
//listBox1.Items.Add('我真酷');
temp:=inputbox('增加房间标准','请输入房间标准','');
if temp<>'' then
begin
newpath:=workpath+'\'+temp;

 if not DirectoryExists(newpath) then
    if not CreateDir(newpath) then
    raise Exception.Create('创建目录失败');
 n:=n+1;
 room[n]:=temp;
 writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
 listbox1.Items.Add(temp);
end;
end;

procedure TForm2.Button2Click(Sender: TObject);
var
   i:integer;
   temp:string;
begin
i:=listbox1.ItemIndex;
if i>=0 then
begin
deldir(room[i+1]);
listbox1.Items.Delete(i);
n:=n-1;
if n>0 then

for i:=1 to n do
//room[i]:=listbox1.Items.ValueFromIndex[i-1];
 room[i]:=listbox1.Items.Strings[i-1];

room[n+1]:='';
writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
end;
end;

procedure TForm2.oncreate(Sender: TObject);
var
   i:integer;
begin
 nimage:=0;
 readroom(filepath,n,sysfont,welcomeword,room,imgnumber);
 if n>0 then

 for i:=1 to n do
   listbox1.Items.Add(room[i]);
  //listbox1.ItemIndex:=0;
   //ListBox1Click(self);
end;

procedure deldir(dirname:string);
var
  found:integer;
  sr:TSearchRec;
  temp:string;

begin
 temp:=workpath+'\'+dirname+'\*.*';
Found := FindFirst(temp, faArchive, sr);
     while Found = 0 do
     begin
     temp:=workpath+'\'+dirname+'\'+sr.Name;
     DeleteFile(temp);
     Found := FindNext(sr);
     end;
     FindClose(sr);
     temp:=workpath+'\'+dirname;
     RemoveDir(temp);
end;


procedure TForm2.Button3Click(Sender: TObject);
var
  i:integer;
  DirFrom, DirTo,temp: string;
  ok:boolean;
begin
i:=listbox1.ItemIndex;
if i>=0 then
 begin
 temp:=inputbox('修改房间标准','请输入新的房间标准         ','');
 if temp<>'' then
 begin
 DirFrom:=workpath+'\'+room[i+1];
 //chdir(DirFrom);
 DirTo:=workpath+'\'+temp;
 //showmessage(getcurrentdir);
 //RenameDir(DirFrom, DirTo);
 if not MoveFile(PChar(DirFrom), PChar(DirTo)) then
    ShowMessage(SysErrorMessage(GetLastError))
  else
    ShowMessage('更改房间标准成功');
 room[i+1]:=temp;
 writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
 //listbox1.Items.Text:=temp;
 listbox1.Items.Strings[i]:=temp;
//ok:=setcurrentdir(DirTo);
// if ok then
// showmessage('ok');
 end;
 end;
end;

procedure RenameDir(DirFrom, DirTo: string);
var
  shellinfo: TSHFileOpStruct; 
begin 
  with shellinfo do 
  begin 
    Wnd    := 0; 
    wFunc  := FO_RENAME; 
    pFrom  := PChar(DirFrom); 
    pTo    := PChar(DirTo); 
    fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or 
              FOF_SILENT or FOF_NOCONFIRMATION;
  end; 
  SHFileOperation(shellinfo); 
end; 



procedure TForm2.Button4Click(Sender: TObject); //添加图片
var
  //infname:string;
  F:TShFileOpStruct;
  i,j,k:integer;
  fileFrom, fileTo,temp: string;
  dirname:string;
   ajpeg:Tjpegimage;
   w,h:integer;
   fbitmap:TBitmap;
begin
  i:=listbox1.ItemIndex ;
   k:=imgnumber[i+1];
  if i>=0 then
  begin
  fileto:=workpath+'\'+room[i+1]+'\'+IntToStr(k+1)+'.jpg';
  if OpenDialog1.Execute then
      begin
      fileFrom:= OpenDialog1.FileName;

F.wnd:=0;
F.wFunc:= FO_COPY; {操作方式}
F.pFrom:=pchar(fileFrom);
F.pTo:=pchar(fileto);
//F.fFlags:=FOF_ALLOWUNDO OR FOF_RENAMEONCOLLISION;
F.fFlags:=FOF_SILENT or FOF_NOCONFIRMATION or FOF_ALLOWUNDO OR FOF_RENAMEONCOLLISION; {操作选项}

//if ShFileOperation(F)<>0 then
if copyfile(filefrom,fileto)<>0 then
ShowMessage('文件拷贝失败!')
else
begin
imgnumber[i+1]:=k+1;
 writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);



 //显示刚加入的图片
// selectimg:=0;
 ajpeg:=Tjpegimage.Create;
 fbitmap:=Tbitmap.Create;
 fbitmap.PixelFormat:=pf24bit;
  i:=nimage+1;
  //temp:=workpath+'\'+dirname+'\'+sr.Name;
     // fbitmap:=LoadThumb(temp);
     ajpeg.LoadFromFile(fileto);
     fbitmap.Assign(ajpeg);
     ajpeg.Scale:=jsQuarter;
     w:=ajpeg.Width;
     h:=ajpeg.Height;

     preimage[i]         := TImage.Create(form2.scrollbox1);
     prebitmap[i]:=Tbitmap.Create;
     prebitmap[i].PixelFormat:=pf24bit;
    preimage[i].Enabled := True;
    preimage[i].parent  := form2.scrollbox1;
    preimage[i].Tag     :=  i;
    preimage[i].Visible := True;

   // preimage[i].top     := (i - 1) * 200;
   if i>1then
     preimage[i].top     :=preimage[i-1].top+200
     else
     preimage[i].top     :=0;
    if w>h then
     begin
     preimage[i].Width :=200;
     preimage[i].Height:=trunc(200/w*h);
     end
     else
     begin
     preimage[i].Height:=200;
     preimage[i].Width:=trunc(200/h*w);
     end;
      preimage[i].Left    := trunc((200- preimage[i].Width)/2);
     prebitmap[i].Width:=preimage[i].Width;
     prebitmap[i].Height:=preimage[i].Height;
     prebitmap[i].Canvas.StretchDraw(rect(0,0,preimage[i].Width,preimage[i].Height),fbitmap);
    preimage[i].Stretch:=true;
    preimage[i].OnClick :=form2.Image1Click;
  //StretchBlt(sbitmap.Canvas.Handle,0,0,preimage[i].Width,preimage[i].Height,fbitmap.Canvas.Handle,0,0,w,h,srccopy);
   //preimage[i].Picture.Assign(fbitmap);
     preimage[i].Canvas.Draw(0,0,prebitmap[i]);
     nimage:=i;
     fbitmap.Free;
   ajpeg.Free;
   end;
   end;
 end;

end;

procedure TForm2.ListBox1Click(Sender: TObject);
var
  i,j,k:integer;
  found:integer;
  sr:TSearchRec;
  temp,dirname:string;
   ajpeg:Tjpegimage;
   w,h:integer;
   fbitmap:TBitmap;

begin
 selectimg:=0;
 ajpeg:=Tjpegimage.Create;
 fbitmap:=Tbitmap.Create;

  fbitmap.PixelFormat:=pf24bit;

  if nimage>0 then
  for i:=1 to nimage do
  begin
  preimage[i].Free;
  prebitmap[i].Free;
  end;
  i:=1;
  
  k:=listbox1.ItemIndex;
  if k>=0 then
  begin
  dirname:=room[k+1];
  currentdiridx:=k+1;
  temp:=workpath+'\'+dirname+'\*.*';
Found := FindFirst(temp, faArchive, sr);
     while Found = 0 do
     begin
     temp:=workpath+'\'+dirname+'\'+sr.Name;
     // fbitmap:=LoadThumb(temp);
     ajpeg.LoadFromFile(temp);


      ajpeg.Scale:=jsQuarter;
      fbitmap.Assign(ajpeg);
     w:=ajpeg.Width;
     h:=ajpeg.Height;

     preimage[i]         := TImage.Create(form2.scrollbox1);
     prebitmap[i]:=Tbitmap.Create;
     prebitmap[i].PixelFormat:=pf24bit;
    preimage[i].Enabled := True;
    preimage[i].parent  := form2.scrollbox1;
    preimage[i].Tag     :=  i;
    preimage[i].Visible := True;

    preimage[i].top     := (i - 1) * 200;

    if w>h then
     begin
     preimage[i].Width :=200;
     preimage[i].Height:=trunc(200/w*h);
     end
     else
     begin
     preimage[i].Height:=200;
     preimage[i].Width:=trunc(200/h*w);
     end;
      preimage[i].Left    := trunc((200- preimage[i].Width)/2);
     prebitmap[i].Width:=preimage[i].Width;
     prebitmap[i].Height:=preimage[i].Height;

     prebitmap[i].Canvas.StretchDraw(rect(0,0,preimage[i].Width,preimage[i].Height),fbitmap);
    preimage[i].Stretch:=true;
    preimage[i].OnClick :=form2.Image1Click;

     preimage[i].Canvas.Draw(0,0,prebitmap[i]);


     inc (i);

     Found := FindNext(sr);
     end;
     nimage:=i-1;
     FindClose(sr);
   end;

    fbitmap.Free;
   ajpeg.Free;

end;




procedure TForm2.Image1Click(Sender: TObject);
var
  t,w,h,i:integer;

begin
  //ShowMessage(IntToStr(Timage(Sender).tag));
  t:=Timage(Sender).tag;
  w:= preimage[t].Picture.Width;
  h:= preimage[t].Picture.Height;
  // preimage[t].Canvas.Pen.Mode := pmnop	;
  preimage[t].Canvas.Pen.Color:=clblue;
   preimage[t].Canvas.Pen.Width:=2;
   preimage[t].Canvas.Pen.Style:=psSolid;
   preimage[t].Canvas.Brush.Style:=bsclear;
   for i:= 1 to nimage do
  preimage[i].Canvas.Draw(0,0,prebitmap[i]);
  //preimage[i].Picture.Assign(prebitmap[i]);
  //preimage[i].Repaint;
  preimage[t].Canvas.Rectangle(1,1,w-1,h-1);
   selectimg:=t;

end;

procedure TForm2.onclose(Sender: TObject; var Action: TCloseAction);
var
   i:integer;
begin
   if nimage>0 then

   for i:=1 to nimage do
   begin
   prebitmap[i].Free;
   preimage[i].Free;
   end;
   nimage:=0;
end;

procedure TForm2.onactive(Sender: TObject);
begin
  //nimage:=0;
  spinedit1.Value:=sysfont.Size;

end;



function LoadThumb(filename:shortstring):TBitmap;
procedure BGR2RGB(var bmp:TBitmap);
var
x,y:integer; t:char; data:pchar;
begin
for y:=bmp.Height-1 downto 0 do
begin
data:=bmp.ScanLine[y];
for x:=0 to bmp.Width-1 do
begin
t:=data[x*3];
data[x*3]:=data[x*3+2];
data[x*3+2]:=t;
end;
end;
end;
var
fstream:Tfilestream; mstream:Tmemorystream;
j,i:word;data:pchar; buf:array [0..3] of byte;
filesize:DWORD; fjpg:Tjpegimage;bmp:Tbitmap;
begin
result:=nil;
fstream:=Tfilestream.create(filename,fmOpenRead);
//建立文件流，读JPEG文件
fstream.Seek(20,soFromBeginning); //FF ED段在文件的第20个字节处
fstream.Read(buf,sizeof(buf));
if PWORD(@buf[0])^=$edff then
begin
j:=buf[2]*256+buf[3]; //FF ED的大小，高位在前，低位在后
if j<1024 then //FF ED段的大小若为1024个字节则文件不包含缩览图，退出程序
begin
fstream.free;
exit;
end;
mstream:=TMemorystream.Create;//建立内存流
mstream.CopyFrom(fstream,j); //把FF ED段拷贝到mstream
data:=mstream.Memory;
for i:=300 to 700 do //找缩览图的开始标志FF D8
if PWORD(@data[i])^=$D8FF then break;
if i<700 then
begin
fjpg:=Tjpegimage.Create; //建立TJPEGimage 解出缩览图
bmp:=TBitmap.Create;
mstream.Position:=i;
fjpg.LoadFromStream(mstream);//fjpg读取mstream
bmp.Assign(fjpg); //JPEG转BMP
if PWORD(@data[i+57])^=$2e34 then //PhotoShop 4.0的缩览图
BGR2RGB(bmp); //BMP的像素格式BGR 而不是RGB,要把BGR转化为RGB
result:=bmp; //函数返回BMP
mstream.Free;
fjpg.Free; //释放Object
end;
end;
fstream.free;
end;



procedure TForm2.Button5Click(Sender: TObject); //删除图片
var
  i:integer;
  w,h,t,l:integer;
  temp:string;
  filefrom,fileto:string;
  isdelete:boolean;
begin
 if selectimg>0 then
 begin
 temp:=workpath+'\'+room[currentdiridx]+'\'+inttostr(selectimg)+'.jpg';
 isdelete:=deletefile(temp);
 if selectimg<nimage then
 for i:=selectimg to nimage-1 do
  begin
  Application.ProcessMessages;

  prebitmap[i].Assign(prebitmap[i+1]);
  w:=preimage[i+1].Width;
  preimage[i].Width:=w;
  h:=preimage[i+1].Height;
  preimage[i].Height:=h;
  t:=preimage[i+1].Top-200;
  preimage[i].Top:=t;
  l:=preimage[i+1].Left;
  preimage[i].Left:=l;
  preimage[i].Picture.Assign(prebitmap[i]);
  //preimage[i].Canvas.Draw(0,0,prebitmap[i]);
 //  preimage[i].Refresh;
 // preimage[i].Assign(preimage[i+1]);
  //preimage[i].Canvas.Draw(0,0,prebitmap[i]);
   filefrom:=workpath+'\'+room[currentdiridx]+'\'+inttostr(i+1)+'.jpg';
   fileto:=workpath+'\'+room[currentdiridx]+'\'+inttostr(i)+'.jpg';
  renamefile(filefrom,fileto);
  end;

  prebitmap[nimage].Free;
  preimage[nimage].Free;
  selectimg:=0;
  nimage:=nimage-1;
  imgnumber[currentdiridx]:=nimage;
   writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
  //for i:= 1 to nimage do
 // preimage[i].Repaint;
 // form2.Repaint;
 end;

end;

function CopyFile( Const sourcefilename, targetfilename: String):integer;
Var
S, T: TFileStream;
Begin
result:=1;
S := TFileStream.Create( sourcefilename, fmOpenRead );
try
T := TFileStream.Create( targetfilename,fmOpenWrite or fmCreate );
try
T.CopyFrom(S, S.Size ) ;
finally
T.Free;
end;
finally
S.Free;
result:=0;
end;
End;



procedure TForm2.Button6Click(Sender: TObject);
var
temp:string;
begin
  readroom(filepath,n,sysfont,welcomeword,room,imgnumber);
 temp:=inputbox('修改房问候语',pchar('请输入新的问候语        '),welcomeword);
 if temp<>'' then
 welcomeword:=temp;
  writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
 end;

procedure TForm2.Button7Click(Sender: TObject);
var
 newfile:string;
 temp:string;
begin
 temp:=workpath+'\welcome.jpg';
if opendialog1.Execute then
begin
  newfile:=opendialog1.FileName;
  if fileexists(temp) then
  deletefile(temp);
  copyfile(newfile,temp);


end;

end;

procedure TForm2.ColorBox1Change(Sender: TObject);
var
 i:integer;
begin
i:=colorbox1.ItemIndex;
sysfont.Color:=colorbox1.Colors[i];
writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
end;

procedure TForm2.onexit(Sender: TObject);
begin
 sysfont.Size:=spinedit1.Value;
 writeroom(filepath,n,sysfont,welcomeword,room,imgnumber);
end;

end.