freepascal.ru

Добавлено: **09.03.2018 12:52:31**

Гружу картинку с помощью Vampyre Imaging, нужно добавить на нее текст. Штатные средства для этого искал плохо и не нашел. Долго думать не стал, решил скопировать картинку в TImage, там сделать все что надо и скопировать обратно в TMultiImage.
Сработало частично, текст рисуется только белым цветом и без алиасинга. Как сделать красивую цветную надпись?

кусок отвечающий за вывод текста и картинки

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

procedure TForm1.onCreateHandler(Sender: TObject);
var
  img:TImage;
  ts:TTextStyle;
begin
  try
    if not assigned(LImg) then
      LImg:=TMultiImage.create;
    LImg.LoadMultiFromFile('Weave.jpeg');
  except
    //MessageDlg(GetExceptObject.Message, mtError, [mbOK], 0);
    //OutputForm.Img.CreateFromParams(32, 32, ifA8R8G8B8, 1);
  end;

  //копируем из вампировского TMultiImage в TImage
  img:=TImage.Create(nil);
  if not assigned(img.Picture.Graphic) then
    img.Picture.Graphic:=TImagingBitmap.Create;
  img.Picture.Graphic.Assign(LImg);

  //настраиваем параметры вывода текста
  ts:=img.Picture.Bitmap.Canvas.TextStyle;
  ts.SingleLine:=false;
  ts.Alignment:=taLeftJustify;
  ts.Layout:=tlTop;

  img.Picture.Bitmap.Canvas.Font.Size:=80;
  img.Picture.Bitmap.Canvas.Font.Quality:=fqCleartypeNatural;
  img.Picture.Bitmap.Canvas.Font.Color:=clRed;
  img.Picture.Bitmap.Canvas.TextRect(Rect(0,0,Image1.Width,Image1.Height),0,0,'TEST',ts);

  //копируем обратно из TImage в вампировский TMultiImage
  LImg.Assign(img.Picture.Graphic);

  //выводим на форму то что получилось
  UpdateView(LImg);
end;

полная демка, вроде должна работать, ничего доустонавливать ненадо
https://yadi.sk/d/HByIdtJK3TBVue

Сейчас набегут художники и научат как правильно... только пжст без гитар и прочих камертонов))

Добавлено: **09.03.2018 13:32:30**

zub если память не изменяет: в либле есть класс канвы.
{
FBitmap: TImagingBitmap;
FImage: TMultiImage;
FImageCanvas: TImagingCanvas; //вот и малюйте в нём
}

Добавлено: **09.03.2018 14:24:03**

zub писал(а):Сейчас набегут художники и научат как правильно... только пжст без гитар и прочих камертонов))

1) Создаёшь битмапку и нарисовав на ней текст, загружаешь её в image.

2)

пжст без гитар и прочих балалаек

Ты не ценишь настоящее искусство!

Добавлено спустя 333 минут 333 секунд:
3)

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

procedure TForm1.UpdateView(pic:TMultiImage);
var
  ts:TTextStyle;
begin
  if not assigned(Image1.Picture.Graphic) then
    Image1.Picture.Graphic:=TImagingBitmap.Create;
  Image1.Picture.Bitmap.Assign(pic); // это лишнее Image1 - всё умеет

  // ! => Image1.Picture.LoadFromFile('Weave.jpeg'); // замени на нормальную картинку с балалайкой! ;) 

  ts:=Image1.Picture.Bitmap.Canvas.TextStyle;

  Image1.Canvas.Font.Size:=111;
  Image1.Canvas.Font.Quality:=fqCleartypeNatural;
  Image1.Canvas.Font.Color:=clRed;
  Image1.Canvas.TextRect(Rect(0,0,Image1.Width,Image1.Height),0,0,'TEST',ts);

  Image1.Proportional := False;
  Image1.Stretch := False;
end;

procedure TForm1.onCreateHandler(Sender: TObject);
begin
  try
    if not assigned(LImg) then
      LImg:=TMultiImage.create;
    LImg.Width:=Width;
    LImg.Height:=Height;
   // LImg.LoadMultiFromFile('Weave.jpeg');
  except
    //MessageDlg(GetExceptObject.Message, mtError, [mbOK], 0);
    //OutputForm.Img.CreateFromParams(32, 32, ifA8R8G8B8, 1);
  end;

  UpdateView(LImg);
end;

Добавлено: **09.03.2018 15:22:38**

pupsik
TImagingCanvas не умеет текстовые примитивы, только простейшие геометрические

vitaly_l
>>3)
Надпись нужна в картинке, минуя экран, хотел отделаться консольным приложением (без "экранных" и совместимых контекстов), но видимо по простому не получится

Добавлено: **09.03.2018 15:30:39**

zub писал(а):Надпись нужна в картинке, минуя экран, хотел отделаться консольным приложением (без "экранных" и совместимых контекстов), но видимо по простому не получится

Там какая-то хрень происходит после того как картинка подгружается. Если рисовать без картинки, то всё работает и текст красного цвета (см. пример кода). А после загрузки картинки, image "глючит", видимо картинка что-то там прописывает. Поэтому, рисуй всё на обычной TBitmap и будет тебе счастье.

Добавлено: **09.03.2018 15:48:12**

>>image "глючит", видимо ... что-то там ...
Всех переглючило, а художников нет))
повторяю:

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

Добавлено спустя 3 минуты 4 секунды:
ладно, с отсутствием алиасинга я готов смириться, но цвет нужен((

Добавлено: **09.03.2018 15:59:46**

zub писал(а):повторяю:
Надпись нужна в картинке, минуя экран, хотел отделаться консольным приложением (без "экранных" и совместимых контекстов), но видимо по простому не получится

повторю, рисуй на обычной битмапке, как настоящий Художник:

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

var
  ts:TTextStyle;
  bmp:TBitmap;
begin
  Image1.Picture.LoadFromFile('balalayka.bmp');
  bmp:=TBitmap.Create;
  bmp.Height:=Height;
  bmp.Width:=Width;
  ts:=bmp.Canvas.TextStyle;

  bmp.Assign(Image1.Picture.Bitmap);

  bmp.Canvas.Font.Size:=111;
  bmp.Canvas.Font.Quality:=fqCleartypeNatural;
  bmp.Canvas.Font.Color:=clRed;
  bmp.Canvas.TextRect(Rect(0,0,bmp.Width,bmp.Height),0,0,'TEST',ts);
  Image1.Picture.Bitmap.Assign(bmp);

И не забудь освободить битмапку, как настоящий Программист.

.

Добавлено: **09.03.2018 16:44:13**

vitaly_l
виталик, ты как клоун. давай уже исправляйся

Проблема оказалась чуток не тут. если LImg сохранить в файл, то там надпись красная :shock:

для эксперимента в исходном примере замените onCreateHandler на

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

procedure TForm1.onCreateHandler(Sender: TObject);
var
  img:TImage;
  ts:TTextStyle;
begin
  try
    if not assigned(LImg) then
      LImg:=TMultiImage.create;
    LImg.LoadMultiFromFile('Weave.jpeg');
  except
    //MessageDlg(GetExceptObject.Message, mtError, [mbOK], 0);
    //OutputForm.Img.CreateFromParams(32, 32, ifA8R8G8B8, 1);
  end;

  //копируем из вампировского TMultiImage в TImage
  img:=TImage.Create(nil);
  if not assigned(img.Picture.Graphic) then
    img.Picture.Graphic:=TImagingBitmap.Create;
  img.Picture.Graphic.Assign(LImg);

  //настраиваем параметры вывода текста
  ts:=img.Picture.Bitmap.Canvas.TextStyle;
  ts.SingleLine:=false;
  ts.Alignment:=taLeftJustify;
  ts.Layout:=tlTop;

  img.Picture.Bitmap.Canvas.Font.Size:=80;
  img.Picture.Bitmap.Canvas.Font.Quality:=fqCleartypeNatural;
  img.Picture.Bitmap.Canvas.Font.Color:=clRed;
  img.Picture.Bitmap.Canvas.TextRect(Rect(0,0,Image1.Width,Image1.Height),0,0,'TEST',ts);

  //копируем обратно из TImage в вампировский TMultiImage
  LImg.Assign(img.Picture.Graphic);
  //сохраняем что у нас там получилось
  LImg.SaveMultiToFile('out.jpg');

  //выводим на форму то что получилось
  UpdateView(LImg);
end;

как это объяснить?

Добавлено: **09.03.2018 17:01:47**

zub писал(а):как это объяснить?

Маска. Там какая-то маска. Понимаешь зачем в тексте маска? Даю подсказку => прозрачность / заливка.

zub писал(а):виталик, ты как клоун. давай уже исправляйся

Сам ты клоун, сам и исправляйся. Вместо того чтобы взять обычную TBitmap,
веселишь народ, грузишь сторонние приблуды для рисования слова "тест".

zub писал(а):если LImg сохранить в файл, то там надпись красная

Сделай как написано, и там и там текст будет красным.

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

var
  ts:TTextStyle;
  bmp:TBitmap;
begin
  Image1.Picture.LoadFromFile('balalayka.jpg');
  bmp:=TBitmap.Create;
  bmp.Height:=Height;
  bmp.Width:=Width;
  ts:=bmp.Canvas.TextStyle;

  bmp.Assign(Image1.Picture.Bitmap);

  bmp.Canvas.Font.Size:=111;
  bmp.Canvas.Font.Quality:=fqCleartypeNatural;
  bmp.Canvas.Font.Color:=clRed;
  bmp.Canvas.TextRect(Rect(0,0,bmp.Width,bmp.Height),0,0,'TEST',ts);
  Image1.Picture.Bitmap.Assign(bmp);

PS: И не забудь освободить битмапку...

Добавлено: **09.03.2018 22:59:05**

>>image "глючит", видимо картинка что-то там прописывает
>>Там какая-то хрень происходит после того как картинка подгружается
>>Там какая-то маска.
Если бы меня устраивали такие ответы я бы не создавал тем на форуме

>>Понимаешь зачем в тексте маска?
нет, не понимыю. я непросил никаких масок
>>Даю подсказку => прозрачность / заливка.
Видищь сусликов? где там какие прозрачности и заливки?

>>Сделай как написано, и там и там текст будет красным.
Как надо сделать описано в первом посте. Есть TMultiImage с картинкой, в него надо вписать цветной текст и отдать обратно. ферштейн?
Ты пишешь текст на экранный канвас, мне нужно писать на "чтото" в памяти, не асоциированое с устройством отображения. ферштейн?

Добавлено: **09.03.2018 23:39:53**

zub, поступай как я и не корми:

Автором этого сообщения является vitaly_l, находящийся в вашем чёрном списке. Показать это сообщение.

По теме: не знал, что Vampyre такое умеет, я как взял версию 0.24.3 от июня 2007-го, так на ней и сижу, потихоньку фикся откровенные баги типа ptruint = cardinal

Добавлено: **10.03.2018 12:17:35**

zub писал(а):Как надо сделать описано в первом посте. Есть TMultiImage с картинкой, в него надо вписать цветной текст и отдать обратно. ферштейн?
Ты пишешь текст на экранный канвас, мне нужно писать на "чтото" в памяти, не асоциированое с устройством отображения. ферштейн?

Это наверное очень удивит, но стоит мне загрузить ваш проект, как перестаёт работать Timage. Однако, если я создаю новый проект, загружаю картинку и там рисую текст в Timage, то он рисуется красным на картинке. Но стоит мне тоже самое сделать в вашем проекте, как текст начинает рисоваться белым. Вы как-то там поломали Timage или точнее какие-то запчасти от него, когда подключали Vampyre. Я при тесте Timage даже не подгружаю TMultiImage в вашем проекте и закомментировал его юниты, но всё равно если беру ваш проект то рисуется белым. А если создаю новый проект, то в Timage всё работает и текст рисуется красным. ферштейн, кто всё поломал? :wink:

Добавлено спустя 111 час 111 минут 111 секунд:

zub писал(а):Проблема оказалась чуток не тут. если LImg сохранить в файл, то там надпись красная

Попробуйте сохранить img и удивитесь ещё больше, т.к. текст вообще будет то серым, то красным (в зависимости где смотреть). Такое возможно из-за разной битности или иных цветовых установок у Vampyre и TImage. И похоже Vampyre, как-то "подменил" установки битности по умолчанию у TImage и последнего от этого сильно глючит, тогда дело не в маске а в битности. Короче проблема в разной битности получаемых и обрабатываемых картинок, т.к. лазарус по умолчанию работает только с 24 битами, а Vampyre с 32. + ещё маска

Добавлено: **10.03.2018 18:13:35**

Художники, однако

Добавлено спустя 2 часа 48 минут 59 секунд:
Немного попробую пояснить.
Сам вампир предназначен для просмотра изображения. Его битмап только показывает что в TMultiImage (не только) загружено. Т.е. работа с битмапом - сродни кощунству (по логике). Всё должно быть через TImagingCanvas. Поэтому и такое странное поведение. Вроде есть, а цвета нет. И, возможно, баг в самой вампирке (хотя... если битмап только для отображения... не будет это поведение багом... баг - то что показывает текст).

Верно подмечено:

TImagingCanvas не умеет текстовые примитивы, только простейшие геометрические

не только... А вот с текстом, вроде как, не умеет. Вполне возможно можно научить. Но это ещё один велик (ведь есть внутренние наборы и bgra, и agg).

То что хочет zub схоже на работу со слоями. Но опять нюанс - не работает с текстом. Сможете нарисовать текст в TSingleImage используя канву вампира. Сможете и совместить изображения, или работать с самим изображением. Т.о. получится ферштейн:

мне нужно писать на "чтото" в памяти, не асоциированое с устройством отображения. ферштейн?

В вапмирке есть ещё и иные возможности подгрузки изображений. Но...о: зачем? Ведь можно нарисовать ваше желаемое внутренними наборами лазаря и не печалиться (голову ломая).

Добавлено спустя 1 час 44 минуты 20 секунд:
походу ошибся я в суждениях. На оф форуме советуют рисовать буковки на TImagingBitmap . Оно то рисует, но...

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

  FIm.SaveMultiToFile('im' + '.' + Fext);//сохраняет всё нормально... т.е. можно и в основном битмапе такое делать
  FImage.AssignFromArray(Fim.DataArray);//этих методов хоть греблю гати, а толку нет.
  FImage.SaveMultiToFile('fim' + '.' + Fext);//сохраняет всё нормально
  Image1.Picture.Graphic.Assign(FImage);  //серая мышЬ

И схожие попытки выдают интереснейшую цветовую гамму :mrgreen:

И более/менее костыль - сбрасывать в поток и оттуда тянуть.
Шо ж там так закручено что "теряет" цвет при игре с битмапом?

Добавлено: **13.03.2018 00:14:28**

Ковыряния показали - проблема связана с альфаканалом, на этапе

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

TPicture.Graphic.Assign(TMultiImage);

т.е. при копировании из TMultiImage в TPicture добавляется альфаканал, заполняемый значением 255. если исходники Vampyre поправить и заполнить альфу нулем, то все начинает работать.

Это ведь не баг, как можно обойти без правки Vampyre?

Добавлено спустя 11 минут 48 секунд:
>>S: И не забудь освободить битмапку...
Проблема совсем не в освобождении чегото, мемлики будут пофикшены позже - на этапе отладки. в минидемке уж извини, цель показать проблему, а не прослезить художников идеальным кодом

>>А если создаю новый проект, то в Timage всё работает и текст рисуется красным. ферштейн, кто всё поломал? :wink:

В твоем высокохудожестваенном ничегонеломающем проекте timage формощлепнуто. в моем кривущем и забагованном timage создается в рантайме и не асоциирована формой. вот и вся разница. или нет?

Добавлено: **13.03.2018 01:20:23**

zub а вы нахал, однако, барин... Доковыряли всё же

freepascal.ru

Надпись на картинке Vampyre Imaging

Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging

Re: Надпись на картинке Vampyre Imaging