Advanced Delphi Systems Code: ads

//Advanced Delphi Systems Code: ads_ImageLib

unit ads_ImageLib;
{Copyright(c)2016 Advanced Delphi Systems

 Richard Maley
 Advanced Delphi Systems
 12613 Maidens Bower Drive
 Potomac, MD 20854 USA
 phone 301-840-1554
 dickmaley@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 dickmaley@advdelphisys.com so that the
 entire Delphi community can benefit.  All comments are welcome.
}
(*

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,
    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

uses
  ads_Exception;
Var
  UnitName : String = 'ads_ImageLib'; 
  ProcName : String = 'Unknown';


//

Unit Description UnitIndex Master Index

Function IL_SaveAs(
  PMultiImage : TPMultiImage;
  inQuality   : Integer;
  sgFileName  : String;
  sgExt       : String;
  sgFileDir   : String): Boolean;
Var
  sgFullFile  : String;
begin
  Result      := False;
  ProcName    := 'IL_SaveAs'; Try
  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;
    Raise;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);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;
  ProcName   := 'IL_SaveAsDlg'; 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 On E : Exception Do RaiseError(UnitName,ProcName,E);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
  Result       := False;
  ProcName     := 'ResizeImageKeepProportions'; Try
  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;
      Raise;
    End;
  Finally
    Bitmap.Free;
    PMultiImage.StretchRatio := boStretch;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);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
  Result       := False;
  ProcName     := 'ResizeImageBestFit'; Try
  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;
      Raise;
    End;
  Finally
    PMultiImage.StretchRatio := boStretch;
  End;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);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
  Result      := False;
  ProcName    := 'IL_SaveAs'; Try
  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;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
End;

end.

//