VPF::Склеить 2 png - Форум программистов

Akella

Дата 29.8.2013, 00:00 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

Как на Delphi склеить 2 png. Одну картинку поставить рядом с другой. Картинки горизонтальные, вот такие: http://rghost.ru/private/48437911/c6e3d900...feedf1144fc11e1

Delphi XE3

да, с графикой я не очень дружу :(

Alexeis

Дата 29.8.2013, 07:58 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

png склеиваются после преобразования из в bmp. Создаешь битмап нужного размера и формата рисуешь на нем свои битмапы, затем пожимаешь обратно в png.

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

Akella

Дата 29.8.2013, 11:10 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

Тут есть у меня код, но он неправильно работает с png без альфа-канала.

Код


procedure MergePNGLayer(Layer1,Layer2: TPngImage; Const aLeft,aTop:Integer);
var
  x, y: Integer;
  SL1,  SL2,  SLBlended : pRGBLine;
  aSL1, aSL2, aSLBlended: Vcl.Imaging.pngimage.pByteArray;
  blendCoeff: single;
  blendedPNG, Lay2buff: TPngImage;
begin
  blendedPNG:=TPngImage.Create;
  blendedPNG.Assign(Layer1);
  Lay2buff:=TPngImage.Create;
  Lay2buff.Assign(Layer2);
  SetPNGCanvasSize(Layer2,Layer1.Width,Layer1.Height,aLeft,aTop);
  for y := 0 to Layer1.Height-1 do
  begin
    SL1 := Layer1.Scanline[y];
    SL2 := Layer2.Scanline[y];
    aSL1 := Layer1.AlphaScanline[y];
    aSL2 := Layer2.AlphaScanline[y];
    SLBlended := blendedPNG.Scanline[y];
    aSLBlended := blendedPNG.AlphaScanline[y];
    for x := 0 to Layer1.Width-1 do
    begin


      blendCoeff:=aSL1[x] * 100/255/100;// здесь вываливается AV



      aSLBlended[x] := round(aSL2[x] + (aSL1[x]-aSL2[x]) * blendCoeff);
      SLBlended[x].rgbtRed   := round(SL2[x].rgbtRed + (SL1[x].rgbtRed-SL2[x].rgbtRed) * blendCoeff);
      SLBlended[x].rgbtGreen := round(SL2[x].rgbtGreen + (SL1[x].rgbtGreen-SL2[x].rgbtGreen) * blendCoeff);
      SLBlended[x].rgbtBlue  := round(SL2[x].rgbtBlue + (SL1[x].rgbtBlue-SL2[x].rgbtBlue) * blendCoeff);
    end;
  end;
Layer1.Assign(blendedPNG);
Layer2.Assign(Lay2buff);
blendedPNG.Free;
Lay2buff.Free;
end;

blendCoeff:=aSL1[x] * 100/255/100;// здесь вываливается AV

я так понимаю, что нужно сделать какие-то исправления, но... я не знаю какие

Добавлено через 5 минут и 27 секунд
Мне почему-то не приходят уведомления :(, хотя я подписан на эту тему

Добавлено через 8 минут и 59 секунд
В общем я сделал проще.
Картинку без альфа-канала я конвертирую в картинку с альфаканалом

Код


procedure ConvertToRGBA(var png: TPNGImage);
var
  tmp: TPNGImage;
  tRNS: TChunktRNS;
  PLTE: TChunkPLTE;
  dst: pRGBLine;
  src, alpha: Vcl.Imaging.pngimage.pByteArray;
  x,y: integer;
  i: byte;
begin
  tmp := TPNGImage.CreateBlank(COLOR_RGBALPHA, 8, png.Width, png.Height);
  case png.Header.ColorType of
    COLOR_PALETTE:
    begin
      tRNS:=png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
      PLTE:=png.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE;
      for y:=0 to png.Height-1 do begin
        dst:=tmp.Scanline[y];
        src:=png.Scanline[y];
        alpha:=tmp.AlphaScanline[y];
        for x:=0 to png.Width-1 do begin
          case png.Header.BitDepth of
            8:   i := src[x];
            2,4: i := src[x div 2] shr ((1-(x mod 2))*4) and $0F;
            1:   i := src[x div 8] shr (7-(x mod 8)) and 1;
          end;
          dst[x].rgbtBlue :=PLTE.Item[i].rgbBlue;
          dst[x].rgbtGreen:=PLTE.Item[i].rgbGreen;
          dst[x].rgbtRed  :=PLTE.Item[i].rgbRed;
          if tRNS<>nil then alpha[x]:=tRNS.PaletteValues[i] else alpha[x]:=255;

        end;
      end;
    end;

    COLOR_GRAYSCALE:
    begin
      for y:=0 to png.Height-1 do begin
        dst:=tmp.Scanline[y];
        src:=png.Scanline[y];
        alpha:=tmp.AlphaScanline[y];
        for x:=0 to png.Width-1 do begin
          case png.Header.BitDepth of
            8: i:=src[x];
            2,4: i:=(src[x div 2] shr ((1-(x mod 2))*4) and $0F) * 17;
            1: i:=(src[x div 8] shr (7-(x mod 8)) and 1) * 255;
          end;
          dst[x].rgbtBlue:=i;
          dst[x].rgbtGreen:=i;
          dst[x].rgbtRed:=i;
          alpha[x]:=255;
        end;
      end;
    end;

    COLOR_RGB:
    begin
      BitBlt(tmp.Canvas.Handle, 0,0, tmp.Width,tmp.Height, png.Canvas.Handle, 0,0, SRCCOPY);
      for y:=0 to png.Height-1 do
        FillChar(tmp.AlphaScanline[y]^, png.Width, 255);
    end;

    COLOR_GRAYSCALEALPHA:
    begin
      BitBlt(tmp.Canvas.Handle, 0,0, tmp.Width,tmp.Height, png.Canvas.Handle, 0,0, SRCCOPY);
      for y:=0 to png.Height-1 do
        Move(png.AlphaScanline[y]^, tmp.AlphaScanline[y]^, png.Width);
    end;

    else tmp.Assign(png);
  end;
  png.Free;
  png:=tmp;
end;

Alexeis

Дата 29.8.2013, 11:59 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

Akella, просто автор неправильно сделал. Когда имеются 2е картинки, то они не обязаны иметь одинаковый формат.
Правильным решением будет привести их к одному формату (какой зависит от задачи) и тогда объединять. Если же альфаканал совсем не нужен, то просто рисуй их методом Draw Canvas-a на битмапе, а его жми в пнг.

--------------------

Akella

Дата 29.8.2013, 12:24 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

Что я делаю не так?
Процедура нормально склеивает два BMP и потом передаётся в png

Код


procedure CombinePics(png1, png2, png1_res: TPngImage);
var
  b1, b2, b3: TBitmap;
begin

  b1 :=TBitmap.Create;
  b2 :=TBitmap.Create;
  b3 :=TBitmap.Create;

  b1.Assign(png1);
  b2.Assign(png2);

  b3.Width := b1.Width + b2.Width;

  if b1.Height > b2.Height then
    b3.Height := b1.Height
  else
    b3.Height := b2.Height;

  b3.Canvas.Draw(0, 0, b1);
  b3.Canvas.Draw(b1.Width, 0, b2);
//  b3.SaveToFile('d:\b3.bmp');

  png1_res := TPngImage.Create;

  png1_res.Assign(b3);
  png1_res.SaveToFile('d:\11.png');//здесь сохраняется картинка нормально на диск, видно ,что картинки склеены корректно

  b1.Free;
  b2.Free;
  b3.Free;
end;

Вот как использую, но сохраняется пустой файл в итоге

Код


Var
  png1, png2, png_res: TPngImage;
begin
...
...
...
      png1 := TPngImage.Create;
      png2 := TPngImage.Create;
      png_res := TPngImage.Create;
//загружаю картинки из MemoryStream
      png1.LoadFromStream(Arr[0].img);
      png2.LoadFromStream(Arr[1].img);
      CombinePics(png1, png2, png_res);//склеиваю


      png_res.SaveToFile('d:\_merge1.png');// сохраняется пустой файл


...
...
...

Добавлено через 12 минут и 6 секунд
Я так понял, что нужно добавить VAR

Код


procedure CombinePics(var png1, png2, png1_res: TPngImage);
begin
...

phomm

Дата 29.8.2013, 12:56 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 38
Регистрация: 7.10.2010

Репутация: нет
Всего: 1

Я пользуюсь примерно таким (адаптируя для каждой задачи, как и сейчас - тут подредактировал, могут быть микрокосяки):

Код


function RGBTripleToColor(const C: Windows.TRGBTriple): Graphics.TColor;
begin
  Result := Windows.RGB(C.rgbtRed, C.rgbtGreen, C.rgbtBlue);
end;

procedure ProcessPng(png: TPNGObject);
var
  x, y: Integer;
  scan: PRGBline;
begin
  for y := 0 to png.Header.Height - 1 do
  begin
    scan := png.Scanline[y];
    for x := 0 to png.Header.Width - 1 do
      case RGBTripleToColor(scan^[x]) of
        //transcol, transcol2, transcol3, transcol4:
        clWhite:
          png.AlphaScanline[y]^[x] := 0;
//        shade1, shade2, shade3, shade4, shade5:
//          begin
//            Scan^[x].rgbtBlue := 0;
//            Scan^[x].rgbtGreen := 0;
//            Scan^[x].rgbtRed := 0;
//            png.AlphaScanline[y]^[x] := alphavalue_for_shadow;
//          end;
      end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
const
  PicCnt = 2;
var
  Pics: array[0..PicCnt - 1] of TPNGObject;
  Bmp: Graphics.TBitmap;
  i, Xpos, MaxHg: Integer;
begin
  Pics[0].ImgPath := '1.png';
  Pics[1].ImgPath := '2.png';

  for i := 0 to PicCnt - 1 do
  begin
    Pics[i] := TPNGObject.Create();
    Pics[i].LoadFromFile(Pics[i].ImgPath);
  end;

  Bmp := TBitmap.Create();
  Bmp.PixelFormat := pf32bit;
  MaxHg := Pics[0].Height;
  for i := 0 to PicCnt - 1 do
  begin  
    Bmp.Width := Bmp.Width + Pics[1].Width;
    Bmp.Height := Max(Pics[i].Height, MaxHg);
    MaxHg := Bmp.Height;
  end;

  Xpos := 0;
  for i := 0 to PicCnt - 1 do
  begin
    Bmp.Canvas.Draw(Xpos, 0, Pics[i]);
    Xpos :=  Pics[i].Width;
  end;

  FinalResult := TPNGObject.CreateBlank(COLOR_RGB, 8, Bmp.Width, Bmp.Height);
  FinalResult.CreateAlpha();
  FinalResult.Canvas.Draw(0, 0, Bmp); 
  ProcessPng(FinalResult); // обработка для преобразования, в частности, белого в альфу
  FinalResult.SaveToFile('result.png');

  for El := 0 to PicCnt - 1 do
    FreeAndNil(Pics[i].Png);
  FreeAndNil(Bmp);
  FreeAndNil(FinalResult);
end;

По идее, зависимости быть не должно, но работало под дельфи7 с внешней библиотекой pngimage, для дельфи выше 2009 вроде всё уже включено

Akella

Дата 29.8.2013, 13:08 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

Да, только в новых версиях не TPNGObject, а TPNGImage и в uses нужно подключать Vcl.Imaging.pngimage
В Вашем коде достаточно будет переименовать TPNGObject в TPNGImage.
Ещё один момент. в секции VAR вместо pByteArray нужно использовать Vcl.Imaging.pngimage.pByteArray

Код


var
  src, alpha: Vcl.Imaging.pngimage.pByteArray;

Alexeis

Дата 29.8.2013, 13:19 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

Метод b1.Assign(png1); не работает. вместо него есть png1.AssignTo(b1);

--------------------

Akella

Дата 29.8.2013, 13:28 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

почему это не работает, ведь склеивает, значит работает

x128

Дата 30.8.2013, 11:46 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 88
Регистрация: 29.9.2009

Репутация: 5
Всего: 7

Цитата(Akella @ 29.8.2013, 13:08

)

В Вашем коде достаточно будет переименовать TPNGObject в TPNGImage.Ещё один момент. в секции VAR вместо pByteArray нужно использовать Vcl.Imaging.pngimage.pByteArray

В XE можно использовать и TPNGObject, его оставили для совместимости, вероятно так и в более новых версиях. pByteArray всегда жил в SysUtils т.ч. нет необходимости явно вытаскивать из PNGImage.

Что касается сабжа. Чем не устроил метод Draw в PNGImage? Столько сложностей на пустом месте...

Код


procedure DrawImage(const Dst, Src: TPNGImage; const X,Y: integer; const Expand: boolean=true);
var
  OldH, OldW: integer;
  NewH, NewW: integer;
begin
  if Expand then begin
    OldH:=Dst.Height;
    OldW:=Dst.Width;
    NewH:=max(OldH, Y+Src.Height);
    NewW:=max(OldW, X+Src.Width);
    Dst.Resize(NewW, NewH);
    with Dst.Canvas do begin
      Brush.Color:=clWhite;
      FillRect(Rect(OldW, 0, NewW, OldH));
      FillRect(Rect(0, OldH, NewW, NewH));
    end;
  end;
  Src.Draw(Dst.Canvas, Rect(X, Y, X+Src.Width, Y+Src.Height));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  png, tmp: TPNGImage;
  i: integer;
begin
  png:=TPNGImage.CreateBlank(COLOR_RGB, 8, 0, 0);

  tmp:=TPNGImage.Create;
  tmp.LoadFromFile('111.png');
  for i:=0 to 4 do DrawImage(png, tmp, 0,png.Height);
  tmp.Free;

  png.SaveToFile('5in1.png');
  png.Free;
end;

результат: http://rghost.ru/private/48466783/fb3acb34...07a5e8666c534ae

Akella

Дата 30.8.2013, 11:53 (ссылка)

(нет голосов)

Загрузка ...

Творец

Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 1
Всего: 329

x128, кто сказал, что не устраивает?

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Звук, графика и видео \| Следующая тема »