I need to resize (png) images depending on the size of the screen. Currently I use the procedure below, but transparency is lost in conversion.
I'm sure there must be a more efficient way to achieve the same result, but I'm not that proficient with graphics.
procedure TFormMain.LoadAndSizeImagesForScreen(ImageFilename: string;
PngImage: TPngImage);
var
PngObject: TPngObject;
TempPngImage: TPngImage;
Bitmap: TBitmap;
Ratio: real;
begin
try
TempPngImage := TPngImage.Create;
TempPngImage.Transparent := True;
TempPngImage.TransparentColor := clWhite;
TempPngImage.LoadFromFile(ImageFilename);
//Determine the ration with which to increase/decrease image size
//BigScreenHeight is the base-line: 1050 currently.
Ratio := Screen.Height / BigScreenHeight;
//Create a bitmap to resize
Bitmap := TBitmap.Create;
//Resize the image to fit the target screen
Bitmap.Width := Round(TempPngImage.Width * Ratio);
Bitmap.Height := Round(TempPngImage.Height * Ratio);
Bitmap.Canvas.StretchDraw(Rect(0, 0, Bitmap.Width, Bitmap.Height), TempPngImage);
//Create a temporary object
PngObject := TPngObject.Create;
PngObject.Assign(Bitmap);
PngImage.Assign(PngObject);
finally
PngObject.Free;
TempPngImage.Free;
Bitmap.Free;
end;
end;
Related
I'm using BDS 2007...
When a user double-clicks a grid cell in our application we display a modal window over the grid. I developed the routine below to draw an animation frame on the grid. It enlarges by drawing and erasing a frame in steps, before the window shows (much like the Windows UI animation). The same routine gets called again (with bExpand=False) after the window closes, to give the UI effect of the window imploding back into the grid cell.
This routine worked fine in Windows XP but misbehaves when Aero is enabled (works fine in Windows 7 without Aero). The animation frame redraws slowly...even if I comment out the DelayMSecs line (which is just a loop that calls Sleep(0) repeatedly until the iDelay number of milliseconds has passed).
And when the routine is called again (after the window closes) it is equally slow, plus leaves a frame on the screen, plus there's a ghost image of the (now closed) window left in place, essentially alpha-blended with the normal display contents of the grid.
Most of the routine's code calculates the changing rectangle size. Only three lines do the actual draw & erase of the animation rect:
ScreenCanvas.Rectangle( r ); //draw frame
SysStuff.DelayMSecs( iDelay ); //
ScreenCanvas.Rectangle( r ); //pmXOR pen ...erase frame
Any ideas on why this is slow under Aero, or what I need to change?
procedure T_fmExplore.AnimateRects(ASourceRect, ADestRect: TRect; bExpand:
boolean; bAdjustSourceForFrame: boolean = True);
{ Draw animation frames in steps, for transition from ASourceRect to ADestRect.
bExpand: determines whether the animation rect is expanding or contracting.
bAdjustSourceForFrame: resize the animation rect smaller for the window frame. }
const
MINSTEPS = 10; //Min redraws of the animation rect (frame)
MAXSTEPS = 20; //30 was too many, too slow
MAXDELAY = 100; //Delay between drawing each rect frame
MINDELAY = 1;
var
iSteps: integer;
DeltaHt: Integer; //Rect size chg for each redraw of animation window
DeltaWidth: Integer;
DeltaTop : integer; //Origin change for each redraw
DeltaLeft : integer;
TgtWidth, TgtHt: Integer;
iTemp: Integer;
iDelay: integer;
r : TRect; //Animation frame's rect
ScreenCanvas: TCanvas;
begin
r := ASourceRect;
TgtWidth := ADestRect.Right - ADestRect.Left; //Target rect's Width
TgtHt := ADestRect.Bottom - ADestRect.Top; //Target rect's Height
//Initially Deltas hold total chg in Width & Height
DeltaWidth := TgtWidth - (r.Right - r.Left); //TgtWidth - old width
DeltaHt := TgtHt - (r.Bottom - r.Top);
//For smooth animation we adjust number of iSteps & Delay relative to the window area.
//Larger window = more iSteps and shorter Delay between drawing each step.
iSteps := Max( DeltaWidth * DeltaHt div 6500, MINSTEPS );
iSteps := Min( iSteps, MAXSTEPS );
//Now convert Deltas to the delta in window rect size
DeltaWidth := DeltaWidth div iSteps;
DeltaHt := DeltaHt div iSteps;
DeltaTop := (ADestRect.Top - ASourceRect.Top) div iSteps;
DeltaLeft := (ADestRect.Left - ASourceRect.Left) div iSteps;
iDelay := Max( MAXDELAY div iSteps, MINDELAY );
ScreenCanvas := TCanvas.Create;
try
ScreenCanvas.Handle := GetDC( 0 ); //Desktop
try
with ScreenCanvas do begin
Pen.Color := clWhite; //Do NOT use clBlack with pmXOR mode: with (r=0, g=0, b=0) there are no bytes to XOR.
Pen.Mode := pmXOR; //MUST use pmXOR pen, so 2nd Rectangle call (see below) erases what we drew.
Pen.Style := psSolid;
Pen.Width := 3; //Thin line. Was: Pen.Width := GetSystemMetrics(SM_CXFRAME);
Brush.Style := bsClear;
if bAdjustSourceForFrame then
InflateRect(ASourceRect, -Pen.Width, -Pen.Width);
repeat
iTemp := (r.Bottom - r.Top) + DeltaHt; //Height
if (bExpand and (iTemp > TgtHt)) or (not bExpand and (iTemp < TgtHt)) then begin
r.Top := ADestRect.Top;
r.Bottom := Top + TgtHt;
end else begin
r.Top := r.Top + DeltaTop; //Assign Top first...Bottom is calc'd from it
r.Bottom := r.Top + iTemp;
end;
iTemp := (r.Right - r.Left) + DeltaWidth; //Width
if (bExpand and (iTemp > TgtWidth)) or (not bExpand and (iTemp < TgtWidth)) then begin
r.Left := r.Left + DeltaLeft;
r.Right := r.Left + TgtWidth;
end else begin
r.Left := r.Left + DeltaLeft; //Assign Left first...Right is calc'd from it
r.Right := r.Left + iTemp;
end;
ScreenCanvas.Rectangle( r ); //draw frame
SysStuff.DelayMSecs( iDelay ); //
ScreenCanvas.Rectangle( r ); //pmXOR pen ...erase frame
until (r.Right - r.Left = TgtWidth) and (r.Bottom - r.Top = TgtHt);
end;
finally
ReleaseDC( 0, ScreenCanvas.Handle );
ScreenCanvas.Handle := 0;
end;
finally
ScreenCanvas.Free;
end;
end;
I want to draw quite complex images with alpha-transparent rectangles and alpha-transparent images.
There is GDI+ wrapper from Mitov, but it doesn't seem to support 32bit BMP files plus it rescales them and the documentation is terrible. BMPs are way faster than PNGs so I want to use them.
There is SynGDI wrapper of GDI+, but it seems very basic and there is no documentation for it.
There is also this trick for GDI:
procedure DrawAlphaAPI(Source: TBitmap; Destination: TCanvas;
const X, Y: Integer; const Opacity: Byte = 255);
var BlendFunc: TBlendFunction;
begin
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := Opacity;
if Source.PixelFormat = pf32bit then
BlendFunc.AlphaFormat := AC_SRC_ALPHA
else
BlendFunc.AlphaFormat := 0;
Windows.AlphaBlend(Destination.Handle, X, Y, Source.Width, Source.Height,
Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, BlendFunc);
end;
But when I call it with Opacity = 255 it draws 32bit bitmaps not properly (something like they are half transparent where they should be fully).
I don't want to use Scanline to make pixels transparent as this will be too complicated to draw all the transparent rectangles this way.
Also I thin GDI+ should be faster on modern computers, am I right?
So the question is: how to draw an alpha transparent rectangle and bitmap easily (without tons of code)?
Preferred Delphi: 7. I also have 2005 and XE3 but since 7 is a speed demon I would most want something to work from 7 up.
If you prepare the ordinary TBitmap, any of the GDI+ implementations can be used just assigning bmp.Canvas.Handle.
Your problem in compiling might be caused by an old DirctDraw-Version in the Folder, just remove it.
implementation
uses GDIPAPI, GDIPOBJ;
{$R *.dfm}
Procedure PrepareBMP(bmp: TBitmap; Width, Height: Integer);
var
p: Pointer;
begin
bmp.PixelFormat := pf32Bit;
bmp.Width := Width;
bmp.Height := Height;
bmp.HandleType := bmDIB;
bmp.ignorepalette := true;
bmp.alphaformat := afPremultiplied;
// clear all Scanlines
p := bmp.ScanLine[Height - 1];
ZeroMemory(p, Width * Height * 4);
end;
procedure TForm2.Button1Click(Sender: TObject);
var
bmp: TBitmap;
G: TGPGRaphics;
B: TGPSolidBrush;
begin
bmp := TBitmap.Create;
try
PrepareBMP(bmp, 300, 300);
G := TGPGRaphics.Create(bmp.Canvas.Handle);
B := TGPSolidBrush.Create(MakeColor(100, 255, 0, 0));
try
G.SetSmoothingMode(SmoothingModeHighQuality);
G.FillEllipse(B, MakeRect(0.0, 0, 300, 300));
B.SetColor(MakeColor(100, 0, 255, 128));
G.FillEllipse(B, MakeRect(40.0, 40, 260, 260));
finally
B.Free;
G.Free;
end;
// draw overlapping in Form Canvas to display transparency
Canvas.Draw(0, 0, bmp);
Canvas.Draw(100, 100, bmp);
finally
bmp.Free;
end;
end;
Question
What's the best way to draw a bitmap with a per-pixel alpha onto a control's Canvas?
My bitmap data is stored in a 2d array of 32-bit pixel values.
T32BitPixel = packed record
Blue : byte;
Green : byte;
Red : byte;
Alpha : byte;
end;
My control is a descendent of TCustomTransparentControl.
Background
For a GUI I'm building I need to draw semi-transparent controls over other controls and textured backgrounds. The control graphics are created using AggPasMod (a port of Anti-Grain Geometry).
TCustomTransparentControl.Canvas.Handle provides access to the device context for drawing but I'm not sure how to blit the pixel data from there.
Assuming, you have your pixel array composed like the image rows and pixels in them, I would do it this way. The Canvas parameter is a target canvas, the X and Y are coordinates, where the bitmap will be rendered in the target canvas and the Pixels is the pixel array:
type
TPixel = packed record
B: Byte;
G: Byte;
R: Byte;
A: Byte;
end;
TPixelArray = array of array of TPixel;
procedure RenderBitmap(Canvas: TCanvas; X, Y: Integer; Pixels: TPixelArray);
var
I: Integer;
Size: Integer;
Bitmap: TBitmap;
BlendFunction: TBlendFunction;
begin
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf32bit;
Bitmap.Width := Length(Pixels[0]);
Bitmap.Height := Length(Pixels);
Size := Bitmap.Width * SizeOf(TPixel);
for I := 0 to Bitmap.Height - 1 do
Move(Pixels[I][0], Bitmap.ScanLine[I]^, Size);
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
AlphaBlend(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,
Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, BlendFunction);
finally
Bitmap.Free;
end;
end;
My task is:
Create a TBitmap object.
Fill it with transparent color (alpha = 0).
Assign this bitmap to TPngImage.
Save PNG file with alpha transparency.
How can I do it in Delphi XE?
var
Png: TPngImage;
X, Y: Integer;
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create();
Bitmap.PixelFormat := pf32bit;
Png := TPngImage.Create();
try
Bitmap.SetSize(100, 100);
// How to clear background in transparent color correctly?
// I tried to use this, but the image in PNG file has solid white background:
for Y := 0 to Bitmap.Height - 1 do
for X := 0 to Bitmap.Width - 1 do
Bitmap.Canvas.Pixels[X, Y]:= $00FFFFFF;
// Now drawing something on a Bitmap.Canvas...
Bitmap.Canvas.Pen.Color := clRed;
Bitmap.Canvas.Rectangle(20, 20, 60, 60);
// Is this correct?
Png.Assign(Bitmap);
Png.SaveToFile('image.png');
finally
Png.Free();
Bitmap.Free();
end;
end;
More or less a copy of Dorin's answer.
It shows how to make a transparent png image and how to clear the background.
uses
PngImage;
...
var
bmp: TBitmap;
png: TPngImage;
begin
bmp := TBitmap.Create;
bmp.SetSize(200,200);
bmp.Canvas.Brush.Color := clBlack;
bmp.Canvas.Rectangle( 20, 20, 160, 160 );
bmp.Canvas.Brush.Style := bsClear;
bmp.Canvas.Rectangle(1, 1, 199, 199);
bmp.Canvas.Brush.Color := clWhite;
bmp.Canvas.Pen.Color := clRed;
bmp.Canvas.TextOut( 35, 20, 'Hello transparent world');
bmp.TransparentColor := clWhite;
bmp.Transparent := True;
png := TPngImage.Create;
png.Assign( bmp );
png.SaveToFile( 'C:\test.png' );
bmp.Free;
png.Free;
end;
Does anyone know a way of cropping, scaling and centering an image (jpg or bitmap) using Delphi?
I have an image with large resolution. I would like to be able to scale it to a lower resolution. The ratio of the target resolution may be different from the original image. I want to keep the original photo aspect ratio, therefore, I don't want to stretch to the new resolution, but crop and center it, to fit best and loose minimal data from the original image. Does anyone know how can it be done using Delphi?
I'm guessing that you want to resize to fill the target image edge to edge, and crop the part that goes out of bounds.
Here's pseudocode. The implementation will differ depending on what you're working with.
// Calculate aspect ratios
sourceAspectRatio := souceImage.Width / sourceImage.Height;
targetAspectRatio := targetImage.Width / targetImage.Height;
if (sourceAspectRatio > targetAspectRatio) then
begin
// Target image is narrower, so crop left and right
// Resize source image
sourceImage.Height := targetImage.Height;
// Crop source image
..
end
else
begin
// Target image is wider, so crop top and bottom
// Resize source image
sourceImage.Width := targetImage.Width;
// Crop source image
..
end;
Only answering the math part of your question here. Please ask a separate question about keeping maximum image quality.
You need to determine the scale in which to draw the image, as well as the position. I suggest you try this routine:
function CropRect(const Dest: TRect; SrcWidth, SrcHeight: Integer): TRect;
var
W: Integer;
H: Integer;
Scale: Single;
Offset: TPoint;
begin
W := Dest.Right - Dest.Left;
H := Dest.Bottom - Dest.Top;
Scale := Max(W / SrcWidth, H / SrcHeight);
Offset.X := (W - Round(SrcWidth * Scale)) div 2;
Offset.Y := (H - Round(SrcHeight * Scale)) div 2;
with Dest do
Result := Rect(Left + Offset.X, Top + Offset.Y, Right - Offset.X,
Bottom - Offset.Y);
end;
And a sample calling code:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FGraphic: TGraphic;
end;
implementation
{$R *.dfm}
uses
Jpeg, Math, MyUtils;
procedure TForm1.FormCreate(Sender: TObject);
begin
FGraphic := TJPEGImage.Create;
FGraphic.LoadFromFile('MonaLisa.jpg');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FGraphic.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
R: TRect;
begin
R := CropRect(ClientRect, FGraphic.Width, FGraphic.Height);
Canvas.StretchDraw(R, FGraphic);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;