Related
I draw a dotted line on a layer of an ImgView32. Later, I want to save each layer as transparent PNGs.
For any other layer that I have, the saving works just fine. But for the drawing layer, it does not.
In order to make the question simpler to understand, take the example code from the gr32 library, more specifically the Layers example. One of the options in its main menu is to add a custom drawing layer (New Custom Layer -> Simple Drawing Layer).
Then try to save that layer as a transparent PNG image and you will end up with a corrupted PNG file (you can't open it with any other picture viewer like for example Paint.net or Microsoft Photo Viewer). Same thing happens if you try to save the layer's bitmap32 as a bitmap as you can see in the bellow code...
I tried two approaches for saving Bitmap32 as a transparent PNG, so the first one is as follows:
procedure TMainForm.SavePNGTransparentX(bm32:TBitmap32; dest:string);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
try
Png.Assign(bm32);
Png.SaveToFile(dest);
finally
Png.Free;
end;
end;
So the above method works if I have a PNG loaded into the layer like this:
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromStream(myStream);
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
...
But as soon as I try to save the layer created with the code from the Layers example, the result is corrupted.
Even if I try to save the layer as bitmap like this (though this is not my intention since I need them to be PNG):
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
the same corruption occurs.
So, it's not like I receive an exception or anything... it just gets saved corrupted somehow;
I also tried other ways to save the Bitmap32 as transparent PNG, like for instance the GR32_PNG approach:
function SaveBitmap32ToPNG (sourceBitmap: TBitmap32;transparent: Boolean;bgColor32: TColor32;filename: String;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): boolean;
var png: TPNGImage;
begin
result := false;
try
png := Bitmap32ToPNG (sourceBitmap,false,transparent,WinColor(bgColor32),compressionLevel,interlaceMethod);
try
png.SaveToFile (filename);
result := true;
finally
png.Free;
end;
except
result := false;
end;
end;
where
function Bitmap32ToPNG (sourceBitmap: TBitmap32;paletted, transparent: Boolean;bgColor: TColor;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): TPNGImage; // TPNGObject
var
bm: TBitmap;
png: TPNGImage;//TPngObject;
TRNS: TCHUNKtRNS;
p: pngImage.PByteArray;
x, y: Integer;
begin
Result := nil;
png := TPngImage.Create; // TPNGObject
try
bm := TBitmap.Create;
try
bm.Assign (sourceBitmap); // convert data into bitmap
// force paletted on TBitmap, transparent for the web must be 8bit
if paletted then
bm.PixelFormat := pf8bit;
png.interlaceMethod := interlaceMethod;
png.compressionLevel := compressionLevel;
png.Assign(bm); // convert bitmap into PNG
// this is where the access violation occurs
finally
FreeAndNil(bm);
end;
if transparent then begin
if png.Header.ColorType in [COLOR_PALETTE] then begin
if (png.Chunks.ItemFromClass(TChunktRNS) = nil) then png.CreateAlpha;
TRNS := png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
if Assigned(TRNS) then TRNS.TransparentColor := bgColor;
end;
if png.Header.ColorType in [COLOR_RGB, COLOR_GRAYSCALE] then png.CreateAlpha;
if png.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA] then
begin
for y := 0 to png.Header.Height - 1 do begin
p := png.AlphaScanline[y];
for x := 0 to png.Header.Width - 1
do p[x] := AlphaComponent(sourceBitmap.Pixel[x,y]); // TARGB(bm.Pixel[x,y]).a;
end;
end;
end;
Result := png;
except
png.Free;
end;
end;
but using this approach, I get an EAccessViolation when trying to save this particular layer. For any other layers (not drawing ones), it does not crash my project except for this custom drawing one.
The access violation occurs at this line:
png.Assign(bm);
inside the Bitmap32ToPNG function
Do you have any idea why that happens and how can I prevent this?
EDIT
I tried using TBitmapLayer instead, because the TPositionedLayer might lack the Bitmap32 for some reason.
So my code is like this:
// adding a BitmapLayer and setting it's onPaint event to my handler
procedure TMainForm.Mynewlayer1Click(Sender: TObject);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,200);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnPaint := PaintMy3Handler;
except
Free;
raise;
end;
Selection := B;
end;
// and the PaintHandler is as follows:
procedure TMainForm.PaintMy3Handler(Sender: TObject;Buffer: TBitmap32);
var
Cx, Cy: Single;
W2, H2: Single;
const
CScale = 1 / 200;
begin
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
// Five black pixels, five white pixels since width of the line is 5px
Buffer.SetStipple([clBlack32, clBlack32, clBlack32, clBlack32, clBlack32,
clWhite32, clWhite32, clWhite32, clWhite32, clWhite32]);
W2 := (Right - Left) * 0.5;
H2 := (Bottom - Top) * 0.5;
Cx := Left + W2;
Cy := Top + H2;
W2 := W2 * CScale;
H2 := H2 * CScale;
Buffer.PenColor := clRed32;
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-2,Top);
Buffer.LineToFSP(Cx-2 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-1,Top);
Buffer.LineToFSP(Cx-1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx,Top);
Buffer.LineToFSP(Cx , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+1,Top);
Buffer.LineToFSP(Cx+1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+2,Top);
Buffer.LineToFSP(Cx+2 , Bottom);
end;
end;
Keep in mind that I use the default layers demo application. So this is just added code. I did not remove nor change anything in the demo code.
So I create a new layer (TBitmapLayer) and onPaint I do my drawing. In the end I want to save the contents of that layer as PNG. But it seems like the onPaint might draw somewhere else instead of the actual layer. Otherwise I do not understand why the saved image is empty.
So this time the resulted PNG is not corrupted, but it is empty...
The error is in the fact that the examples create TPositionedLayer layers which do not hold a bitmap. You can not type cast this layer type into a TBitmapLayer and expect it to create a bitmap image of the layer, as you do in this code:
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
I assume you do something similar to save to .png file, although you did not show that code.
The examples (with TPositionedLayer layers) use ImgView.Buffer for drawing on the screen. You can save that to a .png file like this:
SavePNGTransparentX(ImgView.Buffer, 'c:\tmp\imgs\buffer.png');
but I don't expect that to work satisfactorily for your separate layer images.
What is the reason you don't use TBitmapLayers as you have done before?
Edit after comments by user1137313
Inspired by the solution you found yourself (ref. your comment) I suggest the following which paints the layer to the extra bitmap only when needed for saving.
Starting from a menu item
procedure TMainForm.mnFileSaveClick(Sender: TObject);
begin
SaveLayerToPng(ImgView.Layers[ImgView.Layers.Count-1], 'c:\tmp\imgs\buffer.png');
end;
You possibly want to call SaveLayerToPng() in a loop if you save several layers at the same time, and also change the file name(s) as needed.
Then the SaveLayerToPng() procedure
procedure TMainForm.SaveLayerToPng(L: TCustomLayer; FileName: string);
var
bm32: TBitmap32;
begin
bm32:= TBitmap32.Create;
try
bm32.SetSizeFrom(ImgView.Buffer);
PaintSimpleDrawingHandler(L, bm32);
SavePNGTransparentX(bm32, FileName);
finally
bm32.Free;
end;
end;
It calls the existing PaintSimpleDrawingHandler(Sender: TObject; buffer: TBitmap32) procedure to paint to bm32 which it then passes on to `SavePNGTransparentX() for actual saving.
I used the paint handler of the Graphics32 example, but your PaintMy3Handler() can be used just as well.
The end result is same as your solution, just that the extra TBitmap32 is only painted when the file is to be saved.
Gretings to all!
How to print pictures in Delphi on TPrinter, in real sizes of pictures?
From canvas of TImage I have good results, but if I paints on TPrinter canvas, I have BAD result, puctures is too small than real size of bitmap.
Why that happens What I'm need to do for fix bug?
UPDATE
Yes, I seen question from the hint in the 1st post.
I can't use JCL/JVCL code in my project, but I got idea from it.
I create temporary TImage, and calculate dimensions of it in accordance with the factor of printer's DPI:
var
i, iRow, iCol, // Counter
iBorderSize, // Ident from left/top borders
iImgDistance, // Ident between images in grid
iRows, // Rows Count
iColumns, // Colun count
iLeft, iTop: Integer; // For calc
bmp: TBitmap;
bStop, bRowDone, bColDone: Boolean;
Img1: TImage;
scale: Double;
function CalcY: Integer;
begin
if (iRow = 1) then
Result := iBorderSize
else
Result := iBorderSize + (iImgDistance * (iRow - 1)) +
(bmp.Height * (iRow - 1));
end;
function CalcX: Integer;
begin
if (iCol = 1) then
Result := iBorderSize
else
Result := iBorderSize + (iImgDistance * (iCol - 1)) +
(bmp.Width * (iCol - 1));
end;
begin
iBorderSize := StrToInt(BorderSizeEdit.Text);
iImgDistance := StrToInt(ImgsDistanceEdit.Text);
iRows := StrToInt(RowsCountEdit.Text);
iColumns := StrToInt(ColCountEdit.Text);
iRow := 1;
iCol := 1;
iLeft := iBorderSize;
iTop := iBorderSize;
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) /
Screen.PixelsPerInch;
bmp := TBitmap.Create;
Img1 := TImage.Create(nil);
Img1.Height := Trunc(Printer.PageHeight / scale); //Calc canvas size
Img1.Width := Trunc(Printer.PageWidth / scale); //Calc canvas size
Img1.Canvas.Brush.Color := clWhite;
Img1.Canvas.FillRect(Rect(0, 0, Img1.Width, Img1.Height));
try
bmp.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Source.bmp');
for i := 1 to 18 do
begin
if (iRow <= iRows) then
begin
iTop := CalcY;
iLeft := CalcX;
Img1.Canvas.Draw(iLeft, iTop, bmp);
if not((iRow = iRows) and (iCol = iColumns)) then
begin
if (iCol = iColumns) then
begin
Inc(iRow);
iCol := 1;
end
else
Inc(iCol);
end
else
begin
PrintImage(Img1, 100);
iRow := 1;
iCol := 1;
Img1.Canvas.Brush.Color := clWhite;
Img1.Canvas.FillRect(Rect(0, 0, Img1.Width, Img1.Height));
end;
end;
end;
finally
FreeAndNil(bmp);
FreeAndNil(Img1);
end;
end;
And draw it on TPrinter.Canvas.
You can see results below:
Results is good, but not perfect.
As you can see, in the last column, all images are drawn not to the end, some part misses off the paper and not drawn.
I think it's happens because I use the Trunc to get integer part of double when I'm calculate dimensions of TImage.Canvas in accordance with the factor of printer's DPI.
By experiments I know value 0.20. 0.20 is a part of last column images, in pixels, that not drawn. If I change code, that gets scale factor by this:
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
Screen.PixelsPerInch - 0.20
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) /
Screen.PixelsPerInch - 0.20;
I have that, what I need:
I think the value 0.20 isn't a constant and it will change on every PC.
How to calculate this value? What need to solve this problem?
The basic problem here is one of scaling. More or less, figure out how much to expand the resolution of the image and then stretchdraw it to the printer canvas. Something like this gets the image stretched out to the dimension of the printer canvas.
procedure TForm1.Button2Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
begin
if PrintDialog1.Execute then
begin
Printer.BeginDoc;
scale := Printer.PageWidth / Bitmap1.Width;
ShowMessage(FloatToStr(scale));
{ horizontal pixels, vertical pixels, bit depth 600 x 600 x 24}
MyRect.Left := 0;
MyRect.Top := 0;
MyRect.Right := trunc(Bitmap1.Width * scale);
MyRect.Bottom := trunc(Bitmap1.Height * scale);
Printer.Canvas.StretchDraw(MyRect, Bitmap1);
Printer.EndDoc;
end;
Of course, you have to check "Right" and "Bottom" to make sure they don't exceed your PageWidth and PageHeight depending on the type of scaling you use (6.25 or 600/96 seems fine for simply making an image the same relative size as the screen, assuming those numbers match your printer and screen), assuming you want to keep the image to one page and not mosaic pieces of it onto multiple pages.
I don't know if this works entirely since I don't have a varied number of devices (i.e. different DPIs) to test both orientations on, but this seems to be what you want to get both DPI numbers dynamically.
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / pixelsperinch;
Then of course, you multiply like above.
The issue you're running into is that there really isn't a "real size" of an image, it's all relative. The printer often has a lot higher resolution then your monitor and that's why pictures look small.
Your monitor has often a resolution of 96 dpi and normal printer has a resolution of 600 dpi which means your image prints in its real size it just looks small because a printer can put a lot more dots in the same space then a monitor can.
Delphi Basics link was also helpful : http://www.delphibasics.co.uk/RTL.asp?Name=printer&ExpandCode1=Yes
on form : drag n drop TPrintDialog from your Tool Palette
and manually add this to the uses clause under [Implementation]
uses printers; // Unit containing the printer command
With that and this post I was able to print directly to any printer at the size I wanted for images or text. There is no need to call the bitmap or assign the TPrinter once you have added the unit above. Just draw directly to the canvas in your PC printer queue.
procedure TForm1.cmdPrintCircleClick(Sender: TObject);
var
xx, yy, mySize : integer;
//printer1 : TPrinter;
begin
// create image directly on Printer Canvas and print it
//Ellipse( X-(Width div 2), Y-(Height div 2), X+(Width div 2), Y+(Height div 2));
if PrintDialog1.Execute then
try
with Printer do
begin
if Printer.Orientation = poPortrait then
begin
// represents 1/2 US-inch relative to Portrait page size 8.5 x 11
mySize := Trunc(PageWidth / 8.5 / 2);
end
else
begin
// represents 1/2 US-inch relative to Landscape page size 11 x 8.5
mySize := Trunc(PageHeight / 8.5 / 2);
end;
xx := Trunc(PageWidth / 2);
yy := Trunc(PageHeight / 2);
// Start printing
BeginDoc;
// Write out the ellipse // create one-inch black circle
Canvas.Brush.Color := clBlack;
Canvas.Ellipse(xx - mySize, yy - mySize, xx + mySize, yy + mySize);
// Finish printing
EndDoc;
end;
finally
end;
end;
I use Toolbar2000 component. It shows button's hint below correct position with system scale > 100%. So, I need to set HintPos manually. I have Mouse.CursorPos. But hint should be displayed below mouse cursor image.
How to get mouse cursor dimensions?
You should ask Windows for System Metrics - see http://msdn.microsoft.com/en-us/library/windows/desktop/ms724385.aspx
However if user installed something like Stardock CursorFX those values would not match what the user really sees and what behavior he expects from programs.
That seems to be one of Win32 API limitations, that the value cannot be changed apart of few relatively small standard values from old approved set.
You can create an Icon, use GetCursor to set the handle, additional information can be retrieved with GetIconInfo. This will even work if userdefined cursors are shown, which might have nearly any size.
var
ico: TIcon;
IcoInfo: TIconInfo;
begin
ico := TIcon.Create;
try
ico.Handle := GetCursor;
try
GetIconInfo(ico.Handle, IcoInfo);
Caption := Format('Width %d, Height %d HotSpotX %d, HotSpotY %d',
[ico.Width, ico.Height, IcoInfo.xHotspot, IcoInfo.yHotspot]);
finally
ico.ReleaseHandle;
end;
finally
ico.Free;
end;
end;
// Just as example for an very unusual cursor
procedure TForm1.Button1Click(Sender: TObject);
var
IconInfo: TIconInfo;
AndMask, Bmp: TBitmap;
w, h: Integer;
begin
w := Screen.Width * 2;
h := Screen.Height * 2;
// Creation And Mask
AndMask := TBitmap.Create;
AndMask.Monochrome := True;
AndMask.Height := h;
AndMask.Width := w;
// Draw on And Mask
AndMask.Canvas.Brush.Color := clWhite;
AndMask.Canvas.FillRect(AndMask.Canvas.ClipRect);
AndMask.Canvas.Pen.Color := clwhite;
AndMask.Canvas.Pen.Width := 5;
AndMask.Canvas.MoveTo(w div 2, 0);
AndMask.Canvas.LineTo(w div 2, h);
AndMask.Canvas.MoveTo(0, h div 2);
AndMask.Canvas.LineTo(w, h div 2);
{Create the "XOr" mask}
Bmp := TBitmap.Create;
Bmp.Width := w;
Bmp.Height := h;
{Draw on the "XOr" mask}
Bmp.Canvas.Brush.Color := clblack;
Bmp.Canvas.FillRect(Rect(0, 0, w, h));
Bmp.Canvas.Pen.Color := clwhite;
Bmp.Canvas.Pen.Width := 5;
Bmp.Canvas.MoveTo(w div 2, 0);
Bmp.Canvas.LineTo(w div 2, h);
Bmp.Canvas.MoveTo(0, h div 2);
Bmp.Canvas.LineTo(w, h div 2);
IconInfo.fIcon := true;
IconInfo.xHotspot := w div 2;
IconInfo.yHotspot := h div 2;
IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := Bmp.Handle;
Screen.Cursors[1]:= CreateIconIndirect(IconInfo);
Screen.Cursor:=1;
end;
This is Windows 7 issue and there is no proper solution. GetSystemMetrics(SM_CYCURSOR) returns size of cursor image with background. And it seems this value is much more incorrect with system scale >100%. Delphi XE2 shows a hint on incorrect position too. But it's interesting to note that Explorer shows a hint on the correct position.
I am building an application that has "virtual windows". The output is TImage object.
1) The application loads window skin files into TPNGObject's:
2) Then application has to create a new blank TPNGObject, and resize the skin files to needed sizes and draw them on that blank image. Should look something like this:
3) And the final output on TImage:
The problem is that I do know how to create a completely blank off screen image. Of course I could simply render the skin files on to TImage each time, but it's easier and better to resize skin files and create the window once, instead.
I'm using the PNG Library by Gustavo Daud, version 1.564 (31st July, 2006).
The below uses CreatePNG procedure of 'pngfunctions.pas' of Martijn Sally, from an extension library (pngcomponents) to pngimage.
var
Bmp, Mask: TBitmap;
PNG: TPNGObject;
begin
Bmp := TBitmap.Create;
Bmp.PixelFormat := pf24bit;
Bmp.SetSize(64, 64);
Bmp.Canvas.Brush.Color := clBtnFace;
Bmp.Canvas.Font.Color := clRed;
Bmp.Canvas.Font.Size := 24;
Bmp.Canvas.TextOut(4, 10, 'text');
Mask := TBitmap.Create;
Mask.PixelFormat := pf24bit;
Mask.Canvas.Brush.Color := clBlack;
Mask.SetSize(64, 64);
Mask.Canvas.Font.Color := clWhite;
Mask.Canvas.Font.Size := 24;
Mask.Canvas.TextOut(4, 10, 'text');
PNG := TPNGObject.Create;
CreatePNG(Bmp, Mask, PNG, False);
PNG.Draw(Canvas, Rect(10, 10, 74, 74));
// finally, free etc...
Here's the output (black, white squares are TShapes):
My other answer is another alternative which I suggest. However your question still poses an issue: The PNG library must either have a bug which is preventing any canvas drawing from being visible (after using CreateBlank constructor with COLOR_RGBALPHA as color type) or we're all missing something.
It looks like the only workaround that I can see is (as you mention in your edit) use a Bitmap to do your drawing instead. Use the transparent properties of this bitmap (Transparent: Bool and TransparentColor: TColor) to set up the transparent area of your image, then when you need a transparent PNG, just copy that bitmap over to the new PNG object...
BMP.Width:= 100;
BMP.Height:= 100;
BMP.Transparent:= True;
BMP.TransparentColor:= clWhite;
BMP.Canvas.Brush.Style:= bsSolid;
BMP.Canvas.Brush.Color:= clWhite;
BMP.Canvas.FillRect(BMP.Canvas.ClipRect);
BMP.Canvas.Brush.Color:= clBlue;
BMP.Canvas.Ellipse(10, 10, 90, 90);
PNG.Assign(BMP);
And the white area of the image should be transparent. There are other ways of accomplishing the transparent area, but that's another subject.
Image:
Is this what you're trying to do?
I apologize to people that I messed their heads up.
It turns out CreateBlank works as wanted. The problem was that I was drawing PNG on PNG canvas (PNG.Canvas.Draw). Canvas doesn't really support transparency. To draw a translucent PNG on another PNG you will need a procedure/function that merges those both layers together. With some googling I ended up with this procedure:
procedure MergePNGLayer(Layer1, Layer2: TPNGObject; Const aLeft, aTop: Integer);
var
x, y: Integer;
SL1, SL2, SLBlended: pRGBLine;
aSL1, aSL2, aSLBlended: PByteArray;
blendCoeff: single;
blendedPNG, Lay2buff: TPNGObject;
begin
blendedPNG := TPNGObject.Create;
blendedPNG.Assign(Layer1);
Lay2buff:=TPNGObject.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;
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;
Usage:
var
PNG1, PNG2: TPNGObject;
begin
PNG1 := TPNGObject.CreateBlank(COLOR_RGBALPHA, 16, 500, 500);
PNG2 := TPNGObject.Create;
PNG2.LoadFromFile('...*.png');
MergePNGLayer(PNG1, PNG2, 0, 0);
// PNG1 is the output
And again, I am really sorry to users that wanted to help, but couldn't due to not understanding me.
I don't have answer to this question but I figured out how to get same result with any PNG editor. I have created blank 1000x1000 PNG image and saved it in my application directory. Then I open this image in my program and resize image to needed sizes (smaller of course) and that's the trick.
How do I tile an image in a TImage in Delphi?
Why I need it: Instead of creating more TImages at runtime, I could create one and store my image there knowing that it will be 'fit' until it reaches TImage's height and width.
Please suggest any ideas to do this.
Thank you!
EDIT: Please note, I'm not asking for streching the image, but filling the canvas by repeating the image.
Assuming your image is a bitmap and loaded into the TImage you can use the following
procedure TmyForm.Button1Click(Sender: TObject);
var mybmp:TBitmap;
begin
mybmp:= TBitmap.Create();
try
mybmp.Assign(Image1.Picture.Bitmap);
Image1.Picture.Bitmap.SetSize(Image1.Width,Image1.Height);
Image1.Canvas.Brush.Bitmap := mybmp;
Image1.Canvas.FillRect(Image1.BoundsRect);
mybmp.FreeImage;
finally
FreeandNil(mybmp)
end;
end;
Some notes:
If you save the image after titling it you will save the titled version not the original.
Image1.Canvas and Image1.Picture.Bitmap.Canvas are one and the same, that's why you need to resize the bitmap before painting on the canvas.
If you try and assign the bitmap in the TImage to the brush without assigning it to another bitmap object first like so Image1.Canvas.Brush.Bitmap := Image1.Picture.Bitmap you get an exception "not enough storage".
The following is the function that I have used, taking an existing TImage component and tiling it over a target canvas:
procedure TileImage(const Source:tImage;
Target: TCanvas;
TargetHeight,TargetWidth:integer);
// Tiles the source image over the given target canvas
var
X, Y: Integer;
dX, dY: Integer;
begin
dX := Source.Width;
dY := Source.Height;
Y := 0;
while Y < TargetHeight do
begin
X := 0;
while X < TargetWidth do
begin
Target.Draw(X, Y, Source.Picture.graphic);
Inc(X, dX);
end;
Inc(Y, dY);
end;
end;
Because a tLabel exposes a canvas, you can do tricks like the following:
TileImage(Image1,Label1.Canvas,Label1.Height,Label1.Width);
You could set the canvas.brush.bitmap := to the image of the tile. then canvas.fillrect(canvas.cliprect) to tile the whole canvas with the selected tile image. I haven't done it in a long time and I am not able to check if this is really how it's done in Delphi right now, but I am pretty sure this is what you're after.
Delphi installation comes with a Demo named 'Bitmap' (you can find the project in Help dir.).
It uses the following method to draw a tiled image:
procedure TBmpForm.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
// Bitmap is a TBitmap.
// form's OnCreate looks like this:
// Bitmap := TBitmap.Create;
// Bitmap.LoadFromFile('bor6.bmp');
// or you can use Canvas.Draw(x, y, Image1.Picture.Bitmap),
// instead of Canvas.Draw(x, y, Bitmap);
//
Canvas.Draw(x, y, Bitmap); //Bitmap is a TBitmap.
x := x + Bitmap.Width; // Image1.Picture.Bitmap.Width;
end;
y := y + Bitmap.Height; // Image1.Picture.Bitmap.Height;
end;
end;
Hope that helps!
By "fitting" do you mean "tiling"?
As far as I know, TImage does not support this out of the box. You'd have to manually draw your picture on the TImage's Canvas in a repeating pattern.