Advanced Delphi Systems Code: ads

//Advanced Delphi Systems Code: ads_ImageLib

{Copyright(c)2000 Advanced Delphi Systems

 Richard Maley
 Advanced Delphi Systems
 12613 Maidens Bower Drive
 Potomac, MD 20854 USA
 phone 301-840-1554
 maley@advdelphisys.com

 The code herein can be used or modified by anyone.  Please retain references
 to Richard Maley at Advanced Delphi Systems.  If you make improvements to the
 code please send your improvements to maley@advdelphisys.com so that the
 entire Delphi community can benefit.  All comments are welcome.

 Please note if you are viewing this Delphi unit as a web page all you have to
 do to turn it into a Delphi unit is save it with a ".pas" extension.  The
 html in the unit should not affect its performance.
}
unit ads_ImageLib;

(*

UnitIndex Master Index Implementation Section Download Units

Description: ads_ImageLib.pas
This unit contains the following routines.

IL_SaveAs_1 IL_SaveAs_2 IL_SaveAsDlg ResizeImageBestFit ResizeImageKeepProportions

*)
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


//

Unit Description UnitIndex Master Index

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;

//

Unit Description UnitIndex Master Index

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;

//

Unit Description UnitIndex Master Index

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;

//

Unit Description UnitIndex Master Index

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;

//

Unit Description UnitIndex Master Index

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.
//