Новые пользователи
Активные пользователи
[ Новые сообщения · Участники· Правила форума · Поиск · RSS ]
Страница 1 из 11
Архив - только для чтения
Форум » Программирование на Delphi » Готовые решения » Как удалить рамку у картинки? (Работа с графикой в Delphi)
Как удалить рамку у картинки?
PWorkДата: Среда, 31.01.2018, 16:27 | Сообщение # 1
Группа: Администраторы
Сообщений: 15
Статус: Offline
Иногда бывает нужно удалить рамку у большого количества картинок (например, скриншотов, демотиваторов...). Этот процесс можно с успехом автоматизировать, написав небольшую утилиту, которая бы находила и удаляла рамку, с последующим пересохранением картинки. Я написал небольшую процедуру, которая находит границы однотонных рамок.  Глядите сюда:

Картинка до обработки:



После обработки:



А вот и код:

(Расположите на форме 2 Image и одну кнопку):


Код
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, pngimage, jpeg;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image2: TImage;
    Label1: TLabel;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure FindBounds(Bmp:TBitMap; var R: TRect; FrameColor: TColor = clBlack);
var
  RR: TRect;
  TM, BM, Bmm, RM, LM, H, W, X, Y: Integer;
  Cl: TColor;
  BreakLoop: Boolean;
begin
  RR := Bmp.Canvas.ClipRect;
  H := RR.Bottom - RR.Top;
  W := RR.Right - RR.Left;
  TM := 0;
  BM := H;
  LM := 0;
  RM := W;
  SetRect(R, LM, TM, RM, BM);

  /// HCROP
  BreakLoop := False;
  for Y := 0 to H - 1 do
  begin
    for X := 0 to W - 1 do
    begin
      Cl := Bmp.Canvas.Pixels[X, Y];
      if Cl <> FrameColor then
      begin
        TM := Y;
        BreakLoop := True;
        Break;
      end;
    end;
    if BreakLoop then
      Break;
  end;

  /// BCROP
  BreakLoop := False;
  for Y := H downto TM do
  begin
    for X := 0 to W-1 do
    begin
      Cl := Bmp.Canvas.Pixels[X, Pred(Y)];
      if Cl <> FrameColor then
      begin
        BM := Y;
        BreakLoop := True;
        Break;
      end;
    end;
    if BreakLoop then
      Break;
  end;

  BMM:=BM;
  if BMM=H then
  Dec(BMM);

  // LCROP
  BreakLoop := False;
  for Y := 0 to W - 1 do
  begin
    for X := TM to BMM do
    begin
      Cl := Bmp.Canvas.Pixels[Y, X];
      if Cl <> FrameColor then
      begin
        LM := Y;
        BreakLoop := True;
        Break;
      end;
    end;
    if BreakLoop then
      Break;
  end;

  // RCROP
  BreakLoop := False;
  for Y := W downto LM do
  begin
    for X := TM to BMM do
    begin
      Cl := Bmp.Canvas.Pixels[Pred(Y), X];
      if Cl <> FrameColor then
      begin
        RM := Y;
        BreakLoop := True;
        Break;
      end;
    end;
    if BreakLoop then
      Break;
  end;

  with R do
  begin
    Top := TM;
    Left := LM;
    Bottom := BM;
    Right := RM;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TRect;
  oBmp, Bmp: TBitMap;
begin
  Bmp := TBitMap.Create;
  oBmp := TBitMap.Create;
  oBmp.Assign(Image1.Picture.Graphic); // Страхуемся от ошибок, если формат - не BMP
  SetRect(R, 0, 0, 0, 0); // Просто для "профилактики." ^_^ Можно и не занулять.
  FindBounds(oBmp, R);  // Определяем границы рамки
  Label1.Caption := Format('Left:%d; Top:%d; Height:%d; Width:%d',
    [R.Left, R.Top, R.Bottom, R.Right]);  // Контроль. Можно удалить.
  with Bmp do
  begin
    Width := R.Right - R.Left;
    Height := R.Bottom - R.Top;
    Canvas.CopyRect(Canvas.ClipRect, oBmp.Canvas, R); // Просто копируем нужный кусок канвы оригинального битмапа.
  end;
  Image2.Picture.Assign(Bmp);
//  Bmp.SaveToFile('C:\123123.bmp');
end;

end.
Форум » Программирование на Delphi » Готовые решения » Как удалить рамку у картинки? (Работа с графикой в Delphi)
Страница 1 из 11
Поиск:
X

Внимание!

Ваш браузер уязвим для рекламы. Установите AdBlock Plus! https://adblockPlus.org

uCoz