My application uses standard TComboBoxes and also TButtonedEdits to produce controls with more complex drop-down panels. I would like the two controls to look the same. In particular, I would like image on my TButtonedEdits to be identical to the image on the TComboBoxes regardless of which current or future operating system the program is run on (that is, assuming that this image is determined by the operating system and not be Delphi).
I assume that I will have to install, at runtime, the resource providing the image to TComboBox into a TImageList to make it available to my TButtonedEdits. How do I locate and extract that resource?
You can use the theme engine to draw the button yourself - try something like this for starters:
uses
Themes;
procedure DrawComboBoxButton(ACanvas: TCanvas; ADown, AMouseInControl: Boolean; const ARect: TRect);
var
ComboElem: TThemedComboBox;
Details: TThemedElementDetails;
begin
if ThemeServices.ThemesEnabled then
begin
if ADown then
ComboElem := tcDropDownButtonPressed
else if AMouseInControl then
ComboElem := tcDropDownButtonHot
else
ComboElem := tcDropDownButtonNormal;
Details := ThemeServices.GetElementDetails(ComboElem);
ThemeServices.DrawElement(ACanvas.Handle, Details, ARect);
end
else
begin
if ADown then
DrawFrameControl(ACanvas.Handle, ARect, DFC_SCROLL, DFCS_SCROLLCOMBOBOX or DFCS_PUSHED)
else
DrawFrameControl(ACanvas.Handle, ARect, DFC_SCROLL, DFCS_SCROLLCOMBOBOX);
end;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
DrawComboBoxButton(PaintBox1.Canvas, False, False, Bounds(0, 0, 20, 20));
DrawComboBoxButton(PaintBox1.Canvas, True, False, Bounds(20, 0, 20, 20));
end;
(adapted from the thread "Windows themes in combobox" in the Embarcadero forums).
Mike Lischke's "Windows XP Theme Explorer" can help you to find the right "Elements" and "Details". And have a look at this SO thread.
Related
Some background info. I work at a very small company who has recently upgraded Delphi from version 6 (!!!) to Rad Studio XE5 and things have certainly changed a lot in 10+ years. Most things seems to have been improved in the IDE and framework, but we're having big problems with the new VCL Styles feature. It's just very buggy and not up to par with the quality we were used to from Borland back in the day. We have done lots of tweaks and work arounds to get things working but one issue is really bugging me at the moment and it has to do with the preview form in FastReport 4.
The toolbar gets a white border around it.
Controls in the print dialog and others are misaligned or wrongly positioned
We really want to use VCL Styles to give our software a new fresh look, so we hope there is a solution to these problems.
Steps to reproduce the issues:
Create a new VCL Forms Application
Check a VCL Style in Project > Options > Application > Appearance, e.g. Sapphire Kamri.
Add a TfrxReport report Component to the form
Double click the component frxReport1 and add a Page Header band just to have some content
Add a TButton and in OnClick event, call frxReport1.ShowReport();
Run the program and click on the button. In the preview form you now see that the toolbar is surrounded by a white border which looks weird.
Click the leftmost print button to bring up the print dialog and you can see how the group boxes and cancel button is positioned outside of the client area.
Do you have any solutions or suggestions to solve the issues?
Edit: RRUZ gave a good answer, but there were some side effects to his solution to problem #1 so I decided to simplify the code and just paint the border around the toolbar manually. Like this:
procedure TToolBarStyleHookEx.PaintNC(Canvas: TCanvas);
begin
if TToolBar(Control).BorderWidth>0 then
begin
Canvas.Pen.Width := 4;
Canvas.Pen.Color := StyleServices.GetStyleColor(scWindow);
Canvas.Brush.Style := bsClear;
Canvas.Rectangle(2,2,Control.Width-2,Control.Height-1);
end;
inherited;
end;
Effectively both issues it seems VCL Styles bugs.
1) Q: The toolbar gets a white border around it.
A: The TToolBarStyleHook Style hook in not handling the BorderWidth property. so you must create a new style hook and override the PaintNC to overcome this issue.
type
TToolBarStyleHookEx = class(TToolBarStyleHook)
protected
procedure PaintNC(Canvas: TCanvas); override;
end;
{ TToolBarStyleHookEx }
procedure TToolBarStyleHookEx.PaintNC(Canvas: TCanvas);
var
Details: TThemedElementDetails;
LStyle: TCustomStyleServices;
R: TRect;
begin
if TToolBar(Control).BorderWidth>0 then
begin
LStyle := StyleServices;
R := Rect(0, 0, Control.Width, Control.Height);
Details.Element := teToolBar;
Details.Part := 0;
Details.State := 0;
if LStyle.HasTransparentParts(Details) then
LStyle.DrawParentBackground(Handle, Canvas.Handle, Details, False);
LStyle.DrawElement(Canvas.Handle, Details, R);
end;
inherited;
end;
and register like so
initialization
TCustomStyleEngine.RegisterStyleHook(TToolBar, TToolBarStyleHookEx);
2) Q : Controls in the print dialog and others are misaligned or wrongly positioned
A: It seems a issue related with the TFormStyleHook, you had 3 alternatives.
1) you can edit the frxPrintDialog unit and increase the width of the form.
2) you can patch the form style hook.
3) You can change the width of the print dialog in run-time.
Check this code which changes the width of the dialog in run-time using a HCBT_ACTIVATE hook
var
hhk: HHOOK;
function CBT_FUNC(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
const
ClassNameBufferSize = 1024;
var
hWindow: HWND;
RetVal : Integer;
ClassNameBuffer: Array[0..ClassNameBufferSize-1] of Char;
i : integer;
begin
Result := CallNextHookEx(hhk, nCode, wParam, lParam);
if nCode<0 then exit;
case nCode of
HCBT_ACTIVATE:
begin
hWindow := HWND(wParam);
if (hWindow>0) then
begin
RetVal := GetClassName(wParam, ClassNameBuffer, SizeOf(ClassNameBuffer));
if (RetVal>0) and SameText(ClassNameBuffer, 'TfrxPrintDialog') then
for i:= 0 to Screen.FormCount-1 do
if (SameText(Screen.Forms[i].ClassName, 'TfrxPrintDialog')) and (Screen.Forms[i].Width<=563) then
Screen.Forms[i].Width:=Screen.Forms[i].Width+8;
end;
end;
end;
end;
Procedure InitHook();
var
dwThreadID : DWORD;
begin
dwThreadID := GetCurrentThreadId;
hhk := SetWindowsHookEx(WH_CBT, #CBT_FUNC, hInstance, dwThreadID);
if hhk=0 then RaiseLastOSError;
end;
Procedure KillHook();
begin
if (hhk <> 0) then
UnhookWindowsHookEx(hhk);
end;
initialization
InitHook();
finalization
KillHook();
After of apply both fixes this will be the result
Note: please report these issues to the QC page of Embarcadero.
Although I realise that in addition to the included Delphi docking demo there are other and better docking libraries available such as the Developer Express Library and the JVCL Docking Library, but for a specific demonstration project I am restricted to use only the Delphi built-in capability (despite some of the noted flaws).
My question relates to adding persistence to the docking state. I see from examining Controls.pas that TDockTree is the default dock manager and it has Stream I/O routines. Digging around on SO and in various forums though I cant see how anyone has called these routines. I've tried loading and saving to a file from the relevant Create and OnDrop events but I'm stabbing in the dark. I am happy saving and restoring form sizes and states but am struggling with the concepts of what I should be saving. Would any kind person give me a starting place?
I'm using Delphi XE3, so all (?) things are possible!
Many thanks.
I'm using Toolbar 2000 from J. Russels. It is providing panels, toolwindow's and toolbar's.
That one provides functions like TBRegSavePositions and TBRegSavePositions to store the user customization into registry.
Loading a "view" get's easily done by on code line:
TBRegLoadPositions(self, HKEY_CURRENT_USER, c_BaseUserRegKey);
in this case self is my form.
You can load and save your docking configuration with the LoadFromStream and SaveToStream methods by storing the data in a string.
Therefore, the following methods are required:
save the current docking configuration to a string
load the current docking configuration from a string
Here is some code to do this:
function GetDockString(const AManager: IDockManager): AnsiString;
var
LStream: TMemoryStream;
begin
LStream := TMemoryStream.Create();
try
AManager.SaveToStream(LStream);
SetLength(Result, 2 * LStream.Size);
BinToHex(LStream.Memory, PAnsiChar(Result), LStream.Size);
finally
FreeAndNil(LStream);
end;
end;
procedure ReadDockString(const ADockString: AnsiString; const AManager: IDockManager);
var
LStream: TMemoryStream;
begin
LStream := TMemoryStream.Create();
try
LStream.Size := Length(ADockString) div 2;
HexToBin(PAnsiChar(ADockString), LStream.Memory, LStream.Size);
LStream.Position := 0;
AManager.LoadFromStream(LStream);
finally
FreeAndNil(LStream);
end;
end;
I've used such methods in an application to create dockable windows, but the vcl provides only a very basic user experience. You can do something about it, but it is hard to test and debug - I already spent too much time to use and override TCustDockDragObject and TCaptionedTabDockTree, so I would recommend using a docking framework.
Here is a minimal example which creates two forms and reads a docking configuration.
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDblClick(Sender: TObject);
private
FPanel: TPanel;
end;
Implementation:
procedure TForm1.FormCreate(Sender: TObject);
var
LWindow: TForm;
const
LDockExample = '0000080000000000000000000000000000000000000000000000000100000000000000000B0000004368696C6457696E646F77FFFFFFFF';
begin
FPanel := TPanel.Create(Self);
FPanel.Align := alTop;
FPanel.Height := 300;
FPanel.DockSite := true;
FPanel.Parent := Self;
LWindow := TForm.CreateNew(Self);
LWindow.Name := 'ChildWindow';
LWindow.DragKind := dkDock;
LWindow.BoundsRect:=Rect(10, 10, 400, 400);
LWindow.Color := clGreen;
LWindow.Show;
ReadDockString(LDockExample, FPanel.DockManager);
end;
procedure TForm1.FormDblClick(Sender: TObject);
begin
ShowMessage(GetDockString(FPanel.DockManager));
end;
I'm using this code to remove the vcl styles from the non client area of a form.
type
TFormStyleHookNC= class(TMouseTrackControlStyleHook)
protected
procedure PaintBackground(Canvas: TCanvas); override;
constructor Create(AControl: TWinControl); override;
end;
constructor TFormStyleHookNC.Create(AControl: TWinControl);
begin
inherited;
OverrideEraseBkgnd := True;
end;
procedure TFormStyleHookNC.PaintBackground(Canvas: TCanvas);
var
Details: TThemedElementDetails;
R: TRect;
begin
if StyleServices.Available then
begin
Details.Element := teWindow;
Details.Part := 0;
R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight);
StyleServices.DrawElement(Canvas.Handle, Details, R);
end;
end;
initialization
TStyleManager.Engine.RegisterStyleHook(TForm3, TFormStyleHookNC);
Before to apply this style hook the form looks like
and after
As you can see the menu disappears, The question is : how I can fix this? I mean how i can remove the vcl styles from the non client area of a form without remove the TMainMenu?
When you uses the vcl styles, the TMain menu is drawn by the TMainMenuBarStyleHook vcl style hook, which is defined inside of the TFormStyleHook (the hook of the forms), in this case because you are not using this hook there is not code to draw the TMainMenu.
Two possible solutions are
1) Implement the vcl style hook for the TMainMenu inside of the TFormStyleHookNC , just like the TFormStyleHook does.
2)or even better use a TActionMainMenuBar component instead of a TMainMenu, this component is very well integrated with the vcl styles (check the next sample image).
I know you can use SetWindowTheme found in uxTheme.pas to disable/enable the theming on controls, like this for example:
SetWindowTheme(Button1.Handle, nil, nil);
This works on quite a few of the controls, however it will not work on some controls such as TBitBtn or TSpeedButton. I think this must be because TBitBtn and TSpeedButton are not Windows controls, but custom ones?
There may well be other controls that also won't work, so I was hoping someone could share a solution or alternative to achieve this?
I want some of the controls to have no theming at all, eg they will show as classic themed whilst the rest of the controls will not be affected.
Thanks.
Your analysis is correct. SetWindowTheme works for window controls but TSpeedButton and TBitBtn are non-winowed controls.
In XE, from my quick scan, it seems that most controls call Themes.ThemeControl to determine whether or not to draw themed. So the simple solution is to replace that routine with logic that you control. Since it does not provide any extension points, you need to hook it. Like this:
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
function MyThemeControl(AControl: TControl): Boolean;
begin
Result := False;
if AControl = nil then exit;
if AControl is TSpeedButton then exit;
if AControl is TBitBtn then exit;
Result := (not (csDesigning in AControl.ComponentState) and ThemeServices.ThemesEnabled) or
((csDesigning in AControl.ComponentState) and (AControl.Parent <> nil) and
(ThemeServices.ThemesEnabled and not UnthemedDesigner(AControl.Parent)));
end;
initialization
RedirectProcedure(#Themes.ThemeControl, #MyThemeControl);
As it stands, this will not work with runtime packages, but it's easy enough to extend the code to work with packages.
If you look at the source code for TBitBtn (in particular, TBitBtn.DrawItem), you see that it is drawn manually in the Delphi source code. It uses the Windows visual themes API to draw the button (ThemeServices.Draw*) in the current theme, if themes are enabled. If not, it uses the old-style Windows API functions to draw controls, such as Rectangle and DrawFrameControl. I think you have to alter the source code of the control in order to circumvent this behaviour.
I can enumerate the applications (handle,pid,path) with icons in the notification area, and I can control the position of the icons, but I can't get the tooltip.
How can I enumerate systray icons including the tooltips?
The shell provides no facility for inspecting notification icons that don't belong to your program. (And it provides no way of enumerating even the icons that do belong to your program; you're expected to already know about those.)
I used to use a program that hijacked some or all of the icons and optionally displayed them in its own window instead of in the area near the clock, so it must have been able to get a list of all the icons. It was TraySaver, by Mike Lin. The source is available if you wish to see how his hack worked.
You can also take a look at the answers to a previous question that asked about controlling the position of icons in the notification area.
You should take a look at the madKernal package of madshis component collection. It has some interfaces for working with trayicons. Beware, though:
With madKernel you can manage tray icons (see API "Shell_NotifyIcon") of any application. This kind of functionality is totally undocumented, but works well from win95 to winXP.
The ITrayIcon-interface has properties for hint, icon, position and more.
Here is my method tested with windows xp and delphi 2010 if you are using a version of delphi wich doesn't support unicode make shure you convert the strings read to ansi
uses CommCtrl;
function TForm1.GetIconsCount: Integer;
begin
Result := SendMessage(FindTrayToolbar, TB_BUTTONCOUNT, 0, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListTips;
end;
function TForm1.FindTrayToolbar: HWND;
begin
Result := FindWindow('Shell_TrayWND', nil);
Result := FindWindowEx(Result, 0, 'TrayNotifyWnd', nil);
Result := FindWindowEx(Result, 0, 'SysPager', nil);
Result := FindWindowEx(Result, 0, 'ToolbarWindow32', nil);
end;
procedure TForm1.ListTips;
var
dwTray: DWORD;
wndTray: HWND;
hTray: THandle;
remoteTray: Pointer;
tdata: TTBBUTTON;
i: Integer;
btsread:DWORD;
str:Pchar;
begin
wndTray := FindTrayToolbar;
GetWindowThreadProcessId(wndTray, #dwTray);
hTray := OpenProcess(PROCESS_ALL_ACCESS, false, dwTray);
if hTray <> 0 then
begin
remoteTray := VirtualAllocEx(hTray, nil, Sizeof(tdata), MEM_COMMIT,
PAGE_READWRITE);
for i := 0 to GetIconsCount - 1 do
begin
SendMessage(FindTrayToolbar,TB_GETBUTTON,wparam(i),lparam(remotetray));
ReadProcessMemory(hTray,remotetray,#tdata,sizeof(tdata),btsread);
GetMem(str,255);
ReadProcessMemory(hTray,Ptr(tdata.iString),str,255,btsread);
ListBox1.Items.Add(str);
end;
end
else ShowMessage('Could not locate tray icons');
end;
end.