Colors of the TDialogService.MessageDialog - delphi

Can you explain how I can get used colors of the TDialogService.MessageDialog window?
Update: Which created using this command:
TDialogService.MessageDialog('Test3: Confirmation', MsgDlgType.mtConfirmation,
[TMsgDlgBtn.mbOK], TMsgDlgBtn.mbOK, 0,
procedure(const AResult: TModalResult)
begin
end);
I need color of the bottom panel (Button parent) and background color of the message. I need this color to make my own dialog looks like FMX default dialog.
Currently I have my own highly customizable dialog which looks like this:
And also where I can get icons which used in TDialogService.MessageDialog window?

Thanks to the answer of David Heffernan and Triber:
procedure GetThemeBackgroud(AImage: TImage; ATheme: HTHEME; APartID: Integer);
var
stream: TMemoryStream;
bitmap: Vcl.Graphics.TBitmap;
begin
bitmap := Vcl.Graphics.TBitmap.Create;
try
bitmap.Width := Round(AImage.Width);
bitmap.Height := Round(AImage.Height);
DrawThemeBackground(ATheme, bitmap.Canvas.Handle, APartID, 0,
Rect(0, 0, bitmap.Width, bitmap.Height), nil);
stream := TMemoryStream.Create;
try
bitmap.SaveToStream(stream);
AImage.Bitmap.LoadFromStream(stream);
finally
stream.Free;
end;
finally
bitmap.Free;
end;
end;
procedure GetThemeBackgroud;
var
theme: HTHEME;
begin
theme := OpenThemeData(0, 'TASKDIALOG');
if theme <> 0 then
try
// Client color
GetThemeBackgroud(imgClient, theme, TDLG_PRIMARYPANEL);
// Bottom color
GetThemeBackgroud(imgBottom, theme, TDLG_SECONDARYPANEL);
finally
CloseThemeData(theme);
end;
end;
Here we should to add 2 TImages: client and buttons parents:
Now I should investigate of the system icons loading

Related

Delphi - change ribbon menu color when VCL theme is applied

I'm using TRibbon on an Delphi XE7 application with VCL theme applied and I'd like to change the menu color (because it's difficult to see the items in dark themes), as following:
I've tried the following code, but it only works when style is disabled:
Ribbon1.ApplicationMenu.Menu.ColorMap.MenuColor:= clYellow;
Also no effect with this line:
Ribbon1.ApplicationMenu.Menu.ColorMap.MenuColor:= StyleServices.GetStyleColor(scButtonHot);
Does anyone know if it is possible?
Thanks a lot!
Create your own style with the color you like.
After some try, I found a solution. I don't know if it's the best approach, but it worked for me and could be useful for someone else.
The problem is the method bellow (Vcl.ActnMenus.pas), when StyleServices is enabled:
procedure TCustomActionPopupMenu.DrawBackground;
begin
inherited;
if StyleServices.Enabled and not StyleServices.IsSystemStyle then
StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tmPopupBackground),
Rect(0, 0, Width, Height))
else
begin
Canvas.Brush.Color := ColorMap.MenuColor;
Canvas.FillRect(ClientRect);
end;
end;
So, in order to bypass this method, I just hooked it (adapting from here):
unit MethodHooker;
interface
uses Windows, Vcl.ActnMenus;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
TCustomActionPopupMenu = class(Vcl.ActnMenus.TCustomActionPopupMenu)
procedure DrawBackgroundEx;
end;
implementation
procedure Patch(Address: Pointer; const NewCode; Size: NativeUInt);
var
NumberOfBytes: NativeUInt;
begin
WriteProcessMemory(GetCurrentProcess, Address, #NewCode, Size, NumberOfBytes);
end;
procedure Redirect(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := Integer(NewAddress)-Integer(OldAddress)-SizeOf(NewCode);
Patch(OldAddress, NewCode, SizeOf(NewCode));
end;
{ TCustomActionPopupMenu }
procedure TCustomActionPopupMenu.DrawBackgroundEx;
begin
Canvas.Brush.Color := $00EEEAE9;
Canvas.FillRect(ClientRect);
end;
initialization
Redirect(#TCustomActionPopupMenu.DrawBackground, #TCustomActionPopupMenu.DrawBackgroundEx);
end.
That's it. Just save this unit and add it to the project. No need to call this anywhere.

Drawing on FMX canvas with WinApi functions

This question looks very simple, with VCL this is works fine (Image is TImage on VCL):
procedure TFormMain.btnDrawBackgroundClick(Sender: TObject);
var
theme: HTHEME;
begin
theme := OpenThemeData(0, 'TASKDIALOG');
if theme <> 0 then
try
DrawThemeBackground(theme,
Image.Canvas.Handle,
TDLG_SECONDARYPANEL,
0,
Image.ClientRect,
nil);
finally
CloseThemeData(theme);
end;
end;
Question: what I should change to get the same effect with FMX (on Windows)
Based on this answer you simply can't do that.
The problem is that with Firemonkey, you only have a single device
context for the form and not one for each component. When a component
needs to be redrawn, it gets passed the forms canvas but with clipping
and co-ordinates mapped to the components location.
But there is always some workaround and you can try something like this.
procedure TFormMain.btnDrawBackgroundClick(Sender: TObject);
var
lTheme : HTHEME;
lStream : TMemoryStream;
lBitmap : Vcl.Graphics.TBitmap;
begin
lTheme := OpenThemeData(0, 'TASKDIALOG');
if lTheme <> 0 then
try
lBitmap := Vcl.Graphics.TBitmap.Create;
try
lBitmap.Width := Round(Image.Width);
lBitmap.Height := Round(Image.Height);
DrawThemeBackground(lTheme, lBitmap.Canvas.Handle, TDLG_SECONDARYPANEL, 0,
Rect(0, 0, lBitmap.Width, lBitmap.Height), nil);
lStream := TMemoryStream.Create;
try
lBitmap.SaveToStream(lStream);
Image.Bitmap.LoadFromStream(lStream);
finally
lStream.Free;
end;
finally
lBitmap.Free;
end;
finally
CloseThemeData(lTheme);
end;
end;

How to draw a solid color bitmap with a Text Centered?

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

painting background from TSeStyleFont

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;

How to get a image of a panel with a combobox

I need to capture an image of panel.
The problem I am running into is that if the Panel contains a TCombobox the Text does not appear.
procedure AssignPanelImageToPicture(Panel : TPanel;Image : TImage);
var
B : TBitmap;
begin
B := TBitmap.Create;
try
B.Width := Panel.Width;
B.Height := Panel.Height;
B.Canvas.Lock;
Panel.PaintTo(B.Canvas.Handle,0,0);
B.Canvas.Unlock;
Image1.Picture.Assign(B);
finally
B.Free;
end;
end;
Using this code, I drop a panel with a TCombobox on it. Then Enter a value into the Text Property. I also drop a TImage Next two it. Then I add a button to call the above
code.
Here is the result:
Is there a better way to capture a true image of the panel.
What about using the GetDC and BitBlt functions?
procedure AssignPanelImageToPicture(Panel : TPanel;Image : TImage);
var
B : TBitmap;
SrcDC: HDC;
begin
B := TBitmap.Create;
try
B.Width := Panel.Width;
B.Height := Panel.Height;
SrcDC := GetDC(Panel.Handle);
try
BitBlt(B.Canvas.Handle, 0, 0, Panel.ClientWidth, Panel.ClientHeight, SrcDC, 0, 0, SRCCOPY);
finally
ReleaseDC(Panel.Handle, SrcDC);
end;
Image.Picture.Assign(B);
finally
B.Free;
end;
end;

Resources