Чёрный фон BMP при SaveToFile.

[Kire313evz]

Уважаемые, прошу помочь, есть такой код

Код: Выделить всё

procedure TForm1.BitBtn1Click(Sender: TObject);
var
cdJpeg: TJpegImage;
cdBmp: TBitmap;
begin
cdJpeg:=TJpegImage.Create;
cdBmp:=TBitmap.Create;

cdJpeg.LoadFromFile('test.jpg');

cdBmp.PixelFormat:=pf24bit;
cdBmp.Width:=ImagePreview.Width;
cdBmp.Height:=ImagePreview.Height;

SetStretchBltMode(cdBmp.Canvas.Handle, HALFTONE);
StretchBlt(cdBmp.Canvas.Handle, 0, 0, cdBmp.Width, cdBmp.Height, cdJpeg.Canvas.Handle, 0, 0, cdJpeg.Width, cdJpeg.Height, SRCCOPY);


ImagePreview.Picture.Bitmap:=cdBmp;
cdBmp.SaveToFile('test.bmp') ;

cdJpeg.Free;
cdBmp.Free;
end;


масштабирую изображение,
в Bitmap ImagePreview изображение загружается, а вот сохраняет файл с чёрным фоном, нулевой контент!!!
это в Lazarus-0.9.31-29426-fpc-2.4.3-20110209-win32. Что примечательно в lazarus-0.9.28.2-fpc-2.2.4-win32 вроде как работает!
Спасибо!

[Ism]

возможно надо дополнительно преобразовывать файл, кажется вы грузите jpg, а сохраняете bmp. Возможно Bitmap настроен сохранять только изображения определенной структуры.

Или проблема с указателями, вы сохраняете не рисунок , а указатель на него (это теоретически)

[Kire313evz]

Что? Никто не встречался с такой проблемой? Или я криво объяснил?

[Ism]

попробуйте загрузить bmp и сохранить в bmp. Я не могу сказать точно , но кажется похожее у меня в delphi было.

[Kire313evz]

Ну, вот

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
var
cdBmpIn, cdBmpOut: TBitmap;
begin
cdBmpIn:=TBitmap.Create;
cdBmpOut:=TBitmap.Create;

cdBmpIn.LoadFromFile('in.bmp');

cdBmpOut.Width:=ImagePreview.Width;
cdBmpOut.Height:=ImagePreview.Height;

SetStretchBltMode(cdBmpOut.Canvas.Handle, HALFTONE);
StretchBlt(cdBmpOut.Canvas.Handle, 0, 0, cdBmpOut.Width, cdBmpOut.Height, cdBmpIn.Canvas.Handle, 0, 0, cdBmpIn.Width, cdBmpIn.Height, SRCCOPY);

ImagePreview.Picture.Bitmap:=cdBmpOut;
cdBmpOut.SaveToFile('out.bmp');
cdBmpIn.Free;
cdBmpOut.Free;
end;

Результат один - "чёрный квадрат"!!!
Тут криво работает StretchBlt!
Я так думаю!

Добавлено спустя 8 минут 21 секунду:
Прилагаю проект.

[Ism]

может попробовать
ImagePreview.Picture.Bitmap.SaveToFile('out.bmp');

чтоб наверняка
при условии что картинка отображается правильно

[Kire313evz]

Ism, друг мой, пробовал конечно, результат один! Вы test.zip скачайте попробуйте, как у Вас?

[Maxizar]

Решения:
1- Читаем вот это:
1.1Функция SetStretchBltMode, особенно про замечания о HALFTONE
1.2 Функция SetBrushOrgEx
1.3 Функция StretchBlt
1.4 Функция BitBlt
1.5 Функция CreateDIBSection

2-Мое решение(ИМХО): Если вызвать cdBmpOut.Canvas.FillRect(0,0,cdBmpOut.Width,cdBmpOut.Height); То все будет копироватся. Правильно или нет (маска копирования) косяг мне проверять... Читаем МСДН, если решите проблему отпишитесь, другим это тоже поможет. (Я просто не очень айс знаю вот эти операции копирования(ни разу не работал с этим)) Но смотрите что я тыкал, в зависимости от маски и цвета заливки, меняется выходной вариант. Правильно или нет я не вникал, возможно там и есть баги, по этому т.к вы занимаетесь этой проблемой и как видно уже не один день, вы сразу определитесь где бага, возможно там зарыта не одна кошка... если найдете пишите, тут пару ребят зарегены на багрепорты отпишут(проверят) короче сделают лазарус боллее стабильным.
Замечания: Ваша программа потребовала LCLBase>1.0.1 из за чего я удалил эту зависимость (возможно у меня сборка лазаруса более старая чем у вас)
Код:

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
var
cdBmpIn, cdBmpOut: TBitmap;
oldPoint:TPoint;
begin
  cdBmpIn :=TBitmap.Create;
  cdBmpOut:=TBitmap.Create;

  cdBmpIn.LoadFromFile('in.bmp');

  oldPoint.x:=0;
  oldPoint.y:=0;

  cdBmpOut.Width :=ImagePreview.Width;
  cdBmpOut.Height:=ImagePreview.Height;
  cdBmpOut.Canvas.Brush.Color:=clRed;
  cdBmpOut.Canvas.FillRect(0,0,cdBmpOut.Width,cdBmpOut.Height);

  SetStretchBltMode(cdBmpOut.Canvas.Handle, HALFTONE);
  //SetStretchBltMode(cdBmpOut.Canvas.Handle, BLACKONWHITE);
   //SetStretchBltMode(cdBmpOut.Canvas.Handle, WHITEONBLACK);
  //SetBrushOrgEx(cdBmpOut.Canvas.Handle,100,0,@oldPoint);
  //StretchBlt(cdBmpOut.Canvas.Handle, 0, 0, cdBmpOut.Width, cdBmpOut.Height, cdBmpIn.Canvas.Handle,
  //                                   0, 0, cdBmpIn.Width, cdBmpIn.Height, NOTSRCERASE);
    StretchBlt(cdBmpOut.Canvas.Handle, 0, 0, cdBmpOut.Width, cdBmpOut.Height, cdBmpIn.Canvas.Handle,
                                     0, 0, cdBmpIn.Width, cdBmpIn.Height, SRCCOPY);

  ImagePreview.Picture.Bitmap:=cdBmpOut;
  cdBmpOut.SaveToFile('out.bmp');

  cdBmpIn.Free;
  cdBmpOut.Free;
end;


[Ism]

Я тоже заставил работать

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
var
cdBmpIn, cdBmpOut: TBitmap;
begin
cdBmpIn:=TBitmap.Create;
cdBmpOut:=TBitmap.Create;

cdBmpIn.LoadFromFile('in.bmp');

cdBmpOut.Width:=ImagePreview.Width;
cdBmpOut.Height:=ImagePreview.Height;

cdBmpOut.Canvas.Pixels[1,1]:=clBlack;
SetStretchBltMode(cdBmpOut.Canvas.Handle, HALFTONE);
StretchBlt(cdBmpOut.Canvas.Handle, 0, 0, cdBmpOut.Width, cdBmpOut.Height, cdBmpIn.Canvas.Handle, 0, 0, cdBmpIn.Width, cdBmpIn.Height, SRCCOPY);

ImagePreview.Picture.Bitmap:=cdBmpOut;
cdBmpOut.SaveToFile('out.bmp');

cdBmpIn.Free;
cdBmpOut.Free;
end;           

достаточно добавить после создания cdBmpOut.Canvas.Pixels[1,1]:=clBlack;

Но по моему такое поведение , очевидный баг .
Пожоже TBitmap надо както инициализировать

попробуйте написать об этом сюда viewtopic.php?f=5&t=6580

[Kire313evz]

Maxizar, спасибо, буду изучать, тестировать, о результатах отпишусь.

Ism, спасибо, не знаю, возможно я поспешил, но я обратился на Bug tracker - id 0018732, жду ответа. http://mantis.freepascal.org/view.php?id=18732#bugnotes

[Ism]

Очень важно ? чтоб вы передали с описанием бага тот самый архив с примером который выложили здесь, потому что условия возникновения бага могут быть специфичными

[Kire313evz]

Да да, передал архив.