i'm trying to paint vcl style background from TSeStyleFont like in Bitmap Style Designer ..
is there any way to draw the background ?
i have make a try :
- draw the object first in a bitmap using DrawElement .
- than copy current bitmap to a nother clean bitmap using 'Bitmap.Canvas.CopyRect' the problem is that : this methode does not work correctly with objects that has Glyph such as CheckBox ...
var
bmp, bmp2: TBitmap;
Details: TThemedElementDetails;
R, Rn: TRect;
begin
bmp := TBitmap.Create;
bmp2 := TBitmap.Create;
R := Rect(0, 0, 120, 20);
Rn := Rect(0 + 4, 0 + 4, 120 - 4, 20 - 4);
bmp.SetSize(120, 20);
bmp2.SetSize(120, 20);
Details := StyleServices.GetElementDetails(TThemedButton.tbPushButtonHot);
StyleServices.DrawElement(bmp.Canvas.Handle, Details, R);
bmp2.Canvas.CopyRect(R, bmp.Canvas, Rn);
Canvas.Draw(10, 10, bmp2);
bmp.Free;
bmp2.Free;
end;
If you want draw the background of the buttons you must use the StyleServices.DrawElement method passing the proper TThemedButton part.
Try this sample
uses
Vcl.Styles,
Vcl.Themes;
{$R *.dfm}
procedure TForm2.Button1Click(Sender: TObject);
var
Details : TThemedElementDetails;
begin
Details := StyleServices.GetElementDetails(tbPushButtonPressed);
StyleServices.DrawElement(PaintBox1.Canvas.Handle, Details, PaintBox1.ClientRect);
Details := StyleServices.GetElementDetails(tbPushButtonNormal);
StyleServices.DrawElement(PaintBox2.Canvas.Handle, Details, PaintBox2.ClientRect);
end;
If you want draw the background without corners, you can adjust the bounds of the TRect like so
Details : TThemedElementDetails;
LRect : TRect;
begin
LRect:=PaintBox1.ClientRect;
LRect.Inflate(3,3);
Details := StyleServices.GetElementDetails(tbPushButtonPressed);
StyleServices.DrawElement(PaintBox1.Canvas.Handle, Details, LRect);
LRect:=PaintBox2.ClientRect;
LRect.Inflate(3,3);
Details := StyleServices.GetElementDetails(tbPushButtonNormal);
StyleServices.DrawElement(PaintBox2.Canvas.Handle, Details, LRect);
end;
Related
I need a little help...
I have a transparent PNG image in my application resources. Until now I was loading it in a TPngImage and draw it on the screen with Canvas.Draw(X, Y, PngImage);. And it was drawn transparently. Now I updated my application to be DpiAware and I need to scale all images. I need a quality resampler and I choose to use Graphics32. I managed to do the resampling but I don't know how to keep the transparecy... I try all that I cand think of... The result of the following code is the image drawn with black color in the transparent region...
Foto32, Buff: TBitmap32;
FotoPng: TPngImage;
constructor TForm.Create(AOwner: TComponent);
const BkgHeight = 380;
var Res: TKernelResampler;
SRect, DRect: TRect;
ImgWidth: Integer;
begin
inherited;
Buff:= TBitmap32.Create;
Res:= TKernelResampler.Create;
Res.Kernel:= TLanczosKernel.Create;
FotoPng:= TPngImage.Create;
FotoPng.Transparent:= True;
FotoPng.TransparentColor:= clBlack;
FotoPng.LoadFromResourceName(HInstance, 'BKG_FOTO');
Foto32:= TBitmap32.Create;
Foto32.DrawMode:= dmBlend;
Foto32.CombineMode:= cmMerge;
Foto32.OuterColor:= clBlack;
Foto32.Canvas.Brush.Style:= bsClear;
Foto32.SetSize(FotoPng.Width, FotoPng.Height);
FotoPng.Draw(Foto32.Canvas, Rect(0, 0, FotoPng.Width, FotoPng.Height));
ImgWidth:= Round(Real(Foto32.Width / Foto32.Height) * BkgHeight);
SRect:= Rect(0, 0, Foto32.Width, Foto32.Height);
Buff.DrawMode:= dmBlend;
Buff.CombineMode:= cmMerge;
Buff.OuterColor:= clBlack;
Buff.Canvas.Brush.Style:= bsClear;
Buff.SetSize(Scale(ImgWidth), Scale(BkgHeight));
DRect:= Rect(0, 0, Buff.Width, Buff.Height);
Res.Resample(Buff, DRect, DRect, Foto32, SRect, dmTransparent {dmBlend}, nil);
end;
procedure TForm.Paint;
begin
// ....
Buff.DrawTo(Canvas.Handle, X, Y);
end;
And this is my transparent PNG image compiled into resources:
https://postimg.cc/3yy3wrJB
I found here a similar question, but I don't use the image with a TImage, I draw it directly on the canvas. And in the single answer, David says:
Anyway, if that is so, I would combine the transparency support of
TImage with the re-sampling ability of TBitmap32 to build a solution
that way. Keep the original image in a TBitmap32 instance. Whenever
you need to load it into the TImage component, for example when
re-sizing, use TBitmap32 to perform an in-memory re-size and load that
re-sized image.
This is exactly what I'm trying to do, but I don't know why the transparecy is not working. Any ideas ?
Your issue seems to be an issue with drawing the Buffer to the screen. Bitmap32 uses StretchDIBits for painting which ignores the alpha channel.
You could use the AlphaBlend function in order to draw your image:
procedure TForm1.FormPaint(Sender: TObject);
var
BF: TBlendFunction;
begin
BF.BlendOp := AC_SRC_OVER;
BF.BlendFlags := 0;
BF.SourceConstantAlpha := 255;
BF.AlphaFormat := AC_SRC_ALPHA;
Winapi.Windows.AlphaBlend(Canvas.Handle, 0, 0, Buff.Width, Buff.Height,
Buff.Canvas.Handle, 0, 0, Buff.Width, Buff.Height, BF);
end;
Or convert your TBitmap32 to a Delphi TBitmap and paint that using the VCL:
procedure TForm1.FormPaint(Sender: TObject);
var
Bmp: TBitmap;
I: Integer;
begin
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32bit;
Bmp.AlphaFormat := afDefined;
Bmp.SetSize(Buff.Width, Buff.Height);
for I := 0 to Buff.Height - 1 do
Move(Buff.ScanLine[I]^, Bmp.ScanLine[I]^, Buff.Width * 4);
Canvas.Draw(0, 0, Bmp);
finally
Bmp.Free;
end;
end;
Could an TGPImage be loaded from PNG file or resource
himg := TGPImage.Create('heading.png');
and then be modified by painting on it like using canvas?
Or, better to say, I would like to paint a background using programmatic methods and then load an image from PNG above my painting in order to operate with this merged image as one solid TGPImage.
I looked at methods and properties of TGPImage and didn't find painting instruments.
Could I probably do this using TBitmap?
Following does not work:
_hbm := TBitmap.Create();
_hbm.Width := 1000;
_hbm.Height := 1000;
_hbm.Canvas.Brush.Color := clBlack;
_hbm.Canvas.Pen.Color := clBlack;
_hbm.Canvas.FillRect(Rect(0, 0, 1000, 1000));
_hgb := TGPBitmap.Create(_hbm.Handle);
....................
GPGraphics.DrawImage(_hgb, 0, 0, _hgb.GetWidth(), _hgb.GetHeight());
You don't need a TBitmap for that.
You simply need to use a TGPGraphics associated with the TGPImage to draw on the TGPImage surface.
Here is a very simple example:
uses GDIPOBJ, GDIPAPI, GDIPUTIL;
procedure TForm1.Button1Click(Sender: TObject);
var
b: TGPBitmap;
g: TGPGraphics;
pen: TGPPen;
encoderClsid: TGUID;
begin
b := TGPBitmap.Create('D:\in.png');
try
g := TGPGraphics.Create(b);
try
pen := TGPPen.Create(MakeColor(255, 255, 0), 3);
try
{ Draw a yellow Rectangle }
g.DrawRectangle(pen, MakeRect(0, 0, 200, 200));
GetEncoderClsid('image/png', encoderClsid);
b.Save('D:\out.png', encoderClsid);
finally
pen.Free;
end;
finally
g.Free;
end;
finally
b.Free;
end;
end;
The code below should be creating a bitmap that is a 48x48 rectangle, of blue background color and a Text (actually just a letter) centered horizontally and vertically of white color.
However nothing happens.
procedure MakeCustomIcon(AText: string; AWidth: Integer; AHeight: Integer; AColor: TAlphaColor; var ABlob: TBlob);
var
Bitmap: TBitmap;
Rect: TRectF;
InStream: TMemoryStream;
begin
Bitmap := TBitmap.Create;
InStream := TMemoryStream.Create;
try
Bitmap.SetSize(AWidth, AHeight);
Bitmap.Canvas.Clear(AColor);
Bitmap.Canvas.Stroke.Kind := TBrushKind.bkSolid;
Bitmap.Canvas.StrokeThickness := 1;
Bitmap.Canvas.Fill.Color := TAlphaColorRec.White;
Bitmap.Canvas.BeginScene;
Rect.Create(0, 0, AWidth, AHeight);
Bitmap.Canvas.FillText(Rect, AText, true, 100, [TFillTextFlag.ftRightToLeft], TTextAlign.taCenter, TTextAlign.taCenter);
Bitmap.Canvas.EndScene;
Bitmap.SaveToStream(InStream);
InStream.Position := 0;
ABlob.Clear;
ABlob.LoadFromStream(InStream);
finally
Bitmap.Free;
InStream.Free;
end;
I have tested the rest of my program to make sure the image (that Blob) is actually transporting and getting displayed, and it is doing so. The problem is fully contained on the way it is drawn the bitmap on the method above.
This TBlob is an array of byte.
I am looking to do rectangles like this below, to be used in TListView:
I have prepared a project.
1-) Write Text on TImage
2-) Draw on TImage
3-) Effect to TImage
I Try on XE5
Samples:
procedure ReDraw(Image: TImage);
var
MyRect: TRectF;
begin
if Image.Bitmap.IsEmpty then Exit;
MyRect := TRectF.Create(0, Ozellik.SeritTop, Image.Bitmap.Width, Ozellik.SeritBot);
with Image.Bitmap.Canvas do
begin
BeginScene;
if not Seffaf.IsChecked then
Fill.Color := Ozellik.SeritRenk
else
Fill.Color := TAlphaColorRec.Null;
FillRect(MyRect, 0, 0, [], 1);
Fill.Color := Ozellik.YaziRenk;
if FontCombo.ItemIndex <> -1 then
Font.Family := FontCombo.Items[FontCombo.ItemIndex];
Font.Size := Ozellik.YaziBoyut;
FillText(MyRect,FonYazi.Text.Trim,True,1,[],TTextAlign.taCenter,TTextAlign.taCenter);
EndScene;
end;
Image.Repaint;
end;
http://www.dosya.tc/server32/vHsbaC/CapsYapMasa_st_.rar.html
All canvas drawings must be grouped into a BeginScene/EndScene block. Also, it is recommended to draw within a try-finally block.
So, instead of
Bitmap.Canvas.Clear(AColor);
...
Bitmap.Canvas.BeginScene;
...
Bitmap.Canvas.EndScene;
you should do:
Bitmap.Canvas.BeginScene;
try
Bitmap.Canvas.Clear(AColor);
...
finally
Bitmap.Canvas.EndScene;
end;
-- Regards
How to get screenshot of browser in DCEF3?
I create browser like this without VCL. The TakePicture method will only work if
No debugger is used
If ShowWindow is used
var
info: TCefWindowInfo;
Settings: TCefBrowserSettings;
begin
FillChar(info, SizeOf(info), 0);
info.width := width;
info.height := height;
FillChar(Settings, SizeOf(TCefBrowserSettings), 0);
Settings.Size := SizeOf(TCefBrowserSettings);
GetSettings(Settings);
CefBrowserHostCreateBrowser(#info, FHandler, FDefaultUrl, #settings, nil);
end;
procedure TakePicture(const Browser: ICefBrowser; Height, Width: Integer);
var
DC: HDC;
Bmp : TBitmap;
Handle : HWND;
Rect : trect;
BarHeight : integer;
BarLeft : integer;
begin
Bmp := TBitmap.Create;
Bmp.PixelFormat := pf32bit;
Handle := Browser.Host.WindowHandle;
ShowWindow(handle, SW_RESTORE); // will work only if this is used otherwise black image!
BarLeft := GetSystemMetrics(SM_CXFRAME);
BarHeight := GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME);
GetWindowRect(Handle, Rect);
DC := GetDC(Handle);
Bmp.Width := Rect.Right - Rect.Left;
Bmp.Height := (Rect.Bottom - Rect.Top);
BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, DC, -BarLeft, -BarHeight, SRCCOPY);
ReleaseDC(Handle, DC);
Bmp.SaveToFile('c:\test.bmp');
Bmp.Free;
end;
This is basically off-screen rendering. In the demos folder of DCEF3 you'll find a project 'offscreen'. The code you're looking for is in the OnPaint event of TChromiumOSR. It renders to a TBitmap32, but any bitmap could be made to work. Notice that it has been optimized to only paint the so-called "dirty" areas (those that have changed since last painting), but if you're making a screenshot, that's not what you want. In my check-out of the repository there's a line commented out showing the naive case of just painting everything:
SomeBitmap.SetSize(width, height);
Move(buffer^, SomeBitmap32.Bits^, width * height * 4);
It's my best guess that the magic number 4 represents 4 bytes (32-bits).
I warmly recommend using Graphics32 but it you have to use a regular TBitmap, I'll leave it up to you to work out how to turn the array of bits into pixels. Be warmed it will probably be a lot slower.
I would like to convert a TBitMap to a PBitMap in KOL.
I tried this but I get a black picture as an output:
function TbitMapToPBitMap (bitmap : TBitMap) : PbitMap;
begin
result := NIL;
if Assigned(bitmap) then begin
result := NewBitmap(bitmap.Width, bitmap.Height);
result.Draw(bitmap.Canvas.Handle, bitmap.Width, bitmap.Height);
end;
end;
Any idea what's wrong with it? I am using Delphi7.
Thank you for your help.
EDIT: New CODE:
function TbitMapToPBitMap (const src : TBitMap; var dest : PBitMap) : Bool;
begin
result := false;
if (( Assigned(src) ) and ( Assigned (dest) )) then begin
dest.Draw(src.Canvas.Handle, src.Width, src.Height);
result := true;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TBitMapTest : TBitMap;
PBitMapTest : PBitMap;
begin
TBitMapTest := TBitMap.Create;
TBitMapTest.LoadFromFile ('C:\test.bmp');
PBitMapTest := NewBitMap (TBitMapTest.Width, TBitMapTest.Height);
TbitMapToPBitMap (TBitMapTest, PBitMapTest);
PBitMapTest.SaveToFile ('C:\test2.bmp');
PBitMapTest.Free;
TBitMapTest.Free;
end;
To answer your question why are your target images black; it's because you were drawing those target images to source and black they were because the NewBitmap initializes images to black.
How to copy or convert if you want a TBitmap to KOL PBitmap I found only one way (maybe I missed such function in KOL, but even if so, the method used in the following code is very efficient). You can use the Windows GDI function for bit-block transfer, the BitBlt, which just copies the specified area from one canvas to another.
The following code, when you click on the button creates the VCL and KOL bitmap instances, loads the image to a VCL bitmap, call the VCL to KOL bitmap copy function and if this function succeed, draw the KOL bitmap to the form canvas and free both bitmap instances:
uses
Graphics, KOL;
function CopyBitmapToKOL(Source: Graphics.TBitmap; Target: PBitmap): Boolean;
begin
Result := False;
if Assigned(Source) and Assigned(Target) then
begin
Result := BitBlt(Target.Canvas.Handle, 0, 0, Source.Width, Source.Height,
Source.Canvas.Handle, 0, 0, SRCCOPY);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
KOLBitmap: PBitmap;
VCLBitmap: Graphics.TBitmap;
begin
VCLBitmap := Graphics.TBitmap.Create;
try
VCLBitmap.LoadFromFile('d:\CGLIn.bmp');
KOLBitmap := NewBitmap(VCLBitmap.Width, VCLBitmap.Height);
try
if CopyBitmapToKOL(VCLBitmap, KOLBitmap) then
KOLBitmap.Draw(Canvas.Handle, 0, 0);
finally
KOLBitmap.Free;
end;
finally
VCLBitmap.Free;
end;
end;