Bu unit program resim listesi işleminde kullanılır.
Kod: Tümünü seç
unit ads_ImageLib;
interface
(*
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, FileCtrl, TMultiP, ComCtrls, Menus, Buttons, Resize;
*)
Uses
Windows,
//Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
TMultiP
;
Function ResizeImageBestFit(
PMultiImage : TPMultiImage;
Height : Integer;
Width : Integer): Boolean;
Function ResizeImageKeepProportions(
PMultiImage : TPMultiImage;
NewDimension : Integer;
IsWidth : Boolean): Boolean;
Function IL_SaveAsDlg(
PMultiImage : TPMultiImage;
Quality : Integer): Boolean;
Function IL_SaveAs(
PMultiImage : TPMultiImage;
inQuality : Integer;
sgFileName : String;
sgExt : String;
sgFileDir : String): Boolean; OverLoad;
Function IL_SaveAs(
PMultiImage : TPMultiImage;
inQuality : Integer;
FileName : String): Boolean; OverLoad;
implementation
Function IL_SaveAs(
PMultiImage : TPMultiImage;
inQuality : Integer;
sgFileName : String;
sgExt : String;
sgFileDir : String): Boolean;
Var
sgFullFile : String;
begin
Try
PMultiImage.JPegSaveQuality := inQuality;
If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
sgFileDir := sgFileDir + '\';
sgExt := UpperCase(sgExt);
sgFullFile := sgFileDir + sgFileName;
screen.cursor := crHourGlass;
If sgExt = '.BMP' Then PMultiImage.SaveAsBMP(sgFullFile);
If sgExt = '.EPS' Then PMultiImage.SaveAsEPS(sgFullFile);
If sgExt = '.GIF' Then PMultiImage.SaveAsGIF(sgFullFile);
If sgExt = '.JPEG' Then PMultiImage.SaveAsJpg(sgFullFile);
If sgExt = '.JPG' Then PMultiImage.SaveAsJpg(sgFullFile);
If sgExt = '.PCX' Then PMultiImage.SaveAsPcx(sgFullFile);
If sgExt = '.PNG' Then PMultiImage.SaveAsPNG(sgFullFile);
If sgExt = '.TGA' Then PMultiImage.SaveAsTGA(sgFullFile);
If sgExt = '.TIF' Then PMultiImage.SaveAsTIF(sgFullFile);
If sgExt = '.SCM' Then PMultiImage.SaveCurrentMessage(sgFullFile);
If sgExt = '.CMS' Then PMultiImage.SaveCurrentCreditMessage(sgFullFile);
PMultiImage.ImageName := sgFullFile;
screen.cursor:=crDefault;
Result := True;
Except
Result := False;
End;
end;
Function IL_SaveAsDlg(
PMultiImage : TPMultiImage;
Quality : Integer): Boolean;
Var
sgFileName : String;
sgExt : String;
sgFileDir : String;
SaveDialog : TSaveDialog;
begin
Result := False;
Try
SaveDialog := TSaveDialog.Create(nil);
Try
sgFileDir := ExtractFileDir(PMultiImage.ImageName);
If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
sgFileDir := sgFileDir + '\';
sgFileName := ExtractFileName(PMultiImage.ImageName);
sgExt := UpperCase(ExtractFileExt(sgFileName));
SaveDialog.InitialDir := sgFileDir;
If PMultiImage.BFileType = 'SCM' Then
Begin
SaveDialog.Filename:='*.SCM';
SaveDialog.Filter:='Scroll message|*.scm';
End
Else
Begin
If PMultiImage.BFileType = 'CMS' Then
Begin
SaveDialog.Filename := '*.CMS';
SaveDialog.Filter := 'Credit message|*.cms';
End
Else
Begin
SaveDialog.Filename := sgFileName;
SaveDialog.Filter :='jpeg|*.jpg|bmp|*.bmp|gif|*.gif|pcx|*.pcx|png|*.png|tif|*.tif|tga|*.tga|eps|*.eps';
If (sgExt = '.JPG') Or (sgExt = '.JPEG') Then SaveDialog.FilterIndex := 1;
If (sgExt = '.BMP') Then SaveDialog.FilterIndex := 2;
If (sgExt = '.GIF') Then SaveDialog.FilterIndex := 3;
If (sgExt = '.PCX') Then SaveDialog.FilterIndex := 4;
If (sgExt = '.PNG') Then SaveDialog.FilterIndex := 5;
If (sgExt = '.TIF') Then SaveDialog.FilterIndex := 6;
If (sgExt = '.TIFF') Then SaveDialog.FilterIndex := 6;
If (sgExt = '.TGA') Then SaveDialog.FilterIndex := 7;
If (sgExt = '.EPS') Then SaveDialog.FilterIndex := 8;
End;
End;
If SaveDialog.execute Then
Begin
sgFileDir := ExtractFileDir(SaveDialog.FileName);
If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
sgFileDir := sgFileDir + '\';
sgFileName := ExtractFileName(SaveDialog.FileName);
sgExt := UpperCase(ExtractFileExt(sgFileName));
Result :=
IL_SaveAs(
PMultiImage, //PMultiImage : TPMultiImage;
Quality , //inQuality : Integer;
sgFileName , //sgFileName : String;
sgExt , //sgExt : String;
sgFileDir );//sgFileDir : String): Boolean;
End;
Finally
SaveDialog.Free;
End;
Except
End;
end;
Function ResizeImageKeepProportions(
PMultiImage : TPMultiImage;
NewDimension : Integer;
IsWidth : Boolean): Boolean;
Var
inWidthOld : Integer;
inWidthNew : Integer;
inHeightOld : Integer;
inHeightNew : Integer;
Bitmap : TBitmap;
boStretch : Boolean;
begin
boStretch:= PMultiImage.StretchRatio;
Bitmap := TBitmap.Create;
Try
Try
{Set Stretch Off}
PMultiImage.StretchRatio := False;
{Create a new bitmap and set its size}
inWidthOld := PMultiImage.Picture.Bitmap.Width;
inHeightOld := PMultiImage.Picture.Bitmap.Height;
If IsWidth Then
Begin
inWidthNew := NewDimension;
inHeightNew := (inHeightOld * inWidthNew) div inWidthOld;
End
Else
Begin
inHeightNew := NewDimension;
inWidthNew := (inWidthOld * inHeightNew) div inHeightOld;
End;
Bitmap.Width := inWidthNew;
Bitmap.Height := inHeightNew;
{Copy the palette}
Bitmap.Palette:=PMultiImage.Picture.Bitmap.Palette;
{Delete the lines needed to shrink}
SetStretchBltMode(Bitmap.Canvas.Handle,STRETCH_DELETESCANS);
{Resize it}
Bitmap.Canvas.Copyrect(Rect(0,
0,
inWidthNew,
inHeightNew),
PMultiImage.Picture.Bitmap.Canvas,
Rect(0,
0,
PMultiImage.Picture.Bitmap.Width,
PMultiImage.Picture.Bitmap.Height));
{Copy the palette}
Bitmap.Palette:=PMultiImage.Picture.Bitmap.Palette;
{Assign the new smaller bitmap}
PMultiImage.Picture.Bitmap.Assign(Bitmap);
{Free the bitmap}
Result := True;
Except
Result := False;
End;
Finally
Bitmap.Free;
PMultiImage.StretchRatio := boStretch;
End;
end;
Function ResizeImageBestFit(
PMultiImage : TPMultiImage;
Height : Integer;
Width : Integer): Boolean;
Var
inWidthOld : Integer;
inHeightOld : Integer;
boStretch : Boolean;
IsWidth : Boolean;
NewDimension : Integer;
begin
boStretch := PMultiImage.StretchRatio;
Try
Try
PMultiImage.StretchRatio := False;
inWidthOld := PMultiImage.Picture.Bitmap.Width;
inHeightOld := PMultiImage.Picture.Bitmap.Height;
IsWidth := (((inHeightOld * Width) div inWidthOld)<=Height);
If IsWidth Then
Begin
NewDimension := Width;
End
Else
Begin
NewDimension := Height;
End;
Result :=
ResizeImageKeepProportions(
PMultiImage , //PMultiImage : TPMultiImage;
NewDimension , //NewDimension : Integer;
IsWidth ); //IsWidth : Boolean): Boolean;
Except
Result := False;
End;
Finally
PMultiImage.StretchRatio := boStretch;
End;
end;
Function IL_SaveAs(
PMultiImage : TPMultiImage;
inQuality : Integer;
FileName : String): Boolean; OverLoad;
Var
sgFileName : String;
sgExt : String;
sgFileDir : String;
Begin
sgFileName := ExtractFileName(FileName);
sgExt := ExtractFileExt(FileName);
sgFileDir := ExtractFileDir(FileName);
Result :=
IL_SaveAs(
PMultiImage , //PMultiImage : TPMultiImage;
inQuality , //inQuality : Integer;
sgFileName , //sgFileName : String;
sgExt , //sgExt : String;
sgFileDir ); //sgFileDir : String): Boolean; OverLoad;
End;
end.