What is the fastest way of getting the area of any arbitrary Windows region?
I know I can enumerate all points of bounding rectangle and call the PtInRegion() function but it seems not very fast. Maybe you know some faster way?
When you call GetRegionData, you'll get a list of non-overlapping rectangles that make up the region. Add up their areas, something like this:
function GetRegionArea(rgn: HRgn): Cardinal;
var
x: DWord;
Data: PRgnData;
Header: PRgnDataHeader;
Rects: PRect;
Width, Height: Integer;
i: Integer;
begin
x := GetRegionData(rgn, 0, nil);
Win32Check(x <> 0);
GetMem(Data, x);
try
x := GetRegionData(rgn, x, Data);
Win32Check(x <> 0);
Header := PRgnDataHeader(Data);
Assert(Header.iType = rdh_Rectangles);
Assert(Header.dwSize = SizeOf(Header^));
Rects := PRect(Cardinal(Header) + Header.dwSize);
// equivalent: Rects := PRect(#Data.Buffer);
Result := 0;
for i := 0 to Pred(Header.nCount) do begin
Width := Rects.Right - Rects.Left;
Height := Rects.Bottom - Rects.Top;
Inc(Result, Width * Height);
Inc(Rects);
end;
finally
FreeMem(Data);
end;
end;
Related
I cannot seem to figure out how to print multiple images in one page using Printer,
I want to display images side by side like this:
But the problem is the images always display in full page like this:
I have this code:
procedure TForm1.Button1Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
Bitmap : TBitmap;
i: integer;
begin
try
Bitmap := TBitmap.Create;
Bitmap.Width := Image1.Picture.Width;
Bitmap.Height := Image1.Picture.Height;
Bitmap.Canvas.Draw(0,0,Image1.Picture.Graphic);
if PrintDialog1.Execute then
begin
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / Screen.pixelsperinch;
Printer.BeginDoc;
MyRect := Rect(0,0, trunc(Bitmap.Width * scale), trunc(Bitmap.Height * scale));
Printer.Canvas.StretchDraw(MyRect, Bitmap);
Printer.EndDoc;
end;
finally
Bitmap.Free;
end;
end;
I want to the printer to printout images side by side, how can I accomplish that?
Can any one help me please?
Update:
procedure TForm1.Button1Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
Bitmap : TBitmap;
i, x, y, width, height, img_count: integer;
begin
Bitmap := TBitmap.Create;
x := 0;
y := 0;
img_count := 3;
try
begin
Bitmap.Width := Image1.Picture.Width;
Bitmap.Height := Image1.Picture.Height;
Bitmap.Canvas.Draw(0,0,Image1.Picture.Graphic);
if PrintDialog1.Execute then
begin
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / Screen.pixelsperinch;
Printer.BeginDoc;
for i := 1 to img_count do
begin
width := trunc(Bitmap.Width * scale / img_count);
height := trunc(Bitmap.Height * scale / img_count);
MyRect := Rect(x, y, width, height);
Printer.Canvas.StretchDraw(MyRect, Bitmap);
x := x + width;
end;
Printer.EndDoc;
end;
end;
finally
Bitmap.Free;
end;
end;
Now it displays the images like sticking at each other, an I want them to display with a little margin between them:
This is when I add margins:
This is without margins:
You have to halfway understand your code, then it will all become obvious. Canvas and Rect are literally just that - and if you max your rectangle out by scale you'll never put two pictures side by side. Cut the values in half and use understand the parameters of functions - I'll use more variables to make it more obvious why your approach is very easy to solve:
var
x, y, width, height: Integer;
...
begin
...
Printer.BeginDoc;
x:= 0; // Start on top left
y:= 0;
width:= trunc( Bitmap1.Width* scale/ 2 ); // Half of the size
height:= trunc( Bitmap1.Height* scale/ 2 )
Printer.Canvas.StretchDraw( Rect( x, y, width, height ), Bitmap1 );
x:= width; // Continue after picture on the right side
width:= trunc( Bitmap2.Width* scale/ 2 ); // Again half of the size
height:= trunc( Bitmap2.Height* scale/ 2 )
Printer.Canvas.StretchDraw( Rect( x, y, width, height ), Bitmap2 );
Printer.EndDoc;
This example presumes Bitmap1 and Bitmap2 have similar dimensions.
I have an image list containing several bitmaps which I would like to save together as one single bitmap, but I need it saving just like how a spritesheet or tilesheet is drawn in 2d and rpg games etc.
Typically the tilesheet is drawn with several images across (in a row), so for example if I wanted a maximum of 6 images per row, it will only draw 6, with further images been drawn underneath in a new row.
I can save it in one single row like so:
var
CurrentFrame: Integer;
StripWidth: Integer;
Strip: TBitmap;
Bmp: TBitmap;
I: Integer;
begin
if SaveDialog.Execute then
begin
StripWidth := ImageList1.Width * ImageList1.Count - ImageList1.Width;
CurrentFrame := - ImageList1.Width;
Strip := TBitmap.Create;
try
Strip.SetSize(StripWidth, ImageList1.Height);
Bmp := TBitmap.Create;
try
for I := 0 to ImageList1.Count - 1 do
begin
CurrentFrame := CurrentFrame + ImageList1.Width;
ImageList1.GetImage(I, Bmp);
Strip.Canvas.Draw(CurrentFrame, 0, Bmp);
end;
finally
Bmp.Free;
end;
Strip.SaveToFile(SaveDialog.FileName);
finally
Strip.Free;
end;
end;
end;
So imagine the result for the above is:
The result I want is something like:
So the above would have considered in the procedure/ function a parameter to allow only 3 images per row as an example.
How do I export all images from an imagelist into one single bitmap, allowing only x amount if images to be drawn horizontally before creating a new row?
Thanks.
EDIT
Thanks to David's answer, I put together these procedures:
procedure DrawImageOnSheet(Images: TImageList; Sheet: TBitmap;
ImageIndex, X, Y: Integer);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
Images.GetBitmap(ImageIndex, Bitmap);
Sheet.Canvas.Draw(X, Y, Bitmap);
finally
Bitmap.Free;
end;
end;
procedure SaveImageListAsSheet(Images: TImageList; FileName: string;
NumberOfColumns: Integer);
var
Sheet: TBitmap;
nImage: Integer;
nCol: Integer;
nRow: Integer;
nToDraw: Integer;
nRemaining: Integer;
ImageIndex: Integer;
X, Y: Integer;
I: Integer;
begin
Sheet := TBitmap.Create;
try
nImage := Images.Count;
nCol := NumberOfColumns;
nRow := (nImage + nCol - 1) div nCol;
Sheet.Height := nRow * Images.Height;
Sheet.Width := nCol * Images.Width;
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for I := 0 to nToDraw - 1 do
begin
DrawImageOnSheet(Images, Sheet, ImageIndex, X, Y);
Inc(ImageIndex);
Inc(X, Images.Width);
end;
Inc(Y, Images.Height);
Dec(nRemaining, nToDraw);
end;
Sheet.SaveToFile(FileName);
finally
Sheet.Free;
end;
end;
According to clarification from the comments, you are struggling with the counting of the images, the organisation of the rows/columns and so on. So, let's assume you already have this function which draws image ImageIndex to the output bitmap at a position of X, Y.
procedure Draw(ImageIndex, X, Y: Integer);
Let's also assume that the images have dimensions given by ImageWidth and ImageHeight. Finally, there are nImage images and you want to have nCol images per column.
So, first of all, how many rows do you need?
nRow := (nImage + nCol - 1) div nCol;
Now you can set the size of the output bitmap. Its width is nCol * ImageWidth and its height is nRow * ImageHeight.
Now to draw the images.
nRemaining := nImage;
ImageIndex := 0;
Y := 0;
while nRemaining > 0 do
begin
nToDraw := Math.Min(nRemaining, nCol);
X := 0;
for i := 0 to nToDraw - 1 do
begin
Draw(ImageIndex, X, Y);
inc(ImageIndex);
inc(X, ImageWidth);
end;
inc(Y, ImageHeight);
dec(nRemaining, nToDraw);
end;
Hi I use the follow code to draw a rotate text in my Delphi application. The user can choose if use or not use GDI+ to draw the text:
procedure TForm1.Button1Click(Sender: TObject);
var
MyLogFont: TLogFont;
MyFont: HFont;
t: string;
ff: IGPFontfamily;
ft: IGPFont;
br: IGPSolidBrush;
gr: IGPGraphics;
pp: TGPPointF;
Pen: IGPPen;
begin
t := 'Hello';
if not DrawUsingGDIP.Checked then
begin
// Draw using GDI
FillChar(MyLogFont, Sizeof(MyLogFont), 0);
with MyLogFont do
begin
lfHeight:=0;
lfWidth:=0;
lfEscapement:=-StrToInt(Edit1.Text)*10;
lfOrientation:=-StrToInt(Edit1.Text)*10;
lfWeight:=FW_NORMAL;
lfItalic:=0;
lfUnderline:=0;
lfStrikeOut:=0;
lfCharSet:=DEFAULT_CHARSET;
lfOutPrecision:=OUT_DEFAULT_PRECIS;
lfClipPrecision:=CLIP_DEFAULT_PRECIS;
lfQuality:=DEFAULT_QUALITY;
lfPitchAndFamily:=1;
end;
MyFont:=CreateFontIndirect(MyLogFont);
Form1.Canvas.Font.Handle:=MyFont;
Form1.Canvas.Font.Name := 'Arial';
Form1.Canvas.Font.Size := 13;
Form1.Canvas.TextOut(103, 100, t);
end
else
begin
// Draw using GDI+
Pen := TGPPen.Create($FF000000);
ff := TGPFontFamily.Create('Arial');
ft := TGPFont.Create(ff, 16, FontStyleRegular, UnitPixel);
br := TGPSolidBrush.Create(TGPColor.Red);
gr := TGPGraphics.Create(Form1.Canvas.Handle);
gr.SetTextRenderingHint(TextRenderingHintAntiAlias);
gr.TranslateTransform(100.0, 100.0);
gr.RotateTransform(StrToInt(Edit1.Text));
pp := TGPPointF.Create(0, 0);
gr.DrawString(t, ft, pp, br);
gr.ResetTransform;
end;
end;
Now I need know (if possible without draw the text) the coordinates of the vertices of the rectangle that bounds the text (see the image):
Is there a simple way to get these coordinates both with and without use GDI+ library?
For the GDI implementation you can use something like
tsiz := Form1.Canvas.TextExtent(t); // tsiz : tagSIZE
ang := (2.0*Pi*StrToInt(Edit1.Text))/360; // ang : double
tpts[0].X := 100; // tpts : Array[0..4] of TPoint
tpts[0].Y := 100;
tpts[1].X := 100 + Round(tsiz.cx * Cos(ang));
tpts[1].Y := 100 + Round(tsiz.cx * Sin(ang));
tpts[2].X := tpts[1].X - Round(tsiz.cy*Sin(ang));
tpts[2].Y := tpts[1].Y + Round(tsiz.cy*Cos(ang));
tpts[3].X := tpts[0].X - Round(tsiz.cy*Sin(ang));
tpts[3].Y := tpts[0].Y + Round(tsiz.cy*Cos(ang));
tpts[4] := tpts[0];
//tpts now contains corner points of the bounding rect
Form1.Canvas.TextOut(100, 100, t); // draw text
Form1.Canvas.Polyline(tpts); // draw bounding rect
for GDI+ it's a lot easier
sft := TGPStringFormat.GenericDefault; // sft : IGPStringFormat
mRect := gr.MeasureString(t, ft, pp, sft); // mRect : TGPRectF
// do this after transforms
// mRect is now the bounding rect
gr.DrawRectangle(Pen,mRect);
// mRect is transformed by DrawRectangle - coordinates can be
// calculated in the same way as the GDI case where
// mRect.Width -> tsiz.cx and mRect.Height -> tsiz.cy
I would like to know if there is a way to change the orientation of a TShape thus instead of a square , i would like to rotate it to look like a diamond..
If not a way with TShape, how could this be done?
A Delphi TShape is nothing more than drawing a bunch of vector graphics.
You can "rotate" the X/Y coordinates themselves with a 2-D transformation matrix. Computer Graphics 101:
http://www.cs.uic.edu/~jbell/CourseNotes/ComputerGraphics/2DTransforms.html
http://www.willamette.edu/~gorr/classes/GeneralGraphics/Transforms/transforms2d.htm
A TShape itself cannot be rotated. But you can use a TPaintBox to draw your own graphics anyway you wish, it is just a matter of mathematically plotting the points to draw between. For example:
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
Points: array[0..3] of TPoint;
W, H: Integer;
begin
W := PaintBox1.Width;
H := PaintBox1.Height;
Points[0].X := W div 2;
Points[0].Y := 0;
Points[1].X := W;
Points[1].Y := H div 2;
Points[2].X := Points[0].X;
Points[2].Y := H;
Points[3].X := 0;
Points[3].Y := Points[1].Y;
PaintBox1.Canvas.Brush.Color := clBtnFace;
PaintBox1.Canvas.FillRect(Rect(0, 0, W, H));
PaintBox1.Canvas.Brush.Color := clBlue;
PaintBox1.Canvas.Pen.Color := clBlack;
PaintBox1.Canvas.Pen.Width := 1;
PaintBox1.Canvas.Polygon(Points);
end;
I'm currently trying to add mirroring to our RotateBitmap routine (from http://www.efg2.com/Lab/ImageProcessing/RotateScanline.htm). This currently looks like this (BitMapRotated is a TBitmap) in pseudo-code:
var
RowRotatedQ: pRGBquadArray; //4 bytes
if must reflect then
begin
for each j do
begin
RowRotatedQ := BitmapRotated.Scanline[j];
manipulate RowRotatedQ
end;
end;
if must rotate then
begin
BitmapRotated.SetSize(NewWidth, NewHeight); //resize it for rotation
...
end;
This works if I either must rotate or reflect. If I do both then apparently the call to SetSize invalidates my previous changes via ScanLine. How can I "flush" or save my changes? I tried calling BitmapRotated.Handle, BitmapRotated.Dormant and setting BitmapRotated.Canvas.Pixels[0, 0] but without luck.
Edit: I found the real issue - I'm overwriting my changes with values from the original bitmap. Sorry for the effort.
Perhaps this is not really an answer, but this code works in both D2006 and XE3 and gives the expected result. There is no need to 'flush' anything.
procedure RotateBitmap(const BitMapRotated: TBitmap);
type
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = array [Byte] of TRGBQuad;
var
RowRotatedQ: PRGBQuadArray;
t: TRGBQuad;
ix, iy: Integer;
begin
//first step
for iy := 0 to BitMapRotated.Height - 1 do begin
RowRotatedQ := BitMapRotated.Scanline[iy];
// make vertical mirror
for ix := 0 to BitMapRotated.Width div 2 - 1 do begin
t := RowRotatedQ[ix];
RowRotatedQ[ix] := RowRotatedQ[BitMapRotated.Width - ix - 1];
RowRotatedQ[BitMapRotated.Width - ix - 1] := t;
end;
end;
//second step
BitMapRotated.SetSize(BitMapRotated.Width + 50, BitMapRotated.Height + 50);
//some coloring instead of rotation
for iy := 0 to BitMapRotated.Height div 10 do begin
RowRotatedQ := BitMapRotated.Scanline[iy];
for ix := 0 to BitMapRotated.Width - 1 do
RowRotatedQ[ix].rgbRed := 0;
end;
end;
var
a, b: TBitmap;
begin
a := TBitmap.Create;
a.PixelFormat := pf32bit;
a.SetSize(100, 100);
a.Canvas.Brush.Color := clRed;
a.Canvas.FillRect(Rect(0, 0, 50, 50));
b := TBitmap.Create;
b.Assign(a);
RotateBitmap(b);
Canvas.Draw(0, 0, a);
Canvas.Draw(110, 0, b);