Библиотека (fmx.features.bitmap),обрезаем По Кругу Картинку (delphi,xe,rad Studio)

Lomanu4 · 17 Фев 2016

В видео показывается библиотека FMX.Features.Bitmap.Helpers,которая с максимальной скоростью загружает картинку с интернета и вставляем ее в программу,так же в видео показано как обрезать картинку по кругу.

Код всей программы

Код:

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Features.Bitmap.Helpers,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects, FMX.ListView.Types,
  FMX.ListView.Appearances, FMX.ListView.Adapters.Base, FMX.ListView;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    ListView1: TListView;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Bitmap.loadfromurl
    ('http://guardianelinks.de/data/avatars/l/0/1.jpg?1430741668');

    with ListView1.Items.Add do
    Bitmap.LoadFromUrl('http://guardianelinks.de/data/avatars/l/0/1.jpg?1430741668');
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Bmpnew: TBitmap;
begin
  Bmpnew := TBitmap.Create;
  Bmpnew.SetSize(1012, 1012);
  Bmpnew.Canvas.BeginScene();
  try
    Bmpnew.Canvas.Fill.Kind := TBrushKind.Bitmap;
    Bmpnew.Canvas.Fill.Bitmap.WrapMode := TWrapMode.TileStretch;
    Bmpnew.Canvas.Fill.Bitmap.Bitmap := Image1.Bitmap;
    Bmpnew.Canvas.FillEllipse(RectF(0, 0, 1012, 1012), 1);
  finally
    Bmpnew.Canvas.EndScene;
  end;
    Image1.Bitmap.Assign(Bmpnew);




end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Image1.Free;
end;

end.

Код:

unit FMX.Features.Bitmap.Helpers;

interface

uses
  System.Classes, FMX.Graphics, Soap.EncdDecd, System.IOUtils;

type
  TBitmapHelper = class helper for TBitmap
  private
    procedure RefreshBitMap(Sender : TObject);
    procedure SetBmp(Value: TBitmap);
    function GetBmp : TBitmap;
    procedure LoadFromBase64(const Value: string);

    function SaveToBase64: string;
  public
    property BmpTest: TBitmap read GetBmp write SetBmp;
    property Base64 : string read SaveToBase64 write LoadFromBase64;
    procedure LoadFromUrl(AUrl: string);

    procedure LoadThumbnailFromUrl(AUrl: string; const AFitWidth, AFitHeight: Integer);
    function SaveToFilef(fName : string) : boolean;
    function LoadFromResource(bmpName : string) : Boolean;
  end;

implementation

uses
  System.SysUtils, System.Types, IdHttp, IdTCPClient;
{------------------------------------------------------------------------------}
function TBitmapHelper.GetBmp: TBitmap;
begin
    Result := self;
end;
{------------------------------------------------------------------------------}
procedure TBitmapHelper.LoadFromBase64(const Value: string);
var
    stream : TBytesStream;
    bytes : TBytes;
    temp : string;
begin
    if Value.IsEmpty then
        exit;
    bytes :=  DecodeBase64(Value);
    stream := TBytesStream.Create(bytes);
    try
        LoadFromStream(stream);
    except
        on e : Exception do
            temp := e.Message;
    end;
    FreeAndNil(stream);
end;
{------------------------------------------------------------------------------}
function TBitmapHelper.LoadFromResource(bmpName: string): Boolean;
var
    RStream: TResourceStream;
begin
    Result := false;
    if bmpName.IsEmpty then
        exit;
     RStream := TResourceStream.Create(HInstance, bmpName, RT_RCDATA);
     try
        if RStream.Size < 1000000 then
            self.LoadFromStream(RStream);
        Result := true;
     finally
        RStream.Free;
     end;
end;

{------------------------------------------------------------------------------}
function TBitmapHelper.SaveToBase64: string;
var
    stream : TMemoryStream;
    encodeString : string;
begin
    if IsEmpty then
        Exit(string.Empty);
    stream := TMemoryStream.Create;
    try
        SaveToStream(stream);
        encodeString := EncodeBase64(stream.Memory, stream.Size);
        Result := encodeString;
    finally
        FreeAndNil(stream);
    end;
end;
{------------------------------------------------------------------------------}
function TBitmapHelper.SaveToFilef(fName: string): boolean;
var
    dirName : string;
    fileName : string;
begin
    Result := false;
    if fName.IsEmpty then
        exit;
    dirName := TPath.GetDirectoryName(fName);
    fileName := TPath.GetFileName(fName);
    if ForceDirectories(dirName) then
    begin
        SaveToFile(fName);
        Result := True;
    end;
end;
{------------------------------------------------------------------------------}
procedure TBitmapHelper.LoadFromUrl(AUrl: string);
var
  thread : TThread;
begin
thread :=  TThread.CreateAnonymousThread(
    procedure
    var
      Http: TIdHttp;
      Result : TMemoryStream;
    begin
      Result := TMemoryStream.Create;
      Http := TIdHttp.Create(nil);
      try
        try
        Http.Get(AUrl, Result);
        TThread.Synchronize (TThread.CurrentThread,
            procedure ()
            var
                tempBitMap : TBitmap;
            begin
                tempBitMap := TBitmap.Create;
                tempBitMap.LoadFromStream(Result);
                if not tempBitMap.IsEmpty then
                begin
                    self.Assign(tempBitMap);
                end;
            end);
        except
          Result.Free;
        end;
      finally
        Http.Free;
      end;
    end
  );
  thread.FreeOnTerminate := True;
  thread.start;
end;
{------------------------------------------------------------------------------}
procedure TBitmapHelper.LoadThumbnailFromUrl(AUrl: string; const AFitWidth,
  AFitHeight: Integer);
var
  Bitmap: TBitmap;
  scale: Single;
begin
  LoadFromUrl(AUrl);
  Bitmap := CreateThumbnail(AFitWidth, AFitHeight);
  try
    Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;
{------------------------------------------------------------------------------}
procedure TBitmapHelper.RefreshBitMap(Sender: TObject);
var
    tempBmp : TBitmap;
begin
    tempBmp := TBitmap(Sender);
    if Assigned(tempBmp) then
        self.Assign(tempBmp);
end;
{------------------------------------------------------------------------------}
procedure TBitmapHelper.SetBmp(Value: TBitmap);
begin
    self.Assign(Value);
    Value.OnChange := RefreshBitMap;
end;
{------------------------------------------------------------------------------}
end.

Скачать библиотеку и закиньте его в ваш проект. Скачать тут

Тут вы можете скачать готовый проект сразу с библиотека

Библиотека (fmx.features.bitmap),обрезаем По Кругу Картинку (delphi,xe,rad Studio)

Lomanu4