lazarus/components/ideintf/ideimagesintf.pas

{
 ***************************************************************************
 *                                                                         *
 *   This source is free software; you can redistribute it and/or modify   *
 *   it under the terms of the GNU General Public License as published by  *
 *   the Free Software Foundation; either version 2 of the License, or     *
 *   (at your option) any later version.                                   *
 *                                                                         *
 *   This code is distributed in the hope that it will be useful, but      *
 *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
 *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
 *   General Public License for more details.                              *
 *                                                                         *
 *   A copy of the GNU General Public License is available on the World    *
 *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
 *   obtain it by writing to the Free Software Foundation,                 *
 *   Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.   *
 *                                                                         *
 ***************************************************************************
}
unit IDEImagesIntf;

{$mode objfpc}{$H+}

interface

uses
  Types, Classes, SysUtils, Math,
  // LCL
  LCLType, LResources, ImgList, Controls, Graphics, Buttons;

type

  { TIDEImages }

  TIDEImages = class
  private
    FImages_12: TLCLGlyphs;
    FImages_16: TLCLGlyphs;
    FImages_24: TLCLGlyphs;
    procedure FImages_24_GetWidthForPPI(Sender: TCustomImageList; {%H-}AImageWidth,
      {%H-}APPI: Integer; var AResultWidth: Integer);
    function GetImages(Size: Integer): TLCLGlyphs;
  protected
    function GetImages_12: TLCLGlyphs;
    function GetImages_16: TLCLGlyphs;
    function GetImages_24: TLCLGlyphs;

    class function CreateBitmapFromRes(const ImageName: string): TCustomBitmap;
    class function CreateBestBitmapForScalingFromRes(const ImageName: string;
      const aDefScale: Integer; out aBitmap: TCustomBitmap): Integer;
  public
    destructor Destroy; override;

    class function GetScalePercent: Integer;
    class function ScaleImage(const AImage: TGraphic; out ANewInstance: Boolean;
      TargetWidth, TargetHeight: Integer; const AFactor: Double): TCustomBitmap;
    class function CreateImage(ImageSize: Integer; ImageName: String): TCustomBitmap; deprecated 'Don''t use this, use image lists instead.';
    class function CreateImage(ImageName: String; ImageSize: Integer = 16): TCustomBitmap; deprecated 'Don''t use this, use image lists instead.';
    class procedure AssignImage(const ABitmap: TCustomBitmap; ImageName: String;
      ImageSize: Integer = 16); deprecated 'Use the other overloads instead.';
    procedure AssignImage(const ABitBtn: TCustomBitBtn; ImageName: String;
      ImageSize: Integer = 16);
    procedure AssignImage(const ASpeedButton: TCustomSpeedButton; ImageName: String;
      ImageSize: Integer = 16);
    class function AddImageToImageList(const AImageList: TImageList;
      ImageName: String; ImageSize: Integer = 16): Integer; deprecated 'Don''t use this, use image lists instead.';
    class function ScaledSize(ImageSize: Integer = 16): Integer; deprecated 'Don''t use this, use image lists instead.';

    function LoadImage(ImageSize: Integer; ImageName: String): Integer; deprecated 'Use the other overload instead.';
    function LoadImage(ImageName: String; ImageSize: Integer = 16): Integer;
    function GetImageIndex(ImageSize: Integer; ImageName: String): Integer; deprecated 'Use the other overload instead.';
    function GetImageIndex(ImageName: String; ImageSize: Integer = 16): Integer;

    (* Images_nn
       Each list contains images according to their default size at 96 PPI.
       Any specific image is ONLY present in one of the Lists (and that list also has all the scaled versions of that image)
       To use an image, either
       - assign IdeImages.Images_nn to the ImageList property of a component
       - IdeImages.Images_nn.ResolutionForControl[NN, Control].Draw(...)  // where NN is the same as nn
    *)
    property Images_12: TLCLGlyphs read GetImages_12;
    property Images_16: TLCLGlyphs read GetImages_16;
    property Images_24: TLCLGlyphs read GetImages_24;
    property Images[Size: Integer]: TLCLGlyphs read GetImages;
  end;

function IDEImages: TIDEImages;

implementation

var
  FIDEImages: TIDEImages;

{ TIDEImages }

function TIDEImages.GetImages_12: TLCLGlyphs;
begin
  if FImages_12 = nil then
  begin
    FImages_12 := TLCLGlyphs.Create(nil);
    FImages_12.Width := 12;
    FImages_12.Height := FImages_12.Width;
    FImages_12.RegisterResolutions([12, 16, 24]);
  end;
  Result := FImages_12;
end;

function TIDEImages.GetImages_16: TLCLGlyphs;
begin
  if FImages_16 = nil then
  begin
    FImages_16 := TLCLGlyphs.Create(nil);
    FImages_16.Width := 16;
    FImages_16.Height := FImages_16.Width;
    FImages_16.RegisterResolutions([16, 24, 32]);
  end;
  Result := FImages_16;
end;

function TIDEImages.GetImages_24: TLCLGlyphs;
begin
  if FImages_24 = nil then
  begin
    FImages_24 := TLCLGlyphs.Create(nil);
    FImages_24.Width := 24;
    FImages_24.Height := FImages_24.Width;
    FImages_24.RegisterResolutions([24, 36, 48]);
  end;
  Result := FImages_24;
end;

class function TIDEImages.GetScalePercent: Integer;
begin
  if ScreenInfo.PixelsPerInchX <= 120 then
    Result := 100 // 100-125% (96-120 DPI): no scaling
  else
  if ScreenInfo.PixelsPerInchX <= 168 then
    Result := 150 // 126%-175% (144-168 DPI): 150% scaling
  else
    Result := Round(ScreenInfo.PixelsPerInchX/96) * 100; // 200, 300, 400, ...
end;

function TIDEImages.LoadImage(ImageSize: Integer; ImageName: String): Integer;
begin
  Result := LoadImage(ImageName, ImageSize);
end;

class function TIDEImages.CreateImage(ImageName: String; ImageSize: Integer
  ): TCustomBitmap;
var
  Grp: TCustomBitmap;
  GrpScaledNewInstance: Boolean;
  ScalePercent, GrpScale: Integer;
begin
  ScalePercent := GetScalePercent;

  Grp := nil;
  try
    GrpScale := CreateBestBitmapForScalingFromRes(ImageName, ScalePercent, Grp);
    if Grp<>nil then
    begin
      Result := ScaleImage(Grp, GrpScaledNewInstance,
        MulDiv(ImageSize, ScalePercent, GrpScale), MulDiv(ImageSize, ScalePercent, GrpScale), ScalePercent / GrpScale);
      if not GrpScaledNewInstance then
        Grp := nil;
      Exit; // found
    end;
  finally
    Grp.Free;
  end;
  Result := nil; // not found
end;

destructor TIDEImages.Destroy;
begin
  FImages_12.Free;
  FImages_16.Free;
  FImages_24.Free;
  inherited Destroy;
end;

procedure TIDEImages.FImages_24_GetWidthForPPI(Sender: TCustomImageList;
  AImageWidth, APPI: Integer; var AResultWidth: Integer);
begin
  if (30<=AResultWidth) and (AResultWidth<=40) then
    AResultWidth := 32;
end;

class procedure TIDEImages.AssignImage(const ABitmap: TCustomBitmap;
  ImageName: String; ImageSize: Integer);
var
  xBmp: TCustomBitmap;
begin
  xBmp := CreateImage(ImageName, ImageSize);
  try
    ABitmap.Assign(xBmp);
  finally
    xBmp.Free;
  end;
end;

class function TIDEImages.AddImageToImageList(const AImageList: TImageList;
  ImageName: String; ImageSize: Integer): Integer;
var
  xBmp: TCustomBitmap;
begin
  Result := -1;
  xBmp := TIDEImages.CreateImage(ImageName, ImageSize);
  try
    Result := AImageList.Add(xBmp, nil);
  finally
    xBmp.Free;
  end;
end;

procedure TIDEImages.AssignImage(const ABitBtn: TCustomBitBtn;
  ImageName: String; ImageSize: Integer);
var
  IL: TLCLGlyphs;
begin
  IL := Images[ImageSize];
  if IL=nil then Exit;
  ABitBtn.Images := IL;
  ABitBtn.ImageIndex := IL.GetImageIndex(ImageName);
end;

procedure TIDEImages.AssignImage(const ASpeedButton: TCustomSpeedButton;
  ImageName: String; ImageSize: Integer);
var
  IL: TLCLGlyphs;
begin
  IL := Images[ImageSize];
  if IL=nil then Exit;
  ASpeedButton.Images := IL;
  ASpeedButton.ImageIndex := IL.GetImageIndex(ImageName);
end;

class function TIDEImages.ScaledSize(ImageSize: Integer): Integer;
begin
  Result := ImageSize * GetScalePercent div 100;
end;

class function TIDEImages.CreateBitmapFromRes(const ImageName: string
  ): TCustomBitmap;
var
  ResHandle: TLResource;
begin
  ResHandle := LazarusResources.Find(ImageName);
  if ResHandle <> nil then
    Result := CreateBitmapFromLazarusResource(ResHandle)
  else
    Result := CreateBitmapFromResourceName(HInstance, ImageName);
end;

class function TIDEImages.CreateBestBitmapForScalingFromRes(const ImageName: string;
  const aDefScale: Integer; out aBitmap: TCustomBitmap): Integer;
begin
  aBitmap := nil;
  Result := aDefScale;
  while (Result > 100) do
  begin
    aBitmap := CreateBitmapFromRes(ImageName+'_'+IntToStr(Result));
    if aBitmap<>nil then Exit;
    if (Result>300) and ((Result div 100) mod 2 = 1) then // 500, 700, 900 ...
      Result := Result + 100;
    Result := Result div 2;
  end;
  aBitmap := CreateBitmapFromRes(ImageName);
  Result := 100;
  if (aBitmap is TBitmap) and (aBitmap.PixelFormat in [pf1bit..pf24bit]) then
  begin
    aBitmap.TransparentColor := aBitmap.Canvas.Pixels[0, aBitmap.Height-1];
    aBitmap.Transparent := True;
  end;
end;

class function TIDEImages.CreateImage(ImageSize: Integer; ImageName: String
  ): TCustomBitmap;
begin
  Result := CreateImage(ImageName, ImageSize);
end;

function TIDEImages.GetImageIndex(ImageSize: Integer; ImageName: String): Integer;
begin
  Result := GetImageIndex(ImageName, ImageSize);
end;

function TIDEImages.GetImageIndex(ImageName: String; ImageSize: Integer): Integer;
var
  List: TLCLGlyphs;
begin
  List := Images[ImageSize];
  if List <> nil then
    Result := List.GetImageIndex(ImageName)
  else
    Result := -1;
end;

function TIDEImages.GetImages(Size: Integer): TLCLGlyphs;
begin
  case Size of
    12: Result := Images_12;
    16: Result := Images_16;
    24: Result := Images_24;
  else
    Result := nil
  end;
end;

function TIDEImages.LoadImage(ImageName: String; ImageSize: Integer): Integer;
begin
  Result := GetImageIndex(ImageName, ImageSize);
end;

class function TIDEImages.ScaleImage(const AImage: TGraphic; out
  ANewInstance: Boolean; TargetWidth, TargetHeight: Integer;
  const AFactor: Double): TCustomBitmap;
var
  Bmp: TBitmap;
  TargetRect: TRect;
begin
  if SameValue(AFactor, 1) and (AImage is TCustomBitmap) then
  begin
    ANewInstance := False;
    Exit(TCustomBitmap(AImage));
  end;

  Bmp := TBitmap.Create;
  try
    Result := Bmp;
    ANewInstance := True;
    if (AImage is TBitmap) and AImage.Transparent then
    begin
      Bmp.PixelFormat := pf24bit;
      Bmp.Canvas.Brush.Color := TBitmap(AImage).TransparentColor;
      Bmp.TransparentColor := TBitmap(AImage).TransparentColor;
      Bmp.Transparent := TBitmap(AImage).Transparent;
    end else
    begin
      {$IFDEF LCLGtk2}
      Bmp.PixelFormat := pf24bit;
      Bmp.Canvas.Brush.Color := clBtnFace;
      Bmp.TransparentColor := clBtnFace;
      Bmp.Transparent := True;
      {$ELSE}
      Bmp.PixelFormat := pf32bit;
      Bmp.Canvas.Brush.Color := TColor($FFFFFFFF);
      {$ENDIF}
    end;
    Bmp.SetSize(TargetWidth, TargetHeight);
    Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
    TargetRect := Rect(0, 0, Round(AImage.Width*AFactor), Round(AImage.Height*AFactor));
    OffsetRect(TargetRect, (TargetWidth-TargetRect.Right) div 2, (TargetHeight-TargetRect.Bottom) div 2);
    Bmp.Canvas.StretchDraw(TargetRect, AImage);
  except
    FreeAndNil(Result);
    ANewInstance := False;
    raise;
  end;
end;

function IDEImages: TIDEImages;
begin
  if FIDEImages = nil then
    FIDEImages := TIDEImages.Create;
  Result := FIDEImages;
end;

initialization
  FIDEImages := nil;

finalization
  FIDEImages.Free;
  FIDEImages:=nil;

end.