Can anyone help me in finding a component or SDK that rotates PNG images quickly whilst retaining transparency?
The original author of the PNGImage component (the basis of the Delphi native component) had a forum where he, and others, posted code snippets on how to do things using the PNGImage component.
Before the forum was taken down I grabbed a copy of all of the code snippets and placed them on the CodeGear Code Central website.
Most if not all of these work with native PNG images and do maintain the Alpha channel.
Here is the complete list of examples included in the package:
Smooth rotates a PNG object
Resizes a TPNGObject using a smooth algorithm
Slice one PNG into several smaller ones
Saves an image as either a bitmap or a png.
Sample chunk descendant
Read all tEXt-Chunks and write values into a TStrings object
Display a message box with information extracted from the PNG File
Finds and cuts a block from a PNG image
This method converts the png into a jpeg object
This method converts the png into a bmp object
Overlay one PNG over another
This makes the image half transparent
Flips a png image vertically and saves back
Draws a png image over the desktop
Here is the link: CodeCentral PNG Methods
EDIT
Here is a highly optimized version of a RotatePNG function.
It still, technically, goes pixel by pixel but it uses a number of techniques, such as scanlines, pointer math and storage of image dimensions to achieve a decent speed increase.
I used a 2550x3300 pixel image (~5MB) for testing and by using semi-rough, but totally (non)scientific calculations (counting in my head) I came up with the following metrics:
the old routine (mentioned above):~7 seconds
the new routine (code below):~1.5 seconds
I can't strictly take credit for this. The code originally came from from EFG's website and I decided to try my hand at converting one of those routines to rotate PNG images instead of bitmaps.
I'm sure anyone who knows more about this type of thing will take a look at the code and offer up some suggestions to tweak more speed out of it.
procedure RotatePNG(
const PNGOriginal:TPNGImage;//input PNG
out PNGRotated:TPNGImage; //output PNG
Const Angle : double);
{
(c) har*GIS L.L.C., 1999
You are free to use this in any way, but please retain this comment block.
Please email questions to jim#har-gis.com .
Doc & Updates: http://www.efg2.com/Lab/ImageProcessing/RotateScanline.htm
and http://www.efg2.com/Lab/Library/Delphi/Graphics/JimHargis_RotateBitMap.zip
}
{
Modified by R.J.Mills, 2012 -
- Use pointer arithmetic instead of type sub-scripting for faster pixels.
- Converted to rotate PNG images June 2012.
}
Type
TRGBTripleArray = array [0..32767] of TRGBTriple; //allow integer subscript
pRGBTripleArray = ^TRGBTripleArray;
VAR
wPng : TPngImage;
theta:Double; // rotn angle in radians counterclockwise in windows
cosTheta : Single; {in windows}
sinTheta : Single;
i : INTEGER;
iOriginal : INTEGER;
iPrime : INTEGER;
j : INTEGER;
jOriginal : INTEGER;
jPrime : INTEGER;
NewWidth,NewHeight:INTEGER;
nBytes: Integer;//no. bytes per pixelformat
Oht,Owi,Rht,Rwi: Integer;//Original and Rotated subscripts to bottom/right
RowSizeRot : integer;
RowSizeOrg : integer;
AlphaSizeRot : integer;
AlphaSizeOrg : integer;
RowStartPtr : Pointer;
AlphaStartPtr : Pointer;
RowRotatedT: pRGBtripleArray; //3 bytes
AlphaRowT: pByteArray; //1 byte
AlphaRotatedT : pByteArray; //1 byte
TransparentT: TRGBTriple;
{=======================================}
function Mod360( const angle:Double ):Double;
begin
result := frac( angle/360 )*360;
if result < 0 then
result := result+360;
end;
{=======================================}
begin
Theta := -(2*pi* Mod360(angle))/360;
sinTheta := SIN( theta );
cosTheta := COS( theta );
NewWidth := ABS( ROUND( PNGOriginal.Height*sinTheta) ) + ABS( ROUND( PNGOriginal.Width*cosTheta ) );
NewHeight := ABS( ROUND( PNGOriginal.Width*sinTheta ) ) + ABS( ROUND( PNGOriginal.Height*cosTheta) );
if ( ABS(theta)*MAX( PNGOriginal.width,PNGOriginal.height ) ) > 1 then
begin//non-zero rotation
wPng := TPngImage.createblank(PNGOriginal.Header.ColorType, 8, NewWidth, NewHeight);
try
//local constants for loop, each was hit at least width*height times 1/8/00
Rwi := NewWidth - 1; //right column index
Rht := NewHeight - 1;//bottom row index
Owi := PNGOriginal.Width - 1; //transp color column index
Oht := PNGOriginal.Height - 1; //transp color row index
RowRotatedT := wPng.Scanline[ Rht ] ;
RowStartPtr := PNGOriginal.Scanline[ 0 ];
RowSizeRot := Integer(wPng.ScanLine[1])-Integer(wPng.ScanLine[0]);
RowSizeOrg := Integer(PNGOriginal.ScanLine[1])-Integer(PNGOriginal.ScanLine[0]);
TransparentT := pRGBtripleArray( PNGOriginal.Scanline[ Oht ] )[0];
if PNGOriginal.Header.ColorType in [COLOR_RGBALPHA] then
begin
AlphaRowT := PNGOriginal.AlphaScanline[ Oht ];
AlphaStartPtr := PNGOriginal.AlphaScanline[ 0 ];
AlphaRotatedT := wPng.AlphaScanline[ Rht ];
AlphaSizeRot := Integer(wPng.AlphaScanline[1])-Integer(wPng.AlphaScanline[0]);
AlphaSizeOrg := Integer(PNGOriginal.AlphaScanline[1])-Integer(PNGOriginal.AlphaScanline[0]);
end
else
begin
AlphaRowT := nil;
AlphaStartPtr := nil;
AlphaRotatedT := nil;
AlphaSizeRot := 0;
AlphaSizeOrg := 0;
end;
for j := Rht downto 0 DO //1/8/00
begin //for j
jPrime := 2*j - NewHeight + 1 ;
for i := Rwi downto 0 DO //1/8/00
begin //for i
iPrime := 2*i - NewWidth + 1;
iOriginal := ( ROUND( iPrime*CosTheta - jPrime*sinTheta ) + Owi ) div 2;
if ( iOriginal >= 0 ) and ( iOriginal <= Owi ) then
begin //inside
jOriginal := ( ROUND( iPrime*sinTheta + jPrime*cosTheta ) + Oht ) div 2 ;
if ( jOriginal >= 0 ) and ( jOriginal <= Oht ) then
begin //1/8/00
RowRotatedT[i] := pRGBTripleArray(Integer(RowStartPtr) + (jOriginal * RowSizeOrg))[iOriginal];
if assigned(AlphaRotatedT) then
AlphaRotatedT[i] := pByteArray(Integer(AlphaStartPtr) + (jOriginal * AlphaSizeOrg))[iOriginal];
end
else
begin //set Transparent
if Assigned(AlphaRotatedT) then
AlphaRotatedT[i] := 0;
RowRotatedT[i] := TransparentT;
end;
end //inside
else
begin //Set Transpaarent;
if Assigned(AlphaRotatedT) then
AlphaRotatedT[i] := 0;
RowRotatedT[i] := TransparentT;
end;
end; //for i
Dec(Integer(RowRotatedT), RowSizeRot) ;
if assigned(AlphaRotatedT) then
Dec(Integer(AlphaRotatedT), AlphaSizeRot) ;
end;//for j
PNGRotated.Assign(wPng);
finally
wPng.Free;
end;
end //non-zero rotation
else
begin //Zero rotation
if PNGRotated <> PNGOriginal then
PNGRotated.Assign(PNGOriginal);
end;
end; {RotatePNG}
Related
I am using the free JansDraw Components and when the executable runs, it throws AV error. I could locate the error to specifically the loop block of the code (not the initial block of assignment statements).
procedure TjanDrawImage.colorcircle(var bm:TBitmap;center:tpoint;radius,mode:integer);
var p,p0,p1:pbytearray;
dx,x,y,w,h,i,j,sum,c:integer;
cm,tm:tbitmap;
Rs,Rd:trect;
begin
x:=center.x;
y:=center.y;
w:=bm.width;
h:=bm.height;
cm:=tbitmap.create;
cm.width:=2*radius;
cm.height:=2*radius;
cm.PixelFormat :=FPixelFormat;
tm:=tbitmap.create;
tm.width:=2*radius;
tm.height:=2*radius;
tm.PixelFormat :=FPixelFormat;
tm.canvas.brush.color:=clblack;
tm.canvas.Ellipse (0,0,tm.width-1,tm.height-1);
tm.transparent:=true;
tm.TransparentColor :=clblack;
Rd:=rect(0,0,cm.width,cm.height);
Rs:=rect(x-radius,y-radius,x+radius,y+radius);
cm.canvas.CopyRect (Rd,bm.canvas,RS);
for j:=0 to cm.height-1 do begin
p:=cm.scanline[j];
if j>0 then p0:=cm.scanline[j-1];
if j<(h-1) then p1:=cm.scanline[j+1];
for i:=0 to cm.width-1 do begin
case mode of
0: //blue
begin
p[i*3+1]:=0;
p[i*3+2]:=0;
end;
1: //green
begin
p[i*3]:=0;
p[i*3+2]:=0;
end;
2: //red
begin
p[i*3]:=0;
p[i*3+1]:=0;
end;
3: //not blue
begin
p[i*3]:=0;
end;
4: //not green
begin
p[i*3+1]:=0;
end;
5: //not red
begin
p[i*3+2]:=0;
end;
6: //half blue
begin
p[i*3]:=p[i*3]*9 div 10;
end;
7: //half green
begin
p[i*3+1]:=p[i*3+1]*9 div 10;
end;
8: //half red
begin
p[i*3+2]:=p[i*3+2]*9 div 10;
end;
9:// darker
begin
p[i*3]:=round(p[i*3]*10 /11);
p[i*3+1]:=round(p[i*3+1]*10 / 11);
p[i*3+2]:=round(p[i*3+2]*10 /11);
end;
10:// lighter
begin
p[i*3]:=round(p[i*3]*11 / 10);
p[i*3+1]:=round(p[i*3+1]*11 / 10);
p[i*3+2]:=round(p[i*3+2]*11 / 10);
end;
11:// gray
begin
sum:=round((p[i*3]+p[i*3+1]+p[i*3+2])/ 3);
p[i*3]:=sum;
p[i*3+1]:=sum;
p[i*3+2]:=sum;
end;
12:// mix
begin
c:=p[i*3];
p[i*3]:=p[i*3+1];
p[i*3+1]:=p[i*3+2];
p[i*3+2]:=c;
end;
13://smooth
begin
if ((j>0) and (j<(h-1))and (i>0)and (i<(w-1))) then begin
p[i*3]:=round((p[(i-1)*3]+p[(i+1)*3]+p0[i*3]+p1[i*3]) /4);
p[i*3+1]:=round((p[(i-1)*3+1]+p[(i+1)*3+1]+p0[i*3+1]+p1[i*3+1]) /4);
p[i*3+2]:=round((p[(i-1)*3+2]+p[(i+1)*3+2]+p0[i*3+2]+p1[i*3+2]) / 4);
end;
end;
end;
end;
end;
cm.canvas.Draw (0,0,tm);
cm.transparent:=true;
cm.transparentcolor:=clwhite;
bm.Canvas.draw(x-radius,y-radius,cm);
cm.free;
tm.free;
end;
A linked question which is helpful is this - implementing scan line of bitmap corectly. It suggests to cast the pointers to NativeInt. The OP changed his code after answers, making it difficult to correlate old code with new code. I understand that my problem is due to some hard coded sequential access of pointers but I am really beginner to make sense of scan line or pointers. If you help me port this, these components will continue to be useful to everyone.
update after comment from #Renate Schaaf:
all the brush modes of the janDrawImage are working now, except for the below one. I was expecting a bigger problem but that didn't turn out to be the case. So modified the title of the question. #Renate Schaaf Can you please help fix the below one too. I tried but failed.
procedure TjanDrawImage.rimple(src,dst:tbitmap;amount:extended);
var ca,sa,a,dx,dy,r,rx,ry,sr,fr:extended;
w,h,x,y,cx,cy,i,j,c,ci:NativeInt;
p1,p2:pbytearray;
begin
w:=src.width;
h:=src.height;
cx:=w div 2;
cy:=h div 2;
if amount<1 then amount:=1;
fr:=cx/amount;
for y:=0 to h-1 do begin
p1:=src.ScanLine[y];
for x:=0 to w-1 do begin
dx:=x-cx;dy:=-(y-cx);
r:=sqrt(sqr(dx)+sqr(dy));
sr:=fr*sin(r/cx*amount*2*pi);
if (r+sr<cx) and (r+sr>0) then begin
a:=arctan2(dy,dx);
sincos(a,sa,ca);
i:=cx+round((r+sr)*ca);
j:=cy+round((r+sr)*sa);
p2:=dst.scanline[j];
c:=x*3;ci:=i*3;
p2[ci]:=p1[c];
p2[ci+1]:=p1[c+1];
p2[ci+2]:=p1[c+2];
end;
end;
end;
end;
When you do scanline operations, you always need to make sure that your pixel location is within the boundaries of your bitmap, particularly if you make geometric transformations.
So, in the last example you must clamp j to [0,h-1] and i to [0,w-1] using max(min(..)).
Also, you should set the size and pixelformat of src and dst to the same at the beginning.
I didn't really bother to find out what this ripple is supposed to do, but when I run an example it doesn't look like it's doing whatever it does right. For geometric transformations you need to work backwards, running through the pixels of the destination and figure out which pixel of the source needs to go there. Otherwise you end up with a destination that has holes, like here.
Edit:
Since I'm stuck with my project: I think this is the routine you really want to use. Note that I just switched the roles of src and dst and corrected some errors. It now adds a water ripple effect to the bitmap.
procedure rimple(src, dst: TBitmap; amount: extended);
var
ca, sa, a, dx, dy, r, sr, fr: extended;
w, h, x, y, cx, cy, i, j, c, ci: NativeInt;
p1, p2: pbytearray;
bits: integer;
begin
Assert(src.PixelFormat in [pf24bit, pf32bit],
'Device independent bitmap needed');
dst.PixelFormat := src.PixelFormat;
bits := 3;
if src.PixelFormat = pf32bit then
bits := 4;
w := src.width;
h := src.height;
dst.SetSize(w, h);
cx := w div 2;
cy := h div 2;
// in case somebody enters a negative amount
if abs(amount) < 1 then
amount := 1;
fr := cx / amount;
for y := 0 to h - 1 do
begin
// switched src and dst
p1 := dst.scanline[y]; // src.scanline[y];
for x := 0 to w - 1 do
begin
dx := x - cx;
// Corrected from dy:=-(y-cx)
dy := (y - cy);
r := sqrt(sqr(dx) + sqr(dy));
sr := fr * sin(r / cx * amount * 2 * pi);
// Omitted the following check
// if (r + sr < cx) and (r + sr > 0) then
begin
a := arctan2(dy, dx);
sincos(a, sa, ca);
i := max(min(cx + round((r + sr) * ca), w - 1), 0);
j := max(min(cy + round((r + sr) * sa), h - 1), 0);
// switched src and dst
p2 := src.scanline[j];
c := x * bits;
ci := i * bits;
p1[c] := p2[ci];
p1[c + 1] := p2[ci + 1];
p1[c + 2] := p2[ci + 2];
end;
end;
end;
end;
How can I set TImage size as double value? Example Image1.width := 50.1; or what component accept it, because TImage only accept integer values.
I'm working with download files, and one image should be the number of elements to download, so Image1.width max value is 340, i need to divide this value by the amount of files who will be downloaded, and increase this value on image1.width when every download be finished, but TImage only accept Integer value.
I already did it using "Round" but it is not what I need.
As answered, you cannot set the image's size to any floating point value.
However, using coordinate spaces and transformations functions, you can set an arbitrary transformation between a logical coordinate system and the viewing device. This can be used to increase the logical extent of the image's canvas size with each download and yet keep the image on the screen with an entirely different size.
The below example demonstrates the concept by drawing 4 rows and 4 columns of a 256x256 image on a 105x105 bitmap canvas of a TPicture of a TImage. Basically it achieves to draw a single 256x256 image on a 26.25x26.25 px. surface.
uses
pngimage;
procedure TForm1.Button1Click(Sender: TObject);
const
Col = 4;
Row = 4;
var
Png: TPngImage;
ImgCanvas: TCanvas;
ExtX, ExtY: Integer;
MapMode: Integer;
Size: TSize;
i, j: Integer;
begin
Png := TPngImage.Create;
try
Png.LoadFromFile('...\Attention.png');
Png.Draw(Canvas, Rect(0, 0, Png.Width, Png.Height)); // original picture
Image1.Picture.Bitmap.Canvas.Brush.Color := Color;
Image1.Picture.Bitmap.SetSize(Image1.Width, Image1.Height);
ImgCanvas := Image1.Picture.Bitmap.Canvas;
SetStretchBltMode(ImgCanvas.Handle, HALFTONE);
MapMode := SetMapMode(ImgCanvas.Handle, MM_ISOTROPIC);
if MapMode <> 0 then
try
ExtX := Png.Width * Col;
ExtY := Png.Height * Row;
if not GetWindowExtEx(ImgCanvas.Handle, Size) then
RaiseLastOSError;
if not SetWindowExtEx(ImgCanvas.Handle, Size.cx * ExtX div Image1.Width,
Size.cy * ExtY div Image1.Height, nil) then
RaiseLastOSError;
if not SetViewportExtEx(ImgCanvas.Handle, Size.cx, Size.cy, nil) then
RaiseLastOSError;
i := 0;
j := 0;
while j < ExtY do begin
while i < ExtX do begin
Png.Draw(ImgCanvas, Rect(i, j, i + Png.Width, j + Png.Height));
Inc(i, Png.Width);
end;
i := 0;
Inc(j, Png.Height);
end;
finally
SetMapMode(ImgCanvas.Handle, MapMode);
end
else
RaiseLastOSError;
finally
Png.Free;
end;
end;
Probably worth noting that GDI may not be the best graphics system when scaling is involved. For quick reference, here's what the above yields:
Assuming you're using the VCL framework, all controls across Delphi are Integer based. You simply cannot assign a float value, not without first converting it to an integer.
The Firemonkey framework on the other hand is widely based on float values.
I am using a paintbox component to draw various shapes using rect, polygon and other canvas methods. After the user has created the drawing, I want to save a bitmap for use in a listbox. The problem is that the drawing may only use a small portion of the canvas and the resulting image in the listbox would be very small unless I adjust its size by selecting only the used portion of the paintbox's original canvas. So the question is how do I determine what portion of the canvas has been used so I can extract only that part of the canvas to load into a bitmap for display in listbox?
(Note:I edited above to clarify the question a bit)
The actual program has a paintbox (200x200) and an image (32 x 32). The image gets its bitmap from the paintbox using Bitmap1.Canvas.CopyRect(Dest, PaintBox1.Canvas, Source);. If the drawing in the paintbox is only 20x20 in the 200x200 paintbox.canvas, then the resulting bitmap in the Image.canvas will be very small in the 32x32 image.canvas. I need it to be enlarged and that means that I must determine the actual size of the used area in the paintbox and change the source size in 'CopyRec'.
One approach I have worked out is based on the assumption that the various items that have been drawn such as circles, rectangles, text, etc are all placed on a neutral background. In that case I can read the bitmap using tbitmap.scanline to compare the color of the drawing vs the background color and calculate the extents of the drawing in each row to determine the extents of the drawing in the overall bitmap.
TRGBTriple = packed record
rgbtBlue: Byte;
rgbtGreen: Byte;
rgbtRed: Byte;
end;
TRGBTripleArray = ARRAY[Word] of TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray; // use a PByteArray for pf8bit color
function findBMPExtents (Bmp : tbitmap; BkgdClr : longint):trect;
// finds the extents of an image in a background or BkgdClr color
//works on 24 bit colors
var
P : pRGBTripleArray;
x,y : integer;
tfound, bfound, done : boolean;
WorkTrpl : TRGBTriple;
WorkRect : trect;
begin
result.top := 0;
result.bottom := Bmp.height;
result.left := Bmp.Width;
result.right := 0;
tfound := false;
bfound := false;
WorkTrpl := getRGB (BkgdClr);
//find left and top
y := 0;
done := false;
Repeat
P := Bmp.ScanLine[y];
x := 0;
Repeat
if (p[x].rgbtBlue <> WorkTrpl.rgbtBlue) or
(p[x].rgbtGreen <> WorkTrpl.rgbtGreen) or
(p[x].rgbtRed <> WorkTrpl.rgbtRed) then
begin
tfound := true;
if x <= result.left then begin
result.left := x;
done := true;
end;
end;
inc (x);
until (x = bmp.width) or done;
done := false;
inc (y);
if not tfound then
inc(result.top);
until (y = bmp.height);
//find right and bottom
y := bmp.height - 1;
done := false;
Repeat
P := Bmp.ScanLine[y];
x := bmp.width-1;
Repeat
if (p[x].rgbtBlue <> WorkTrpl.rgbtBlue) or
(p[x].rgbtGreen <> WorkTrpl.rgbtGreen) or
(p[x].rgbtRed <> WorkTrpl.rgbtRed) then
begin
bfound := true;
if x >= result.right then begin
result.right := x;
done := true;
end;
end;
dec (x);
Until (x = 0) or done;
if not bfound then
dec(result.bottom);
done := false;
dec (y);
Until (y = -1);
dec(result.bottom);
end;
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;
With Delphi 2010 you can get the pixelformat of a jpg file with
TJPEGImage ( Image.Picture.Graphic ).PixelFormat
Is there a way to get the pixelformat or bitdepth of TPNGImage?
I tried this but it returns incorrect bitdepth:
if Lowercase ( ExtractFileExt ( FPath ) ) = '.png' then
StatusBar1.Panels [ 4 ].Text := ' Color Depth: ' + IntToStr( TPNGImage ( Image.Picture.Graphic ).Header.ColorType ) + '-bit';
you must use the BitDepth field
TPNGImage(Image.Picture.Graphic ).Header.BitDepth)
and using the ColorType field you can wirte a function like this
function BitsForPixel(const AColorType, ABitDepth: Byte): Integer;
begin
case AColorType of
COLOR_GRAYSCALEALPHA: Result := (ABitDepth * 2);
COLOR_RGB: Result := (ABitDepth * 3);
COLOR_RGBALPHA: Result := (ABitDepth * 4);
COLOR_GRAYSCALE, COLOR_PALETTE: Result := ABitDepth;
else
Result := 0;
end;
end;
and use like so
procedure TForm72.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr( BitsForPixel(
TPNGImage ( Image1.Picture.Graphic ).Header.ColorType,
TPNGImage ( Image1.Picture.Graphic ).Header.BitDepth
)));
end;
As Rodrigo pointed out, Header.BitDepth is the value to use. The pitfall is that you have to interpret it depending on the ColorType. You may find some hints in the comments inside function BytesForPixels in PngImage.pas:
{Calculates number of bytes for the number of pixels using the}
{color mode in the paramenter}
function BytesForPixels(const Pixels: Integer; const ColorType,
BitDepth: Byte): Integer;
begin
case ColorType of
{Palette and grayscale contains a single value, for palette}
{an value of size 2^bitdepth pointing to the palette index}
{and grayscale the value from 0 to 2^bitdepth with color intesity}
COLOR_GRAYSCALE, COLOR_PALETTE:
Result := (Pixels * BitDepth + 7) div 8;
{RGB contains 3 values R, G, B with size 2^bitdepth each}
COLOR_RGB:
Result := (Pixels * BitDepth * 3) div 8;
{Contains one value followed by alpha value booth size 2^bitdepth}
COLOR_GRAYSCALEALPHA:
Result := (Pixels * BitDepth * 2) div 8;
{Contains four values size 2^bitdepth, Red, Green, Blue and alpha}
COLOR_RGBALPHA:
Result := (Pixels * BitDepth * 4) div 8;
else
Result := 0;
end {case ColorType}
end;
As you see, for ARGB (= COLOR_RGBALPHA) the BitDepth value is taken for each color part plus the alpha value individually. So BitDepth = 8 will result in a 32-bit value for each pixel.