Решено. TImage сохраняет залитое чёрным изображение

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

Решено. TImage сохраняет залитое чёрным изображение

Сообщение zi000000 » 15.06.2017 19:49:31

Здравствуйте!

Упрощённо. Надо скопировать кусок из одного изображения в другое и сохранить его в файл BMP.
Изображение-то копируется, но после сохранения я имею файл BMP залитый чёрным цветом, а не кусок скопированного изображения.

Укажите на ошибку, пожалуйста!

Прототип:
Код: Выделить всё
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, LCLIntf, LCLType;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Image2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure Image2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
  BitMap: TBitMap;
  FlagDown:Boolean;
  DownX, DownY: Integer;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FlagDown := True;
  DownX := X;
  DownY := Y;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.SaveToFile('C:\2priemn.bmp');
  Image3.Picture.Assign(Image1.Picture);
  Image1.Picture.SaveToFile('C:\3.bmp');
  Image2.Picture.SaveToFile('C:\1orig.bmp');

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BitMap := TBitMap.Create;
  BitMap.PixelFormat := pf32bit;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  BitMap.Free;
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if FlagDown then
  begin
    with Image2 do
      begin
        Canvas.Pen.Color := clRed;
        Canvas.Pen.Width := 2;
        Canvas.Pen.Style := psSolid;
        Canvas.Brush.Color := clNone;
        Canvas.Brush.Style := bsClear;
        Repaint;
        Canvas.Rectangle(DownX, DownY, X, Y);
      end;
     end;
end;

procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Rect: TRect;
  DC: HDC;
begin
  FlagDown := False;
  Rect.Left := DownX;
  Rect.Top := DownY;
  Rect.Right := X;
  Rect.Bottom := Y;
  BitMap.Width := Rect.Right - Rect.Left;
  BitMap.Height := Rect.Bottom - Rect.Top;
  BitMap.PixelFormat := Image2.Picture.Bitmap.PixelFormat;

  BitBlt(BitMap.Canvas.Handle, 0, 0, Rect.Width, Rect.Height, Image2.Picture.Bitmap.Canvas.Handle, Rect.Left, Rect.Top, SRCCOPY);

  Image1.Picture.Assign(BitMap);
  //BitMap.SaveToFile(Edit1.Text);

end;

end.



Скачать прототип: https://cloud.mail.ru/public/Apd5/wBXyHXRXs
Последний раз редактировалось zi000000 16.06.2017 01:51:07, всего редактировалось 2 раз(а).
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение vitaly_l » 15.06.2017 20:02:24

Image1.Picture.Assign(BitMap); <== А так?
Или вот так: BitMap.SaveToFile( Edit1.Text );
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 3333
Зарегистрирован: 31.01.2012 16:41:41

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 15.06.2017 20:11:05

vitaly_l Проверял. Чёрный.

Lazarus 1.6.4
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение pupsik » 15.06.2017 21:20:23

zi000000 копайте в сторону CopyRect.
pupsik
энтузиаст
 
Сообщения: 1154
Зарегистрирован: 20.08.2014 16:20:13

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 15.06.2017 21:28:53

pupsik Хотелось бы понять, что не так с моим кодом.. или это проблема lazarus.

Изображение во второй timage копируется и в программе отображается. Я добавил третий timage для теста и из него в третий копируется без проблем.
Но вот сохраняется этот кусок с размерами правильными, а вот вместо изображения чёрный фон.

Видео https://cloud.mail.ru/public/9WWJ/shBJRAKyX
Последний раз редактировалось zi000000 15.06.2017 22:35:09, всего редактировалось 1 раз.
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение pupsik » 15.06.2017 22:19:42

Хотелось бы понять, что не так с моим кодом
у вас виндозависимый код. И он срабатывает не верно.
Плюс: если хотите скопировать часть изображения то или храните оригинал в памяти, или рисуйте TRect прозрачным. Хотя: первый вариант желательнее, а Image - для визуальной отрисовки.
pupsik
энтузиаст
 
Сообщения: 1154
Зарегистрирован: 20.08.2014 16:20:13

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 15.06.2017 22:39:11

pupsik
Правильно, windows зависимый. Для этой ОС и пишу приложение.

pupsik писал(а):Плюс: если хотите скопировать часть изображения

Я показал прототип, что бы обозначить проблему.
На видео видно, что копирование происходит без проблем. Проблема с сохранением.
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение shade » 15.06.2017 22:45:13

> BitMap.Width := Rect.Right - Rect.Left;
> BitMap.Height := Rect.Bottom - Rect.Top;
> BitBlt(BitMap.Canvas.Handle, 0, 0, Rect.Width, Rect.Height, Image2.Picture.Bitmap.Canvas.Handle, Rect.Left, Rect.Top, SRCCOPY);

может так:
BitBlt(BitMap.Canvas.Handle, 0, 0, Bitmap.width, bitmap.height, Image2.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
?

или так:
Bitmap.canvas.CopyRect(rect(0, 0, bitmap.width, bitmap.height), Image2.Picture.Bitmap.Canvas, rect(0, 0, bitmap.width, bitmap.height));

> Image1.Picture.BitMap := BitMap;
что-то тут не хорошо. Как минимум теряете ссылку на объект (утечка памяти будет)
надо наверное Image1.Picture.BitMap.assing(BitMap);

Добавлено спустя 1 минуту 48 секунд:
Вам надо прям с TImage на TImage копировать? или просто изображение обработать?
Аватара пользователя
shade
энтузиаст
 
Сообщения: 879
Зарегистрирован: 21.02.2006 20:15:48
Откуда: http://shamangrad.net/

Re: TImage сохраняет не то, что надо

Сообщение pupsik » 15.06.2017 22:57:06

Я показал прототип, что бы обозначить проблему.
и зачем виндозависимость в таком простом случае? - риторика.
И, пардон, ничего ваш код нормально не отображает. Лёгкая смена обстановки позволяет достичь требуемого. При этом - это кросс вариант. Как? Пробуйте, тестируйте.

Плюс: весьма риторический вопрос... что происходит при уничтожении битмапа? И ссылка идёт, или копирование? Повторяю: риторика.

п.с.
На видео видно
да я тор не хочу мучить. "Затор" видите ли у нас... законодательный :mrgreen:
pupsik
энтузиаст
 
Сообщения: 1154
Зарегистрирован: 20.08.2014 16:20:13

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 15.06.2017 23:25:13

shade писал(а):надо наверное Image1.Picture.BitMap.assing(BitMap);

уже, не обращайте внимание, это прототип

pupsik
Желательно без риторики :)
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение pupsik » 15.06.2017 23:52:01

Желательно без риторики
да легко. Но и без кода, а скрином :lol:

Если уж сложно будет поставьте BGRABitmap. Там ужо всё включено.

п.с.
На скрине я переделал первым вариантом.

Добавлено спустя 2 минуты 54 секунды:
Image1.Picture.BitMap.assing(BitMap);
тогда уж или чистить, или пересоздавать битмап. Это сумбурная риторика номер 2:
И ссылка идёт, или копирование?
У вас нет необходимых прав для просмотра вложений в этом сообщении.
pupsik
энтузиаст
 
Сообщения: 1154
Зарегистрирован: 20.08.2014 16:20:13

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 16.06.2017 00:05:02

pupsik
Я имел ввиду, что разобраться надо с моим кодом. Хочется понять, что там не так и заставить "кусок" сохраняться правильно.

Здесь предложили решение и у человека заработало, у меня всё тот же чёрный квадрат Казимира Малевича.
http://forum.lazarus.freepascal.org/ind ... #msg240471
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49

Re: TImage сохраняет не то, что надо

Сообщение pupsik » 16.06.2017 01:11:45

Там же есть ответ.. по ссылке...
Код: Выделить всё
var
  zRect : TRect;
  DC : HDC;
  cBMP : HBITMAP;   
..................
  cBMP := CreateCompatibleBitmap(DC, zRect.Right - zRect.Left, zRect.Bottom - zRect.Top);
  BitMap.Handle := cBMP;

  BitBlt(BitMap.Canvas.Handle, 0, 0, zRect.Width,
         zRect.Height, Image2.Picture.Bitmap.Canvas.Handle,
         zRect.Left, zRect.Top, SRCCOPY);
pupsik
энтузиаст
 
Сообщения: 1154
Зарегистрирован: 20.08.2014 16:20:13

Re: TImage сохраняет не то, что надо

Сообщение zi000000 » 16.06.2017 01:45:34

pupsik
Спасибо большое! Я уже забросил этот вариант.
zi000000 писал(а):у человека заработало, у меня всё тот же чёрный квадрат

Благодаря Вам вернулся к нему.
Моя ошибка: cBMP := CreateCompatibleBitmap(Image2.Picture.Bitmap.Handle, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
Верно так: cBMP := CreateCompatibleBitmap(Image2.Picture.Bitmap.Canvas.Handle, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);

Добавлено спустя 34 секунды:
Теперь работает так, как ожидалось.
zi000000
новенький
 
Сообщения: 29
Зарегистрирован: 28.04.2016 19:55:49


Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 29

Рейтинг@Mail.ru