Recent

Author Topic: [SOLVED] Splitting an image  (Read 8888 times)

paweld

  • Hero Member
  • *****
  • Posts: 1058
Re: splitting an image
« Reply #15 on: April 25, 2024, 02:44:37 pm »
Code: Pascal  [Select][+][-]
  1. var
  2.   bmp, part: TBGRABitmap;
  3.   filename: String;
  4.   limit: Integer;
  5. begin
  6.   filename := 'd:\Downloads\Men Group Holding Up Division Information Signs [Zwart].png';
  7.   bmp := TBGRABitmap.Create(filename);
  8.   limit := trunc(bmp.Width * 0.42);
  9.   part := TBGRABitmap.Create;
  10.   part := bmp.GetPart(Rect(0, 0, limit, bmp.Height));
  11.   part.SaveToFile(ChangeFileExt(filename, ' - part 1.png'));
  12.   part := bmp.GetPart(Rect(limit, 0, bmp.Width, bmp.Height));
  13.   part.SaveToFile(ChangeFileExt(filename, ' - part 2.png'));
  14.   part.Free;
  15.   bmp.Free;
  16. end;    
Best regards / Pozdrawiam
paweld

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #16 on: April 26, 2024, 10:17:50 am »
Why does everyone think I want to save the file....


I just want to split a picture up in two parts without saving it but showing it in two TImages.
I use a TImageList where I store my pictures. The are all the same but a different color.


I managed to get this far with the help of everyone here.
Code: Pascal  [Select][+][-]
  1.   LBMP := TBitmap.Create;
  2.   try
  3.     HalfBMP := TBitmap.Create;
  4.     try
  5. //      LBMP := Image_Divisie.Picture.Bitmap;
  6.       case KleurPop of
  7.         Oranje : ImageList_Divisie.GetBitmap(0,LBMP); // Oranje
  8.         Rood   : ImageList_Divisie.GetBitmap(1,LBMP); // Rood
  9.         Blauw  : ImageList_Divisie.GetBitmap(2,LBMP); // Blauw
  10.         Groen  : ImageList_Divisie.GetBitmap(3,LBMP); // Groen
  11.         Paars  : ImageList_Divisie.GetBitmap(4,LBMP); // Paars
  12.         Geel   : ImageList_Divisie.GetBitmap(5,LBMP); // Geel
  13.         Zwart  : ImageList_Divisie.GetBitmap(6,LBMP); // Zwart
  14.       end;  // case
  15. //      X := LBMP.Width div 2; // at that position I do split the image
  16.       X := 270;
  17.       HalfBMP.Width := X;
  18.       HalfBMP.Height := LBMP.Height;
  19.       // left half:
  20.       HalfBMP.Canvas.CopyRect(Rect(0, 0, X, LBMP.Height), LBMP.Canvas, Rect(0, 0, X, LBMP.Height));
  21.       Image_Divisie1.Picture.Bitmap.Assign(HalfBMP);
  22.       Image_Divisie1.Repaint;
  23.       // right half:
  24. //      HalfBMP.Canvas.CopyRect(Rect(0, 0, X, LBMP.Height), LBMP.Canvas, Rect(X, 0, LBMP.Width, LBMP.Height));
  25. //      Image3.Picture.Bitmap.Assign(HalfBMP);
  26.     finally
  27.       HalfBMP.Free;
  28.     end;
  29.   finally
  30.     LBMP.Free;
  31.   end;
  32.  


But then I get a Black background. How to compensate for this because in the original images the background is transparent
You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

wp

  • Hero Member
  • *****
  • Posts: 12069
Re: splitting an image
« Reply #17 on: April 26, 2024, 11:24:17 pm »
Extracting a bitmap from an ImageList via GetBitmap seems to reduce the pixel format to 24 bpp and thus to remove the alpha-channel transparency. Using the similar method ImageList.GetRawImage, however, does not change the pixelformat. A RawImage can be converted to a bitmap by means of the TBitmap.LoadfromRawImage method.

Code: Pascal  [Select][+][-]
  1. uses
  2.   GraphType, Graphics, ...
  3.  
  4. procedure TForm1.Button1Click(Sender: TObject);
  5. var
  6.   rawImg: TRawImage;    // just a record, no construction/destruction needed!
  7.   bmp, leftbmp, rightbmp: TCustomBitmap;
  8. begin
  9.   // Get the raw image data from the imagelist keeping the alpha channel
  10.   ImageList1.GetRawImage(0, rawImg);
  11.  
  12.   bmp := TBitmap.Create;
  13.   try
  14.     // Convert the raw image to a bitmap
  15.     bmp.LoadFromRawImage(rawImg, false);
  16.  
  17.     // Create a bitmap for the left part of the initial image ...
  18.     leftbmp := TBitmap.Create;
  19.     try
  20.       leftbmp.PixelFormat := pf32bit;    // Important!
  21.       leftbmp.SetSize(270, bmp.Height);
  22.       leftbmp.Canvas.Draw(0, 0, bmp);
  23.       // ... and assign it to the TImage component on the form
  24.       Image1.AutoSize := true;
  25.       Image1.Picture.Assign(leftbmp);
  26.     finally
  27.       leftbmp.Free;
  28.     end;
  29.  
  30.     // dt. with the right part of the initial image.
  31.     rightbmp := TBitmap.Create;
  32.     try
  33.       rightbmp.PixelFormat := pf32bit;
  34.       rightbmp.SetSize(bmp.Width - 270, bmp.Height);
  35.       rightbmp.Canvas.Draw(-270, 0, bmp);
  36.       Image2.AutoSize := true;
  37.       Image2.Picture.Assign(rightbmp);
  38.     finally
  39.       rightbmp.Free;
  40.     end;
  41.   finally
  42.     bmp.Free;
  43.   end;
  44. end;      
« Last Edit: April 26, 2024, 11:30:15 pm by wp »

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: splitting an image
« Reply #18 on: April 26, 2024, 11:47:02 pm »
IMHO the better choice would be to create a custom method that generate such stuff.
Having each single person with a blank sign saved as PNG and included in resource.
While preparing those files put attention on those signs that they are always at same (TRect) coordinates and having same width dimension.
(so begin with the biggest one to know the width for the rest and center the smaller ones if needed)
Build a method that accept a string and a TFont as input arguments and output should be a TPortableNetworkGraphic.
Within method create a TBitmap to prepare a high scaled letter, white background, font color as font color lol, downscale it to the sign TRect dimension (cheap antialias effect that way), pick random one of the PNGs from resource, draw the bitmap onto the PNG, store that in an array and continue with next letter same way.
When all letter/persons are prepared simply loop over that array and merge each PNG onto the output PNG.

Sound like a lot but thats how I would realize such and its reusable with any font on the fly.
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #19 on: May 04, 2024, 03:52:25 pm »

@KodeZwerg
[/size]That is a great idea. But I have never tried such a thing....
Can you help me build it?
You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: splitting an image
« Reply #20 on: May 04, 2024, 06:24:56 pm »

@KodeZwerg
That is a great idea. But I have never tried such a thing....
Can you help me build it?
I can help to write an alpha version that just do what I've suggested, I would need a prepared image (png) set of different shapes (that person that holding a sign) where each image has same dimension and the sign canvas is at same coordinate. A version for different sized base images with different TRect canvas dimensions and locations is also possible but needs than those variables to work with.
So it depend on your files how I would prepare an alpha version :D
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #21 on: May 04, 2024, 07:19:38 pm »
i have added 1 set of png's. Later on I would like to make it multicolored (Orange, Red, Blue, Green, Yellow, Purple and Black).
All png's are 35x100 pixels. A space in the sentence should be max 20 pixels.

Png 6-10 are mirror's of 1-5.
I would like to start every word with PNG_1 and end with PNG_10.

So:
if the word is PIXEL then PNG's should be 01-02-05-09-10.
if the word is PIXELS then PNG's should be 01-02-05-06-09-10.
If the word is INFORMATION the PNG's should be 01-02-03-04-05-05-06-07-08-09-10

I hope you can help me.
« Last Edit: May 04, 2024, 07:24:03 pm by madref »
You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: splitting an image
« Reply #22 on: May 04, 2024, 07:51:54 pm »
My current way would be pretty simple to follow or modify.
I create a list of integers, throw all available indexes into (0..10 exemplary)
In the "PaintALetter" method I would pick a random index value via random method :D and take that number out of the list,
repeat that until no more numbers left, if count reached 0 refill all numbers and just check that "lastIndex" and "randomPick" isn't same.
That way its most "random" if you understand how I meaning it at all.
To customize this should not make that much trouble, first we need a working alpha and then we can finetune this and that.
A space character would be with my logic having same size as any other character would have to keep easy track over max needed width (chars * width)

By a quick look, your files are good to start coding something for them :D
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #23 on: May 04, 2024, 09:25:43 pm »
i am an amatuer...so i need and example :)

You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

paweld

  • Hero Member
  • *****
  • Posts: 1058
Re: splitting an image
« Reply #24 on: May 05, 2024, 10:47:54 am »
my suggestion, bgrabitmap required
« Last Edit: May 05, 2024, 10:52:12 am by paweld »
Best regards / Pozdrawiam
paweld

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #25 on: May 05, 2024, 02:37:31 pm »
Thanks for the demo.....


But how do I load a font from a file (Referee.TTF)?
You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: splitting an image
« Reply #26 on: May 05, 2024, 02:44:36 pm »
I am working on it without BGRA needed, having some problems with transparency :D
Right now it just draw and display the last "letter".
You will need to extract the image-set into this folder so it can link them into binary.
Here is my current code, in attachment the project.
Code: Pascal  [Select][+][-]
  1. unit uFont;
  2.  
  3. {$mode ObjFPC}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Windows,
  9.   Classes,
  10.   SysUtils,
  11.   Forms,
  12.   Graphics,
  13.   fpCanvas, IntfGraphics, LazCanvas;
  14.  
  15. type
  16.  
  17.   { TImageFont }
  18.  
  19.   TImageFont = class(TObject)
  20.     strict private
  21.       type
  22.         TImages = array of TPicture;
  23.         TIntArray = array of Integer;
  24.       const
  25.         CImageCount = Integer(10); // this number controls how many resources implemented (absolute number, 0 mean 0, 1 mean 1 etc)
  26.         CImageWidth = Integer(35); // generic fixed width per character
  27.         CImageHeight = Integer(100); // generic fixed height per character
  28.         CCanvasTop = Integer(10); // controls the top of the canvas
  29.         CCanvasLeft = Integer(7); // controls the left of the canvas
  30.         CCanvasWidth = Integer(25); // controls the width of the canvas
  31.         CCanvasHeight = Integer(30); // controls the height of the canvas
  32.     strict private
  33.       FText: WideString;
  34.       FSize: Integer;
  35.       FFont: TFont;
  36.       FBackground: TColor;
  37.       FImage: TPicture;
  38.       FImagePool: TImages;
  39.       FLastIndex: Integer;
  40.       FStretch: Boolean;
  41.       FTempArray: TIntArray;
  42.     private
  43.       procedure SetBackground(const AValue: TColor);
  44.       procedure SetFont(const AValue: TFont);
  45.       procedure SetSize(const AValue: Integer);
  46.       procedure SetStretch(const AValue: Boolean);
  47.       procedure SetText(const AValue: WideString);
  48.       function FontCheck(const AFontFaceName: WideString): Boolean;
  49.       function BuildImageList: Boolean;
  50.       procedure ResetTempArray;
  51.       function PickRandom: Integer;
  52.       procedure ExactTextPixels(const AFont: TFont; const AText: string; const ABackground: TColor; out AImage: TBitmap);
  53.       procedure CreateRescaleBitmap(const Source: TBitmap; const Width, Height: Integer; out Rescaled: TBitmap);
  54.       procedure AntiAliasedStretchDrawBitmap(SourceBitmap, DestBitmap: TCustomBitmap);
  55.     protected
  56.     public
  57.       constructor Create;
  58.       destructor Destroy; override;
  59.     published
  60.       property Text: WideString read FText write SetText;
  61.       property Size: Integer read FSize write SetSize default 9;
  62.       property Font: TFont read FFont write SetFont;
  63.       property Background: TColor read FBackground write SetBackground default clNone;
  64.       property Image: TPicture read FImage;
  65.       property Stretch: Boolean read FStretch write SetStretch default True;
  66.   end;
  67.  
  68. implementation
  69.  
  70. // import the pictures to resource section
  71. {$R 'images.rc'}
  72.  
  73. { TImageFont }
  74.  
  75. constructor TImageFont.Create;
  76. var
  77.   LPNG: TPortableNetworkGraphic;
  78. begin
  79.   inherited Create;
  80.   Randomize;
  81.   FText := '';
  82.   FLastIndex := -1;
  83.   FSize := 9;
  84.   FFont := TFont.Create;
  85.   // try setup a default (windows) font
  86.   if FontCheck('Segoe UI') then
  87.     FFont.Name := 'Segoe UI'
  88.   else
  89.   if FontCheck('Tahoma') then
  90.     FFont.Name := 'Tahoma'
  91.   else
  92.   if FontCheck('MS Shell Dlg 2') then
  93.     FFont.Name := 'MS Shell Dlg 2';
  94.   FFont.Color := clBlack;
  95.   FBackground := clNone;
  96.   BuildImageList;
  97.   ResetTempArray;
  98.   FImage := TPicture.Create;
  99.   LPNG := TPortableNetworkGraphic.Create;
  100.   try
  101.     LPNG.SetSize(0, 100);
  102.     LPNG.TransparentMode := tmFixed;
  103.     LPNG.TransparentColor := clNone;
  104.     LPNG.Transparent := True;
  105.     FImage.Assign(LPNG);
  106.   finally
  107.     LPNG.Free;
  108.   end;
  109.   FStretch := True;
  110. end;
  111.  
  112. destructor TImageFont.Destroy;
  113. var
  114.   i: Integer;
  115. begin
  116.   FFont.Free;
  117.   FFont := nil;
  118.   FImage.Free;
  119.   FImage := nil;
  120.   for i := High(FImagePool) downto Low(FImagePool) do
  121.     begin
  122.       FImagePool[i].Free;
  123.       FImagePool[i] := nil;
  124.     end;
  125.   inherited Destroy;
  126. end;
  127.  
  128. var
  129.   GFontFaceName: WideString;
  130.  
  131. function MyFontEnumerator(var ALogFont: ENUMLOGFONTEXW; var ATextMetric: NEWTEXTMETRICEXW;
  132.     AFontType: Integer; AData: LPARAM): Integer; stdcall;
  133. var
  134.   s: WideString;
  135. begin
  136.   Result := 1;
  137.   s := ALogFont.elfLogFont.lfFaceName;
  138.   {$IfDef Debug}
  139.   WriteLn('[', s, ']');
  140.   {$EndIf Debug}
  141.   if s = GFontFaceName then
  142.     begin
  143.       PInteger(AData)^ := 1;
  144.       Result := 0;
  145.     end;
  146. end;
  147.  
  148. function TImageFont.FontCheck(const AFontFaceName: WideString): Boolean;
  149. var
  150.   DC: HDC;
  151.   LFont: TLogFontW;
  152.   Found: Integer;
  153. begin
  154.   DC := GetDC(0);
  155.   try
  156.     GFontFaceName := AFontFaceName;
  157.     Found := 0;
  158.     FillChar(LFont, SizeOf(LFont), 0);
  159.     LFont.lfCharset := DEFAULT_CHARSET;
  160.     EnumFontFamiliesExW(DC, @LFont, @MyFontEnumerator, LPARAM(@Found), 0);
  161.     Result := Found <> 0;
  162.   finally
  163.     ReleaseDC(0, DC);
  164.   end;
  165. end;
  166.  
  167. function TImageFont.BuildImageList: Boolean;
  168. const
  169.   Prefix = AnsiString('Font');
  170. var
  171.   i: Integer;
  172. begin
  173.   SetLength(FImagePool, CImageCount);
  174.   for i := Low(FImagePool) to High(FImagePool) do
  175.     begin
  176.       FImagePool[i] := TPicture.Create;
  177.       FImagePool[i].LoadFromResourceName(HInstance, Prefix + IntToStr(i));
  178.     end;
  179.   Result := (Length(FImagePool) > 0);
  180. end;
  181.  
  182. procedure TImageFont.ResetTempArray;
  183. var
  184.   i: Integer;
  185. begin
  186.   SetLength(FTempArray, CImageCount);
  187.   for i := Low(FTempArray) to High(FTempArray) do
  188.     FTempArray[i] := i;
  189. end;
  190.  
  191. procedure TImageFont.SetBackground(const AValue: TColor);
  192. begin
  193.   if AValue = FBackground then
  194.     Exit;
  195. end;
  196.  
  197. procedure TImageFont.SetFont(const AValue: TFont);
  198. begin
  199.   if AValue = FFont then
  200.     Exit;
  201. end;
  202.  
  203. procedure TImageFont.SetSize(const AValue: Integer);
  204. begin
  205.   if AValue = FSize then
  206.     Exit;
  207. end;
  208.  
  209. procedure TImageFont.SetStretch(const AValue: Boolean);
  210. begin
  211.   if AValue = FStretch then
  212.     Exit;
  213. end;
  214.  
  215. function TImageFont.PickRandom: Integer;
  216. var
  217.   i: Integer;
  218. begin
  219.   if (Length(FTempArray) = 0) then
  220.     ResetTempArray;
  221.   i := Random(Length(FTempArray));
  222.   Result := FTempArray[i];
  223.   Delete(FTempArray, i, 1);
  224. end;
  225.  
  226. procedure TImageFont.ExactTextPixels(const AFont: TFont; const AText: string; const ABackground: TColor; out AImage: TBitmap);
  227. var
  228.   Bitmap: TBitmap;
  229.   PixelX, PixelY, // for the scanning
  230.   LeftX, RightX, TopY, BottomY, // store each direction to accurate output AWidth and AHeight
  231.   SizeX, SizeY: Integer; // initial bitmap size
  232.   LRect: TRect;
  233.   GotUpperCase: Boolean;
  234. begin
  235.   // Initialize the output values
  236.   LRect.Width := 0;
  237.   LRect.Height := 0;
  238.   LRect.Top := 0;
  239.   LRect.Left := 0;
  240.   LRect.Right := 0;
  241.   LRect.Bottom := 0;
  242.  
  243.   GotUpperCase := False;
  244.   for LeftX := Low(AText) to High(AText) do
  245.     if AText[LeftX] = UpperCase(AText[LeftX]) then
  246.       begin
  247.         GotUpperCase := True;
  248.         break;
  249.       end;
  250.  
  251.   // Create a bitmap and canvas
  252.   Bitmap := TBitmap.Create;
  253.   try
  254.     // Set the font for the canvas
  255.     Bitmap.Canvas.Font := AFont;
  256.  
  257.     // Calculate the needed dimension and add more space for non-normal fonts or font styles
  258.     SizeX := Bitmap.Canvas.TextWidth(AText) * 3;
  259.     SizeY := Bitmap.Canvas.TextHeight(AText) * 3;
  260.     Bitmap.SetSize(SizeX, SizeY);
  261.  
  262.     // Clear the bitmap and draw the text onto the bitmap,
  263.     // ensure that we got 2 different colors to check for one of them
  264.     if ABackground <> clNone then
  265.       begin
  266.         Bitmap.Canvas.Brush.Color := ABackground;
  267.         Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
  268.       end;
  269. //    Bitmap.Canvas.Font.Color := clBlack;
  270.     Bitmap.Canvas.TextOut(0, 0, AText);
  271.  
  272.     // Initialize scan variables in opposite manner to use Min() and Max() correct
  273.     LeftX := Bitmap.Width;
  274.     RightX := 0;
  275.     TopY := Bitmap.Height;
  276.     BottomY := 0;
  277.  
  278.     // Scan the bitmap from left to right
  279.     for PixelX := 0 to Pred(Bitmap.Width) do
  280.       for PixelY := 0 to Pred(Bitmap.Height) do
  281.         if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
  282.           LeftX := Min(LeftX, PixelX);
  283.  
  284.     // Scan the bitmap from right to left
  285.     for PixelX := Pred(Bitmap.Width) downto 0 do
  286.       for PixelY := 0 to Pred(Bitmap.Height) do
  287.         if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
  288.           RightX := Max(RightX, PixelX);
  289.  
  290.     // Scan the bitmap from top to bottom
  291.     for PixelY := 0 to Pred(Bitmap.Height) do
  292.       for PixelX := 0 to Pred(Bitmap.Width) do
  293.         if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
  294.           TopY := Min(TopY, PixelY);
  295.  
  296.     // Scan the bitmap from bottom to top
  297.     for PixelY := Pred(Bitmap.Height) downto 0 do
  298.       for PixelX := 0 to Pred(Bitmap.Width) do
  299.         if Bitmap.Canvas.Pixels[PixelX, PixelY] <> ABackground then
  300.           BottomY := Max(BottomY, PixelY);
  301.  
  302.     // Calculate the width and height based on the scan results
  303.     LRect.Top := TopY;
  304.     LRect.Left := LeftX;
  305.     LRect.Bottom := Succ(BottomY);
  306.     if GotUpperCase then
  307.       LRect.Right := Succ(RightX)
  308.     else
  309.       LRect.Right := RightX;
  310.     AImage.SetSize(LRect.Width, LRect.Height);
  311.     AImage.Canvas.CopyMode := cmSrcCopy;
  312.     AImage.Canvas.CopyRect(AImage.Canvas.ClipRect, Bitmap.Canvas, LRect);
  313.  finally
  314.    Bitmap.Free;
  315.  end;
  316. end;
  317.  
  318. procedure TImageFont.CreateRescaleBitmap(const Source: TBitmap; const Width, Height: Integer; out Rescaled: TBitmap);
  319. var
  320.   DC: HDC;
  321.   MemDC: HDC;
  322.   Bitmap: HBITMAP;
  323.   OldBitmap: HBITMAP;
  324. begin
  325.   DC := GetDC(0);
  326.   try
  327.     MemDC := CreateCompatibleDC(DC);
  328.     try
  329.       Bitmap := CreateCompatibleBitmap(DC, Width, Height);
  330.       OldBitmap := SelectObject(MemDC, Bitmap);
  331.  
  332.       SetStretchBltMode(MemDC, HALFTONE);
  333.       SetBrushOrgEx(MemDC, 0, 0, nil);
  334.  
  335.       StretchBlt(MemDC, 0, 0, Width, Height, Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, SRCCOPY);
  336.  
  337.       Rescaled := TBitmap.Create;
  338.       Rescaled.Assign(Source);
  339.       Rescaled.Width := Width;
  340.       Rescaled.Height := Height;
  341.       BitBlt(Rescaled.Canvas.Handle, 0, 0, Width, Height, MemDC, 0, 0, SRCCOPY);
  342.  
  343.       SelectObject(MemDC, OldBitmap);
  344.       DeleteObject(Bitmap);
  345.     finally
  346.       DeleteDC(MemDC);
  347.     end;
  348.   finally
  349.     ReleaseDC(0, DC);
  350.   end;
  351. end;
  352.  
  353. procedure TImageFont.AntiAliasedStretchDrawBitmap(SourceBitmap, DestBitmap: TCustomBitmap);
  354. var
  355.   DestIntfImage, SourceIntfImage: TLazIntfImage;
  356.   DestWidth, DestHeight: Integer;
  357.   DestCanvas: TLazCanvas;
  358. begin
  359.   DestWidth := DestBitmap.Width;
  360.   DestHeight := DestBitmap.Height;
  361.   DestIntfImage := TLazIntfImage.Create(0, 0);
  362.   try
  363.     DestIntfImage.LoadFromBitmap(DestBitmap.Handle, DestBitmap.MaskHandle);
  364.     DestCanvas := TLazCanvas.Create(DestIntfImage);
  365.     try
  366.       SourceIntfImage := SourceBitmap.CreateIntfImage;
  367.       try
  368.         DestCanvas.Interpolation := TFPBaseInterpolation.Create;
  369.         try
  370.           DestCanvas.StretchDraw(0, 0, DestWidth, DestHeight, SourceIntfImage);
  371.           DestBitmap.LoadFromIntfImage(DestIntfImage);
  372.         finally
  373.           DestCanvas.Interpolation.Free;
  374.         end;
  375.       finally
  376.         SourceIntfImage.Free;
  377.       end;
  378.     finally
  379.       DestCanvas.Free;
  380.     end;
  381.   finally
  382.     DestIntfImage.Free;
  383.   end;
  384. end;
  385.  
  386.  
  387. procedure TImageFont.SetText(const AValue: WideString);
  388. var
  389.   LPNG: TPortableNetworkGraphic;
  390.   LBMP: TBitmap;
  391.   LBMP2: TBitmap;
  392.   i: Integer;
  393. begin
  394.   if AValue = '' then
  395.     Exit;
  396.   FImage.Free;
  397.   FImage := TPicture.Create;
  398.   FBackground := $FEFEFE;
  399.   LPNG := TPortableNetworkGraphic.Create;
  400.   try
  401.     LPNG.Canvas.Font := FFont;
  402.     LBMP := TBitmap.Create;
  403.     try
  404.       LBMP.Canvas.Font := FFont;
  405.       for i := Low(AValue) to High(AValue) do
  406.         begin
  407.           ExactTextPixels(FFont, string(AValue[i]), FBackground, LBMP);
  408.           LBMP2 := TBitmap.Create;
  409.           try
  410.             LBMP2.Width := CCanvasWidth;
  411.             LBMP2.Height := CCanvasHeight;
  412.             AntiAliasedStretchDrawBitmap(LBMP, LBMP2);
  413.             LPNG.Width := CImageWidth;
  414.             LPNG.Height := CImageHeight;
  415.             LPNG.TransparentMode := tmFixed;
  416.             LPNG.TransparentColor := clBlack;
  417.             LPNG.Transparent := True;
  418.             LPNG.Canvas.Brush.Color := clDefault;
  419.             LPNG.Canvas.Brush.Style := bsSolid;
  420.             LPNG.Canvas.FillRect(LPNG.Canvas.ClipRect);
  421.             LPNG.Canvas.Draw(0, 0, FImagePool[PickRandom].Graphic);
  422.             LPNG.Canvas.CopyMode := cmSrcCopy;
  423.             LPNG.Canvas.CopyRect(Rect(CCanvasLeft, CCanvasTop, CCanvasWidth, CCanvasHeight),
  424.                                  LBMP2.Canvas,
  425.                                  LBMP2.Canvas.ClipRect);
  426.           finally
  427.             LBMP2.Free;
  428.           end;
  429.           FImage.Assign(LPNG);
  430.         end;
  431.     finally
  432.       LBMP.Free;
  433.     end;
  434.   finally
  435.     LPNG.Free;
  436.   end;
  437. end;
  438.  
  439. end.
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

paweld

  • Hero Member
  • *****
  • Posts: 1058
Re: splitting an image
« Reply #27 on: May 05, 2024, 03:12:27 pm »
@madref : The only solution I can think of is to embed the font in the resource - but this is only possible on MS Windows.
The best solution is to install the font in the OS.
Best regards / Pozdrawiam
paweld

madref

  • Hero Member
  • *****
  • Posts: 1014
  • ..... A day not Laughed is a day wasted !!
    • Nursing With Humour
Re: splitting an image
« Reply #28 on: May 05, 2024, 03:37:37 pm »
but I have installed fonts and the don't show up on your combobox
You treat a disease, you win, you lose.
You treat a person and I guarantee you, you win, no matter the outcome.

Lazarus 3.99 (rev main_3_99-2099-gef1838e6d2) FPC 3.3.1 x86_64-darwin-cocoa
Mac OS X Sonoma 14.5

paweld

  • Hero Member
  • *****
  • Posts: 1058
Re: splitting an image
« Reply #29 on: May 05, 2024, 04:14:36 pm »
I checked and in Windows all installed fonts are downloaded. Just an important note: if you install a font while the program is running then you have to close and restart the program because the font list is loaded in FormCreate event.
Edit: And in Lazarus this font is available / visible in the font list?
« Last Edit: May 05, 2024, 06:05:46 pm by paweld »
Best regards / Pozdrawiam
paweld

 

TinyPortal © 2005-2018