imagefileselect.~pas

数字图像预出处理系统

unit ImageFileSelect;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, JPEG, StdCtrls, Buttons, ExtCtrls, FileCtrl,
  ComCtrls, ShellApi;
type
   EPowerException = class(Exception)
end;

type
  TImageSelectForm = class(TForm)
    DriveComboBox1: TDriveComboBox;
    DirectoryListBox1: TDirectoryListBox;
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    FileListBox1: TFileListBox;
    Image1: TImage;
    ImageSizeLabel: TLabel;
    procedure FileListBox1Click(Sender: TObject);
    procedure DriveComboBox1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure DirectoryListBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
     function DiskInDrive(Drive: Char): Boolean;
  public
     procedure Chargement(afichier : string);
  end;

  Function Power(X, N : real) : extended;
  Procedure FitRect(var arect : Trect;     // 矩形结构定义
                  var azoom : single;    // 放大系数
                  Wdest, Hdest,          // 图像的高和宽
                  Worig, Horig,          // 图像的高和宽的原点
                  aMargex, aMargey : integer;  // 图像的范围
                  bigger : boolean);

var
  ImageSelectForm: TImageSelectForm;

implementation

{$R *.DFM}

uses ImageProcessMainUnit;
var
  flag1 : boolean;

procedure TImageSelectForm.FormCreate(Sender: TObject);
begin
  flag1 := true;
end;

function TImageSelectForm.DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  if Drive in ['a'..'z'] then Dec(Drive, $20);  //大小字母适宜性
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
  finally
    SetErrorMode(ErrorMode);
  end;
end;
// 选择图像并给出图像的简图和大小
procedure TImageSelectForm.FileListBox1Click(Sender: TObject);
begin
  IF filelistbox1.items.count < 1 then exit;
  IF filelistbox1.filename = '' then exit;
  chargement(filelistbox1.filename);
  ImageSizeLabel.caption := '图像尺寸'+inttostr(WillbeChangedBmp.width) +' ,  ' +Inttostr(WillbeChangedBmp.height);
end;

Procedure TImageSelectForm.Chargement(afichier : string);
const
  K = 152;
Var
  fattr : integer;
  w0, h0 : single;
  w, h   : single;
  kk : single;
  ext : string;
begin
  fattr := Filegetattr(afichier);
  if fattr and fareadonly > 0 then
    showmessage('文件 '+afichier+' 是只读文件. '
    +' 当保存文件时发生错误');
  image1.picture.assign(nil);
  ext := uppercase(Extractfileext(afichier));
  // 只能是Jpg 或 bmp类型文件
  try
    Image1.Picture.LoadFromFile(afichier);
  except
    on EInvalidGraphic do
    begin
      Image1.Picture.Graphic := nil;
      exit;
    end;
  end;
  w0 := Image1.picture.graphic.width;
  h0 := Image1.picture.graphic.height;
  WillbeChangedBmp.free;
  WillbeChangedBmp := Tbitmap.create;
  WillbeChangedBmp.width  := Image1.picture.graphic.width;
  WillbeChangedBmp.height := Image1.picture.graphic.height;
  WillbeChangedBmp.pixelformat := pf24bit;
  WillbeChangedBmp.canvas.draw(0,0,Image1.picture.graphic);
  w := w0;
  h := h0;
  IF (w0 > K) OR (h0 > K) then
  begin
    KK := K;
    IF w0 > h0 then
    begin
      w := kk;
      h := (kk * h0) / w0;
    end
    else
    begin
      h := kk;
      w := (kk*w0) / h0;
    end;
  end;
  Image1.width  := Trunc(w);
  Image1.height := Trunc(h);
  // 图像在区域中间
  Image1.left := (Panel1.width  - Image1.width ) div 2;
  Image1.top  := (Panel1.height - Image1.height) div 2;
end;

procedure TImageSelectForm.DirectoryListBox1Change(Sender: TObject);
begin
  IF Diskindrive(Drivecombobox1.drive) = False Then
  Begin
    Showmessage('驱动设备没准备好');
    exit;
  end;
  Filelistbox1.Itemindex := 0;
  Filelistbox1click(sender);
  Filelistbox1.setfocus;
end;

procedure TImageSelectForm.DriveComboBox1Click(Sender: TObject);
begin
 IF Diskindrive(Drivecombobox1.drive) = False Then
  Begin
    Showmessage('CD-ROM or floppy not ready');
    exit;
  end;
end;

procedure TImageSelectForm.FormActivate(Sender: TObject);
begin
  image1.visible := true;
  if flag1 then
  begin
    if directoryexists(CurrentDir) then Directorylistbox1.directory := CurrentDir;
  end
  else
  begin
     if ImageSelectForm.filelistbox1.itemindex <  ImageSelectForm.filelistbox1.items.count-1 then
     ImageSelectForm.filelistbox1.itemindex :=  ImageSelectForm.filelistbox1.itemindex+1
    else messagebeep(1);
  end;
  if flag1 then if filelistbox1.items.count > 1 then Filelistbox1.Itemindex := 0;
  if filelistbox1.items.count > 1 then filelistbox1.topindex := filelistbox1.itemindex -1;
  Filelistbox1click(sender);
  Filelistbox1.setfocus;
  flag1 := false;
end;

function Power(X, N : real) : extended;
var
  t : longint;
  r : real;
  isInteger : boolean;
begin
   if N = 0 then begin result := 1.0;  exit;  end;
   if X = 1.0 then begin result := 1.0;  exit; end;
   if X = 0.0 then
   begin
     if N > 0.0 then
     begin
       result := 0.0;
       exit;
     end
     else
       raise EPowerException.Create('Infinite Result');
     end;
     if (X > 0) then
     try
       result := exp(N * ln(X));
       exit;
     except
       raise EPowerException.Create('Overflow/Underflow Result');
     end;
     try
       t := trunc(n);
       if (n - t) = 0 then isInteger := true else isInteger := False;
     except
         r := int(n);
       if (n - r) = 0 then
       begin
         isInteger := true;
         if frac(r/2) = 0.5 then t := 1 else t := 2;
       end
       else
       begin
         t := 0;
         isInteger := False;
       end;
    end;
    if isInteger then
    begin  {n is an integer}
      if odd(t) then {n is odd}
      try
        result := -exp(N * ln(-X));
        exit;
      except
        raise EPowerException.Create('Overflow/Underflow Result');
      end
      else         {n is even}
      try
        result := exp(N * ln(-X));
        exit;
      except
        raise EPowerException.Create('Overflow/Underflow Result');
      end;
    end
  else
  raise EPowerException.Create('Complex Result');
end;

// 图像放入合适的矩形区域
// 保留长宽比
Procedure FitRect(var arect : Trect;
                  var azoom : single;
                  Wdest, Hdest,
                  Worig, Horig,
                  aMargex, aMargey : integer;
                  bigger : boolean);
                                     
var
  kw, kh : single;
  wd, hd, wo, ho : single;
  w , h : integer;
begin
  if (worig < 1) or (horig < 1) or (wdest < 1) or (hdest < 1) then
  begin
    arect.left   := 0;
    arect.top    := 0;
    arect.right  := 0;
    arect.bottom := 0;
    azoom := 1;
    exit;
  end;
    if (bigger = false) and
     (worig <= wdest-amargex*2) and (horig <= hdest-amargey*2) then
  begin
    w := worig;
    h := horig;
    azoom := 1;
  end
  else
  begin
    wd := wdest - amargex*2;
    hd := hdest - amargey*2;
    wo := worig;
    ho := horig;
    kw := wd / wo;
    kh := hd / ho;
    if kw < kh then azoom := kw else azoom := kh;
    w := round(wo*azoom);  h := round(ho*azoom);
  end;
  arect := bounds((wdest-w) div 2, (hdest-h) div 2, w, h);
end;

procedure TImageSelectForm.CheckBox1Click(Sender: TObject);
begin
  chargement(filelistbox1.filename);
end;

procedure TImageSelectForm.DirectoryListBox1Click(Sender: TObject);
begin
  Directorylistbox1.opencurrent;
end; 
end.