[RE-SOLVED] Splitting an image

[madref]

I would rather have it not stretched. but would love to be able to choose the size of the font and then have all letters centered.

[KodeZwerg]

I would rather have it not stretched. but would love to be able to choose the size of the font and then have all letters centered.

The problematic part is the custom size + centering but here is my first version that does do it very quick, not perfect but usable.
And because it is custom I added 2 tweaks that you need to set, OffsetX, OffsetY, this gives you the possibility to adjust the Letter in all directions.
Also I overhauled the demo GUI so you can learn what options are in what mode available.
To explain the modes:
Speed - this is the implementation of paweld just slightly modified by me
Stretched - this will fill out the box complete
Custom - this is basicly same as pawelds variant but now customizable by fontsize and offset tweaking

no fonts included in this archive.
attached is the raw project in current state.
added image to show all three modes without altering any option, just pressed on "draw".

[madref]

Thanks again...


now I hope this is done... so SOLVED !!!!!!!

[KodeZwerg]

Thanks again...


now I hope this is done... so SOLVED !!!!!!!

I am glad that this is what you wanted to have while for me it is not fully solved.
I hated my extra slow working stretched variant and begun from scratch writing a better one with the result that it is now as fast as all other methods.
Here is the code that I currently use, I hope I made no mistakes since it is first time for me that I work with a Lazarus Image Format.
I've tested with quality settings way over 100 (total overkill) that Lazarus Format is really fast. (my new default is 100 for the quality)

Code: Pascal  [Select][+][-]

1. procedure TImageFont.CroppedText(const AFont: TFont; const AText: UnicodeString; const ABackground: TColor; out AImage: TBitmap);
2.   function Max(const AValueA, AValueB: Integer): Integer; inline;
3.     begin
4.       if AValueA > AValueB then
5.         Result := AValueA
6.       else
7.         Result := AValueB;
8.     end;
9.   function Min(const AValueA, AValueB: Integer): Integer; inline;
10.     begin
11.       if AValueA < AValueB then
12.          Result := AValueA
13.        else
14.          Result := AValueB;
15.     end;
16. var
17.   LBitmap: TBitmap;
18.   LText: RawByteString;
19.   LImage: TLazIntfImage;
20.   LinePointer: PIntegerArray;
21.   CurrentX, CurrentY,
22.   FromTop, FromLeft, FromBottom, FromRight: Integer;
23.   LRect: TRect;
24. begin
25.   LText := RawByteString(AText);
26.   LBitmap := TBitmap.Create;
27.   try
28.     LBitmap.PixelFormat := pf32bit;
29.  
30.     case UTF8CodepointSizeFast(PAnsiChar(LText)) of
31.       1: LBitmap.Canvas.Font := AFont;
32.       2: begin
33.            if FontCheck('Segoe UI') then
34.              LBitmap.Canvas.Font.Name := 'Segoe UI'
35.            else
36.            if FontCheck('Tahoma') then
37.              LBitmap.Canvas.Font.Name := 'Tahoma'
38.            else
39.            if FontCheck('Arial') then
40.              LBitmap.Canvas.Font.Name := 'Arial'
41.            else
42.              LBitmap.Canvas.Font.Name := 'MS Shell Dlg 2';
43.          end;
44.     end;
45.  
46.     LBitmap.Canvas.Font.Size := FQuality;
47.     LBitmap.SetSize(LBitmap.Canvas.TextWidth(LText) * 3, LBitmap.Canvas.TextHeight(LText) * 3);
48.     LBitmap.Canvas.Brush.Color := ABackground;
49.     LBitmap.Canvas.FillRect(LBitmap.Canvas.ClipRect);
50.     LBitmap.Canvas.TextOut(0, 0, AnsiString(AText));
51.     LImage := LBitmap.CreateIntfImage;
52.  
53.     FromTop := -1;
54.     FromLeft := -1;
55.     FromBottom := -1;
56.     FromRight := -1;
57.  
58.     for CurrentY := 0 to Pred(LImage.Height) do
59.       begin
60.         LinePointer := LImage.GetDataLineStart(CurrentY);
61.         for CurrentX := 0 to Pred(LImage.Width) do
62.           begin
63.             if LinePointer^[CurrentX] <> ABackground then
64.               begin
65.                 if FromLeft = -1 then
66.                   FromLeft := CurrentX
67.                 else
68.                   FromLeft := Min(FromLeft, CurrentX);
69.  
70.                 if FromRight = -1 then
71.                   FromRight := CurrentX
72.                 else
73.                   FromRight := Max(FromRight, CurrentX);
74.  
75.                 if FromTop = -1 then
76.                   FromTop := CurrentY
77.                 else
78.                   FromTop := Min(FromTop, CurrentY);
79.  
80.                 if FromBottom = -1 then
81.                   FromBottom := CurrentY
82.                 else
83.                   FromBottom := Max(FromBottom, CurrentY);
84.               end;
85.           end;
86.       end;
87.     LImage.Free;
88.     LRect.Top := FromTop;
89.     LRect.Left := FromLeft;
90.     LRect.Right := FromRight;
91.     LRect.Bottom := FromBottom;
92.     {%H-}AImage.SetSize(LRect.Width, LRect.Height);
93.     AImage.Canvas.CopyMode := cmSrcCopy;
94.     AImage.Canvas.CopyRect(AImage.Canvas.ClipRect, LBitmap.Canvas, LRect);
95.   finally
96.     LBitmap.Free;
97.   end;
98. end;

On my todo-list just one thing missing, but I am lazy
Measure from each image the x1,x2,y1,y2 coordinates and add it into my logic so that the chars looking centered on all boxes same way.
(the boxes are not at same location on all images)

[madref]

Where do I need to put this?

[KodeZwerg]

Where do I need to put this?

It is easier for me to upload my current state than to explain (i recommend to replace this unit with the one from last archive)
This just immense speed up the "stretched" method, nothing else changed I think 

I've also uploaded my newer .lfm file where I unlocked the quality up to 1000 (while I suggest to not go over 100, wasted cycles)

[madref]

I know this is an old thread.
But I had a total harddiskfailure and my backup was corrupted  .


So know I am trying to remake an app that was evolved to version 5.4.3. Th backup I still had was 5.0.3
and this was one of the modifications I had done, but now is gone.


So i was searching the old threads and found this one.
 I got I to compile but no results because I get an error in a rare spot.
See attachment.


@KodeZwerg or @paweld..... can you help me out again?

[paweld]

Can you attach the project that's causing problems? I checked my latest project ( https://forum.lazarus.freepascal.org/index.php/topic,67070.msg516898.html#msg516898 ) and @KodeZwerg's project ( https://forum.lazarus.freepascal.org/index.php/topic,67070.msg516978.html#msg516978 - this one, because the others don't have any resources attached), and both work fine. I tested them on Windows 10 + Lazarus trunk + FPC 3.2-fixes

[madref]

Here are my files...


And the graphics are here.

[paweld]

Your resource definitions are incorrect; specifically, two files are missing from the “font54” and ‘font55’ resource definitions - replace the “lpi” file, recompile, and it should work

[madref]

Thanks Pawed (again)

Solved again...

[paweld]

You're welcome.
And for the future, I strongly recommend using some kind of VCS. Personally, I prefer SVN (it’ll be hard to find something free for private projects, but you can host public ones on SourceForge, for example), but I also use Git, and there’s a wide selection of free services available - including Codeberg, GitHub, and GitLab.