If you are using one of my projects, please go to this page

Delphi Vcl Styles and TWebBrowser, source code released.

March 20, 2012 8 comments

First I want to thank you, for the great feedback of my last post, all your comments and issue reports were very useful.

Motivation

While I was working on my favorite personal project I realised which the TWebBrowser embedded in one of my forms doesn’t look very nice when the vcl styles are enabled. So I decide write a fix.

My main goal was skin the scrollbars of the TWebBrowser component which by default uses the native windows look and feel.

This task involve many challenges like determine which WebBrowser events modify the position and visibility of the scrollbars, get the bounds of the original scrollbars, paint the skinned scrollbars, scroll the WebBrowser control, and so on. So I will try to explain briefly how was done.

The work begin

The first task was hook the TWebBrowser component to check which events and windows messages of the TWebBrowser modify the scrollbars visibility and position. So after of write a little helper application to do this, was determined that the events are :

  • OnDocumentComplete
  • OnNavigateComplete2
  • OnBeforeNavigate2
  • OnCommandStateChange
  • OnProgressChange

And also the WMSIZE message.

The events

In order to intercept these TWebbrowser events we can’t assign a event handler directly because these will not be fired if the same events are assigned by the user. So the solution was override the InvokeEvent method which is part of the TOleControl control (and which is the parent class of the TWebbrowser component).

Here’s how it looks the overridden InvokeEvent method

procedure TVclStylesWebBrowser.InvokeEvent(DispID: TDispID; var Params: TDispParams);
var
  ArgCount  : Integer;
  LVarArray : Array of OleVariant;
  LIndex    : Integer;
begin
  inherited; //call the original implementation of InvokeEvent
  ArgCount := Params.cArgs;
  SetLength(LVarArray, ArgCount);
  //store the paramaters in an variant array for an more easy access to the values
  for LIndex := Low(LVarArray) to High(LVarArray) do
    LVarArray[High(LVarArray)-LIndex] := OleVariant(TDispParams(Params).rgvarg^[LIndex]);

  //call the private impkemenation of each event
  case DispID of
    252: DoNavigateComplete2(Self,
                              LVarArray[0] {const IDispatch},
                              LVarArray[1] {const OleVariant});

    259: DoDocumentComplete(Self,
                             LVarArray[0] {const IDispatch},
                             LVarArray[1] {const OleVariant});

    250: DoBeforeNavigate2(Self,
                            LVarArray[0] {const IDispatch},
                            LVarArray[1] {const OleVariant},
                            LVarArray[2] {const OleVariant},
                            LVarArray[3] {const OleVariant},
                            LVarArray[4] {const OleVariant},
                            LVarArray[5] {const OleVariant},
                            WordBool((TVarData(LVarArray[6]).VPointer)^) {var WordBool});

    105:DoCommandStateChange(Self,
                               LVarArray[0] {Integer},
                               LVarArray[1] {WordBool});

    108:DoProgressChange(Self,
                           LVarArray[0] {Integer},
                           LVarArray[1] {Integer});

  end;

  SetLength(LVarArray, 0);
end;

Additionally each local event implementation call the ResizeScrollBars method to change the visibility of the scrollbars and calculate the current position 

procedure TVclStylesWebBrowser.DoBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
begin
  ResizeScrollBars;
end;

procedure TVclStylesWebBrowser.DoProgressChange(Sender: TObject; Progress,ProgressMax: Integer);
begin
  ResizeScrollBars;
end;

procedure TVclStylesWebBrowser.DoDocumentComplete(Sender: TObject;const pDisp: IDispatch; const URL: OleVariant);
begin
  ResizeScrollBars;
end;

procedure TVclStylesWebBrowser.DoNavigateComplete2(Sender: TObject;const pDisp:IDispatch;const URL: OleVariant);
begin
  ResizeScrollBars;
end;

Also we need to call the same method when the WM_SIZE message arrives.

procedure TVclStylesWebBrowser.WMSIZE(var Message: TWMSIZE);
begin
  inherited;
  ResizeScrollBars;
end;

The Scrollbars

After of that we need to paint the new Scrollbars using two TScrollBar components (Horizontal and Vertical), these controls are not draw directly over the Twebbrowser canvas rather, they are painted over a TWinControl which is a container for these controls, this container overlaps the original (native) scrollbars, also we need implement WMEraseBkgnd message to use the vcl styles color to fill the background of the container.

This is the definition of the private TWinContainer class.

  TVclStylesWebBrowser = class(SHDocVw.TWebBrowser, IDocHostUIHandler, IDocHostShowUI, IOleCommandTarget)
  strict private
    type
      TWinContainer = class(TWinControl)
        procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
      end;

This is the implementation of the WMEraseBkgnd message

procedure TVclStylesWebBrowser.TWinContainer.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
var
  Details: TThemedElementDetails;
  LCanvas: TCanvas;
begin
  LCanvas := TCanvas.Create;
  try
    LCanvas.Handle := Msg.DC;
    Details.Element := teWindow;
    Details.Part := 0;
    StyleServices.DrawElement(LCanvas.Handle, Details, ClientRect);
  finally
    LCanvas.Free;
  end;
end;

And this is the code of how the TScrollBar components are created

constructor TVclStylesWebBrowser.Create(AOwner: TComponent);
begin
  inherited;
  //Get the scrollbars sizes
  LSM_CXHTHUMB:=GetSystemMetrics(SM_CXHTHUMB);
  LSM_CYVTHUMB:=GetSystemMetrics(SM_CYVTHUMB);
  
  //set the containers to nil
  VScrollBarContainer := nil;
  HScrollBarContainer := nil;

  //create the containers
  ScrollCornerContainer := TWinContainer.Create(Self);
  ScrollCornerContainer.Visible := False;
   
  //create the vertical scroll bar
  VScrollBarContainer := TWinContainer.Create(Self);
  VScrollBarContainer.Visible := True;
  VScrollBar := TScrollBar.Create(Self);
  VScrollBar.Parent   := VScrollBarContainer;
  VScrollBar.Kind     := sbVertical;
  VScrollBar.Visible  := True;
  VScrollBar.Align    := alClient;
  VScrollBar.OnChange := VScrollChange;
  VScrollBar.Enabled  := False;

  //create the horizontal scroll bar
  HScrollBarContainer := TWinContainer.Create(Self);
  HScrollBarContainer.Visible := False;
  HScrollBar := TScrollBar.Create(Self);
  HScrollBar.Parent   := HScrollBarContainer;
  HScrollBar.Visible  := True;
  HScrollBar.Align    := alClient;
  HScrollBar.OnChange := HScrollChange;
end;

As final step of this stage we need handle CM_VISIBLECHANGED message to hide or show the new scrollbars.

procedure TVclStylesWebBrowser.CMVisibleChanged(var MSg: TMessage);
begin
  inherited ;
  VScrollBarContainer.Visible   := Self.Visible;
  HScrollBarContainer.Visible   := Self.Visible;
  ScrollCornerContainer.Visible := Self.Visible;
end;

The ResizeScrollBars method

As you see in some of the above code a call to the ResizeScrollBars method is made, well this is one of the key points of the TVclStylesWebBrowser class, this method change the visibility , recalculate the sizes of the scrollbars and scroll the TWebBrowser.

Take a look to the method implementation

procedure TVclStylesWebBrowser.ResizeScrollBars;
var
  StateVisible   : Boolean;
  DocClientWidth : Integer;
  ScrollWidth    : Integer;
  ScrollHeight   : Integer;
  HPageSize      : Integer;
  VPageSize      : Integer;
  LRect          : TRect;
  IEHWND         : WinApi.Windows.HWND;
begin
  IEHWND:=GetIEHandle;
  //some safety checks before to continue
  if (IEHWND=0) or (VScrollBarContainer = nil) or (HScrollBarContainer = nil) then Exit;

  if not VScrollBarContainer.Visible then
   VScrollBarContainer.Visible := True;

  //the loaded page has body?
  if (Document <> nil) and (IHtmldocument2(Document).Body <> nil) then
   begin
     //get the client width
     DocClientWidth := OleVariant(Document).documentElement.ClientWidth;
     //if the docuemnt has a width larger than 0 
     if (DocClientWidth > 0) then
     begin
       //Get the Scroll Width 
       ScrollWidth:=OleVariant(Document).DocumentElement.scrollWidth;
       if (HScrollBar.Max<>ScrollWidth) and (ScrollWidth>=HScrollBar.PageSize) and (ScrollWidth>=HScrollBar.Min) then
         HScrollBar.Max := ScrollWidth;

       //Get the Scroll Height
       ScrollHeight:=OleVariant(Document).DocumentElement.scrollHeight;
       if (VScrollBar.Max<>ScrollHeight) and (ScrollHeight>=VScrollBar.PageSize) and (ScrollHeight>=VScrollBar.Min) then
         VScrollBar.Max := ScrollHeight;
     end
     else
     //use the body values
     begin
       //Get the Scroll Width        
       ScrollWidth  := IHtmldocument2(Document).Body.getAttribute('ScrollWidth', 0);
       if (HScrollBar.Max<>ScrollWidth) and (ScrollWidth>=HScrollBar.PageSize) and (ScrollWidth>=HScrollBar.Min) then
         HScrollBar.Max := ScrollWidth;

       //Get the Scroll Height
       ScrollHeight:=IHtmldocument2(Document).Body.getAttribute('ScrollHeight', 0);
       if (VScrollBar.Max<>ScrollHeight) and (ScrollHeight>=VScrollBar.PageSize) and (ScrollHeight>=VScrollBar.Min) then
         VScrollBar.Max := ScrollHeight;
     end;

     //Get the height of the page
     if (HScrollBar.Max > Self.Width - LSM_CXHTHUMB) and(HScrollBar.Max > 0) and (HScrollBar.Max <> Self.Width) then
       VPageSize := Self.Height - LSM_CYVTHUMB
     else
       VPageSize := Self.Height;

     //Set the position of the vertical scrollbar
     VScrollBar.PageSize:=VPageSize;
     VScrollBar.SetParams(VScrollBar.Position, 0, VScrollBar.Max);
     VScrollBar.LargeChange := VScrollBar.PageSize;

     //Set the position of the horizontal scrollbar
     HPageSize := Self.Width - LSM_CXHTHUMB;
     HScrollBar.PageSize:=HPageSize;
     HScrollBar.SetParams(HScrollBar.Position, 0, HScrollBar.Max);
     HScrollBar.LargeChange := HScrollBar.PageSize;

     VScrollBar.Enabled := (VPageSize < VScrollBar.Max) and(VScrollBar.PageSize > 0) and (VScrollBar.Max > 0) and (VScrollBar.Max <> Self.Height);

     StateVisible := HScrollBarContainer.Visible;

     //set the visibility of the containers
     if IsWindow(HScrollBarContainer.Handle) then
      HScrollBarContainer.Visible := (HPageSize < HScrollBar.Max) and (HScrollBar.PageSize < HScrollBar.Max) and (HScrollBar.Max > 0) and (HScrollBar.Max <> Self.Width);
     if not StateVisible and HScrollBarContainer.Visible then
       HScrollBarContainer.BringToFront;
   end;
   
   UpdateContainers;
end;

Additional elements

Besides of the scrollbars we need to make small changes to the aspect of the TWebBrowser , for example remove the 3D border, this is made via the IDocHostUIHandler interface and the GetHostInfo function.

function TVclStylesWebBrowser.GetHostInfo(var pInfo: TDocHostUIInfo): HRESULT;
var
  BodyCss   : string;
  ColorHtml : string;
  LColor    : TColor;
begin
  LColor:=StyleServices.GetSystemColor(clWindow);
  ColorHtml:= Format('#%.2x%.2x%.2x',[GetRValue(LColor), GetGValue(LColor), GetBValue(LColor)]) ;
  BodyCss:=Format('BODY {background-color:%s}',[ColorHtml]);

  pInfo.cbSize := SizeOf(pInfo);
  pInfo.dwFlags := 0;
  pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER;//disable 3d border
  pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_THEME;//use themes
  if FUseVClStyleBackGroundColor then
  pInfo.pchHostCss :=PWideChar(BodyCss); //use the vcl styles color as background color (this optional and disabled by default)
  Result := S_OK;
  ResizeScrollBars;
end;

A Final touch

While I was wrote this class I decide add two new options to customize the way how the JScript alert messages and Javascript errors are shown, using the IOleCommandTarget and IDocHostShowUI interfaces.

Implementing the IDocHostShowUI.ShowMessage function you can replace the Windows Internet Explorer message box (which is used for Microsoft JScript alerts among other things).

function TVclStylesWebBrowser.ShowMessage(hwnd: THandle; lpstrText, 
  lpstrCaption: POLESTR; dwType: Integer; lpstrHelpFile: POLESTR;
  dwHelpContext: Integer; var plResult: LRESULT): HRESULT;
var
 DlgType: TMsgDlgType;
 Buttons: TMsgDlgButtons;
begin
  Result := E_NOTIMPL;
  if not FCustomizeStdDialogs then exit;

   DlgType:=mtInformation;
  if ((dwType and MB_ICONMASK)=MB_ICONHAND) or ((dwType and MB_ICONMASK)=MB_USERICON) then
   DlgType:=mtCustom
  else
  if (dwType and MB_ICONMASK)=MB_ICONWARNING then
   DlgType:=mtWarning
  else
  if (dwType and MB_ICONMASK)=MB_ICONQUESTION then
   DlgType:=mtConfirmation
  else
  if (dwType and MB_ICONMASK)=MB_ICONEXCLAMATION then
   DlgType:=mtInformation;

  case dwType and MB_TYPEMASK of
    MB_OK:Buttons:=[mbOK];
    MB_OKCANCEL:Buttons:=[mbOK,mbCancel];
    MB_ABORTRETRYIGNORE:Buttons:=[mbAbort,mbRetry,mbIgnore];
    MB_YESNOCANCEL:Buttons:=[mbYes,mbNo,mbCancel];
    MB_YESNO:Buttons:=[mbYes,mbNo];
    MB_RETRYCANCEL:Buttons:=[mbRetry,mbCancel];
  else
    Buttons:=[mbOK];
  end;

  //use the vcl MessageDlg function to show an skinned message box.
  plResult:= MessageDlg(lpstrText, DlgType, Buttons, dwHelpContext);
  Result := S_OK;
end;

Now to customize the message box which shows the javascript errors we must implement the IOleCommandTarget.Exec function (check this article for more info How to handle script errors as a WebBrowser control host) 

function TVclStylesWebBrowser.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
  const vaIn: OleVariant; var vaOut: OleVariant): HResult;
const
  CGID_DocHostCommandHandler: TGUID = (D1: $F38BC242; D2: $B950; D3: $11D1; D4: ($89, $18, $00, $C0, $4F, $C2, $C8, $36));
var
  LHTMLEventObj : IHTMLEventObj;
  LHTMLWindow2  : IHTMLWindow2;
  LHTMLDocument2: IHTMLDocument2;
  LUnknown      : IUnknown;
  Msg           : string;
  
  function GetPropertyValue(const PropName: WideString): OleVariant;
  var
    LParams    : TDispParams;
    LDispIDs   : Integer;
    Status     : Integer;
    ExcepInfo  : TExcepInfo;
    LName      : PWideChar;
  begin
    ZeroMemory(@LParams, SizeOf(LParams));
    LName := PWideChar(PropName);
    Status := LHTMLEventObj.GetIDsOfNames(GUID_NULL, @LName, 1, LOCALE_SYSTEM_DEFAULT, @LDispIDs);
    if Status = 0 then
    begin
      Status := LHTMLEventObj.Invoke(LDispIDs, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, LParams, @Result, @ExcepInfo, nil);
      if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
    end
    else
    if Status = DISP_E_UNKNOWNNAME then raise EOleError.CreateFmt('Property "%s" is not supported.', [PropName])
    else
      OleCheck(Status);
  end;

begin
 Result:=S_OK;
   if (CmdGroup <> nil) and IsEqualGuid(CmdGroup^, CGID_DocHostCommandHandler) then
     case nCmdID of
        //intercept the JScript error messages
        OLECMDID_SHOWSCRIPTERROR:
        begin
          if not FCustomizeJSErrorDialog then exit;
          LUnknown := IUnknown(TVarData(vaIn).VUnknown);
          //get an interface to the document which raise the message
          if Succeeded(LUnknown.QueryInterface(IID_IHTMLDocument2, LHTMLDocument2)) then
          begin
            LHTMLWindow2   := LHTMLDocument2.Get_parentWindow;
            if LHTMLWindow2<>nil then
            begin
              LHTMLEventObj := LHTMLWindow2.Get_event;
              if LHTMLEventObj <> nil then
              begin
               //buil the message to show
               Msg:='An error has ocurred in the script in this page'+sLineBreak+
                    'Line  %s'+sLineBreak+
                    'Char  %s'+sLineBreak+
                    'Error %s'+sLineBreak+
                    'Code  %s'+sLineBreak+
                    'URL   %s'+sLineBreak+
                    'Do you want to continue running scripts on this page?';               
               Msg:=Format(Msg,[GetPropertyValue('errorline'), GetPropertyValue('errorCharacter'), GetPropertyValue('errorMessage'), GetPropertyValue('errorCode'), GetPropertyValue('errorUrl')]);
               if MessageDlg(Msg,mtWarning,[mbYes, mbNo],0) =mrYes then
                vaOut := True
               else
                vaOut := False;
               Result:=S_OK;
              end;
            end;
          end;
        end;
     else
        Result:=OLECMDERR_E_NOTSUPPORTED;
     end
   else
     Result:=OLECMDERR_E_UNKNOWNGROUP;
end;

Note : In the end of this entry you can find a very useful collection of resources to customize a WebBrowser control.

How it works?

First the class introduced in this article is not a Vcl Style Hook, because exist some technical limitations to accomplish this, among them is the fact that the TWebBrowser control must implement additional interfaces (IDocHostUIHandler, IDocHostShowUI, IOleCommandTarget), so is necesary modify the original TWebBrowser component.

The recommended way to use the TVclStylesWebBrowser class is add the Vcl.Styles.WebBrowser unit to the uses clause is some point after of the SHDocVw unit and then use an interposer class like so :

TWebBrowser=class(TVclStylesWebBrowser);

Finally, How it looks?

Source Code

The full source code of this article is part of the VCL Styles Utils project, you can check the Vcl.Styles.WebBrowser unit here

Recommended resources about WebBrowser Customization

A final words

This is part of an open source project, so feel free to post any issue in the issue page of the project, as well if you want participate improving the code or adding new features, let me now.

Categories: Delphi, Delphi XE2, TWebBrowser, VCL Styles

Vcl Styles and TWebBrowser, Your help is need.

March 16, 2012 5 comments

How you probably know the TWebBrowser doesn’t supports the vcl styles, so two days ago I started to write a fix for the TWebBrowser and the VCL styles

So far i’m getting very good results

But I need to do some additional tests in order to release the code, so your help is need it to try the demo app included in this post. Please let me know about any issue which you can find.

Download the demo application from here.

You can send me your feedback to rodrigo dot ruz dot v at gmail dot com

Categories: Delphi, Delphi XE2, VCL Styles

Vcl Styles and Owner Draw

March 14, 2012 8 comments

The Issue

When you uses the Vcl Styles, you expect which at least all the standard (and common) controls (TListBox, TEditBox, TListView, TMemo, Treeview, and so on) are skinned according to the style selected, but maybe you are observed some minor issues in controls like TListBox, TListView and TTreeView.

Check the next image, which had a form with a TListBox and a TListView

As you can see the highlight color and the checkboxes doesn’t use the Vcl Styles elements.

The Explanation

So why this happen? is a Vcl Style bug? well let me answer both questions :

First exist basically two ways how the vcl styles skin a control, if the control doesn’t have a windows handle (like the TLabel), the control is draw (usually) in the  paint method using the properties and procedures of the StyleServices (TCustomStyleServices) class, otherwise if the control is a TWinControl descendent then use the Style Hooks , the styles hooks handles the windows messages of the controls wrapped by the VCL and use Windows messages and WinApi calls to draw directly over the Canvas of the control or set the properties of the controls (when is possible) like the background  or foreground color using the SendMessage function. 

In this point the windows messages are the key,   some Windows controls doesn’t fire some messages at least which the control was in an owner draw (or Custom Draw) mode.

for example if you want to change the highlight color of  a listview

1) You must receive the WM_NOTIFY message
2) then check the NM_CUSTOMDRAW notification code
3) after check for the current drawing stage (CDDS_ITEMPREPAINT in this case)
4) to finally pass a NMLVCUSTOMDRAW record with the new colors to use.

So in this case if the list view has the OwnerDraw property set to false these messages never will sent to our application. Because that is not possible implement a Style hook as there are not windows messages to process.

Note : Is technically possible write a Style hook for receive such owner draw messages, but that will implies create a style hook which need modify the ownerdraw property and then full draw the control.

The Fix

So how the style hooks are discarded, in this case we can owner draw the contols using the Vcl Styles classes and functions. (I don’t spend much time writing these routines , so can be incomplete)

OnDrawItem implementation for a TListbox

procedure TFrmMain.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
Var
 LListBox : TListBox;
 LStyles  : TCustomStyleServices;
 LDetails : TThemedElementDetails;
begin
  LListBox :=TListBox(Control);
  LStyles  :=StyleServices;
  //check the state
  if odSelected in State then
    LListBox.Brush.Color := LStyles.GetSystemColor(clHighlight);

  //get the details (states and parts) to use
  LDetails := StyleServices.GetElementDetails(tlListItemNormal);
    
  LListBox.Canvas.FillRect(Rect);
  Rect.Left:=Rect.Left+2;
  //draw the text
  LStyles.DrawText(LListBox.Canvas.Handle, LDetails, LListBox.Items[Index], Rect, [tfLeft, tfSingleLine, tfVerticalCenter]);

  //draw the Highlight rect using the vcl styles colors
  if odFocused In State then
  begin
    LListBox.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight);
    LListBox.Canvas.DrawFocusRect(Rect);
  end;
end;

OnDrawItem implementation for a TListView

procedure TFrmMain.ListView1DrawItem(Sender: TCustomListView; Item: TListItem;
  Rect: TRect; State: TOwnerDrawState);
var
  r         : TRect;
  rc        : TRect;
  ColIdx    : Integer;
  s         : string;
  LDetails  : TThemedElementDetails;
  LStyles   : TCustomStyleServices;
  BoxSize   : TSize;
  Spacing   : Integer;
  LColor    : TColor;
begin
  Spacing:=4;
  LStyles:=StyleServices;
  //get the color text of the items 
  if not LStyles.GetElementColor(LStyles.GetElementDetails(ttItemNormal), ecTextColor, LColor) or  (LColor = clNone) then
  LColor := LStyles.GetSystemColor(clWindowText);

  //get and set the backgroun color
  Sender.Canvas.Brush.Color := LStyles.GetStyleColor(scListView);

  //set the font color
  Sender.Canvas.Font.Color  := LColor;
  Sender.Canvas.FillRect(Rect);

  r := Rect;
  inc(r.Left, Spacing);
  //iterate over the columns
  for ColIdx := 0 to TListView(Sender).Columns.Count - 1 do
  begin
    r.Right := r.Left + Sender.Column[ColIdx].Width;

    if ColIdx > 0 then
      s := Item.SubItems[ColIdx - 1]
    else
    begin
      BoxSize.cx := GetSystemMetrics(SM_CXMENUCHECK);
      BoxSize.cy := GetSystemMetrics(SM_CYMENUCHECK);
      s := Item.Caption;
      if TListView(Sender).Checkboxes then
       r.Left:=r.Left+BoxSize.cx+3;
    end;

    if ColIdx = 0 then
    begin
      if not IsWindowVisible(ListView_GetEditControl(Sender.Handle)) and ([odSelected, odHotLight] * State <> []) then
      begin
        if ([odSelected, odHotLight] * State <> []) then
        begin
          rc:=Rect;
          if TListView(Sender).Checkboxes then
           rc.Left:=rc.Left+BoxSize.cx+Spacing;

          if not TListView(Sender).RowSelect then
           rc.Right:=Sender.Column[0].Width;
          
          Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight);
          //draw the highlight rect using the current the vcl styles colors
          Sender.Canvas.FillRect(rc);
        end;
      end;
    end;

    if TListView(Sender).RowSelect then
      Sender.Canvas.Brush.Color := LStyles.GetSystemColor(clHighlight);

    //draw the text of the item
    LDetails := StyleServices.GetElementDetails(tlListItemNormal);
    Sender.Canvas.Brush.Style := bsClear;
    LStyles.DrawText(Sender.Canvas.Handle, LDetails, s, r, [tfLeft, tfSingleLine, tfVerticalCenter, tfEndEllipsis]);

    //draw the check box 
    if (ColIdx=0) and TListView(Sender).Checkboxes then
    begin
      rc := Rect;
      rc.Top    := Rect.Top + (Rect.Bottom - Rect.Top - BoxSize.cy) div 2;
      rc.Bottom := rc.Top + BoxSize.cy;
      rc.Left   := rc.Left + Spacing;
      rc.Right  := rc.Left + BoxSize.cx;

      if Item.Checked then
       LDetails := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal)
      else
       LDetails := StyleServices.GetElementDetails(tbCheckBoxcheckedNormal);

      LStyles.DrawElement(Sender.Canvas.Handle, LDetails, Rc);
    end;

    if ColIdx=0 then
     r.Left:=Sender.Column[ColIdx].Width + Spacing
    else
     inc(r.Left, Sender.Column[ColIdx].Width);
  end;

end;

After of apply the above code , this is the result

Download the full source of the demo project from here.

Categories: Delphi, Delphi XE2, VCL Styles

Adding VCL Styles support to a TPopupMenu in 2 lines of code.

March 6, 2012 15 comments

The TPopupMenu component has not support for Vcl Styles directly, so if you use this control in a form with Vcl Styles enabled you will get a result like this.

To fix this you have 2 ways :

  1. Write a style hook for a TPopUpMenu (The hard way)
  2. Or use the TPopupActionBar component (the easy way)

In this post I will show you how use the option 2, taking advantage of two facts

  1. The TPopupActionBar component has full support for Vcl Styles
  2. Descends directly from the TPopupMenu component.

So adding the Vcl.ActnPopup unit to your project and using a interposer class (before of the form declaration which contains the PopupMenu), you can add vcl styles to the TPopupMenu component.

uses Vcl.ActnPopup;
type TPopupMenu=class(Vcl.ActnPopup.TPopupActionBar);

This is the result after of add the 2 above lines of code.

Categories: Delphi, Delphi XE2, VCL Styles

Fixing a VCL Style bug in the TButton component

February 26, 2012 2 comments

A few weeks ago a fellow delphi developer ask me via email about a workaround for a bug in the TButton component, when the ImageAlignment property has a value different than iaLeft (btw i just submit this bug to Quality Central).
Tipically when you uses this property in a TButton without a Vcl Style applied you had a result like this.

Now if you apply any Vcl Style, this is the result

As you can see the images are not aligned properly. This is due which the TButtonStyleHook class (used by the TButton component) ignore the value of the ImageAlignment property. So to fix that we must patch the code of the Paint method TButtonStyleHook style hook.

Check the next code for a workaround

Uses
 Winapi.CommCtrl,
 Vcl.Themes,
 Vcl.Styles;

type
  TCustomButtonH=class(TCustomButton);

  //we need this helper to access some strict private fields
  TButtonStyleHookHelper = class Helper for TButtonStyleHook
  protected
   function Pressed : Boolean;
   function DropDown: Boolean;
  end;
  
  //to avoid writting a lot of extra code we are to use TButtonStyleHook class and override the paint method
  TButtonStyleHookFix = class(TButtonStyleHook)
  protected
    procedure Paint(Canvas: TCanvas); override;
  end;


{ TButtonStyleHookFix }

procedure TButtonStyleHookFix.Paint(Canvas: TCanvas);
var
  LDetails          : TThemedElementDetails;
  DrawRect          : TRect;
  pbuttonImagelist  : BUTTON_IMAGELIST;
  IW, IH, IY        : Integer;
  LTextFormatFlags  : TTextFormatFlags;
  ThemeTextColor    : TColor;
  Buffer            : string;
  BufferLength      : Integer;
  SaveIndex         : Integer;
  X, Y, I           : Integer;
  BCaption          : String;
begin

  if StyleServices.Available then
  begin
    BCaption := Text;
    if Pressed then
      LDetails := StyleServices.GetElementDetails(tbPushButtonPressed)
    else
    if MouseInControl then
      LDetails := StyleServices.GetElementDetails(tbPushButtonHot)
    else
    if Focused then
      LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted)
    else
    if Control.Enabled then
      LDetails := StyleServices.GetElementDetails(tbPushButtonNormal)
    else
      LDetails := StyleServices.GetElementDetails(tbPushButtonDisabled);

    DrawRect := Control.ClientRect;
    StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect);

    if Button_GetImageList(handle, pbuttonImagelist) and (pbuttonImagelist.himl <> 0) and ImageList_GetIconSize(pbuttonImagelist.himl, IW, IH) then
    begin
      if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then
        IY := DrawRect.Top + 15
      else
        IY := DrawRect.Top + (DrawRect.Height - IH) div 2;

      //here the image is drawn properly according to the ImageAlignment value
      case TCustomButton(Control).ImageAlignment of
        iaLeft  :
                  begin
                    ImageList_Draw(pbuttonImagelist.himl, 0, Canvas.Handle, DrawRect.Left + 3, IY, ILD_NORMAL);
                    Inc(DrawRect.Left, IW + 3);
                  end;
        iaRight :
                  begin
                    ImageList_Draw(pbuttonImagelist.himl, 0, Canvas.Handle, DrawRect.Right - IW -3, IY, ILD_NORMAL);
                    Dec(DrawRect.Right, IW - 3);
                  end;

        iaCenter:
                  begin
                   ImageList_Draw(pbuttonImagelist.himl, 0, Canvas.Handle, (DrawRect.Right - IW) div 2, IY, ILD_NORMAL);
                  end;


        iaTop   :
                  begin
                   ImageList_Draw(pbuttonImagelist.himl, 0, Canvas.Handle, (DrawRect.Right - IW) div 2, 3, ILD_NORMAL);
                  end;


        iaBottom:
                  begin
                   ImageList_Draw(pbuttonImagelist.himl, 0, Canvas.Handle, (DrawRect.Right - IW) div 2, (DrawRect.Height - IH) - 3, ILD_NORMAL);
                  end;

      end;


    end;

    if (GetWindowLong(Handle, GWL_STYLE) and BS_COMMANDLINK) = BS_COMMANDLINK then
    begin
      if pbuttonImagelist.himl = 0 then
        Inc(DrawRect.Left, 35);

      Inc(DrawRect.Top, 15);
      Inc(DrawRect.Left, 5);
      Canvas.Font := TCustomButtonH(Control).Font;
      Canvas.Font.Style := [];
      Canvas.Font.Size := 12;
      LTextFormatFlags := TTextFormatFlags(DT_LEFT);
      if StyleServices.GetElementColor(LDetails, ecTextColor, ThemeTextColor) then
         Canvas.Font.Color := ThemeTextColor;
      StyleServices.DrawText(Canvas.Handle, LDetails, BCaption, DrawRect, LTextFormatFlags, Canvas.Font.Color);
      SetLength(Buffer, Button_GetNoteLength(Handle) + 1);
      if Length(Buffer) <> 0 then
      begin
        BufferLength := Length(Buffer);
        if Button_GetNote(Handle, PChar(Buffer), BufferLength) then
        begin
          LTextFormatFlags := TTextFormatFlags(DT_LEFT or DT_WORDBREAK);
          Inc(DrawRect.Top, Canvas.TextHeight('Wq') + 2);
          Canvas.Font.Size := 8;
          StyleServices.DrawText(Canvas.Handle, LDetails, Buffer, DrawRect,
            LTextFormatFlags, Canvas.Font.Color);
        end;
      end;

      if pbuttonImagelist.himl = 0 then
      begin
        if Pressed then
          LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphPressed)
        else if MouseInControl then
          LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphHot)
        else if Control.Enabled then
          LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphNormal)
        else
          LDetails := StyleServices.GetElementDetails(tbCommandLinkGlyphDisabled);
        DrawRect.Right := 35;
        DrawRect.Left := 3;
        DrawRect.Top := 10;
        DrawRect.Bottom := DrawRect.Top + 32;
        StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect);
      end;

    end
    else
    if (GetWindowLong(Handle, GWL_STYLE) and BS_SPLITBUTTON) = BS_SPLITBUTTON then
    begin
      Dec(DrawRect.Right, 15);
      DrawControlText(Canvas, LDetails, Text, DrawRect, DT_VCENTER or DT_CENTER);
      if DropDown then
      begin
        LDetails := StyleServices.GetElementDetails(tbPushButtonPressed);
        SaveIndex := SaveDC(Canvas.Handle);
        try
          IntersectClipRect(Canvas.Handle, Control.Width - 15, 0,
            Control.Width, Control.Height);
          DrawRect := Rect(Control.Width - 30, 0, Control.Width, Control.Height);
          StyleServices.DrawElement(Canvas.Handle, LDetails, DrawRect);
        finally
          RestoreDC(Canvas.Handle, SaveIndex);
        end;
      end;

      with Canvas do
      begin
        Pen.Color := StyleServices.GetSystemColor(clBtnShadow);
        MoveTo(Control.Width - 15, 3);
        LineTo(Control.Width - 15, Control.Height - 3);
        if Control.Enabled then
          Pen.Color := StyleServices.GetSystemColor(clBtnHighLight)
        else
          Pen.Color := Font.Color;
        MoveTo(Control.Width - 14, 3);
        LineTo(Control.Width - 14, Control.Height - 3);
        Pen.Color := Font.Color;
        X := Control.Width - 8;
        Y := Control.Height div 2 + 1;
        for i := 3 downto 0 do
        begin
          MoveTo(X - I, Y - I);
          LineTo(X + I + 1, Y - I);
        end;
      end;

    end
    else
    begin
      //finally the text is aligned and drawn depending of the value of the ImageAlignment property
      case TCustomButton(Control).ImageAlignment of
        iaLeft,
        iaRight,
        iaCenter : DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_VCENTER or DT_CENTER);
        iaBottom : DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_TOP or DT_CENTER);
        iaTop    : DrawControlText(Canvas, LDetails, BCaption, DrawRect, DT_BOTTOM or DT_CENTER);
      end;
    end;
  end;
end;

{ TButtonStyleHookHelper }

function TButtonStyleHookHelper.DropDown: Boolean;
begin
  Result:=Self.FDropDown;
end;

function TButtonStyleHookHelper.Pressed: Boolean;
begin
  Result:=Self.FPressed;
end;

And this is the result after of aply the above style hook

TStyleManager.Engine.RegisterStyleHook(TButton, TButtonStyleHookFix);

Categories: Delphi, Delphi XE2, VCL Styles

Disabling the VCL Styles in the non client area of a Form

February 7, 2012 8 comments

Today I receive a question about how disable the vcl styles in the non client area of a vcl form. Well that can be done using a Style hook.

Tipically a VCL form with a vcl style look like this

To remove the vcl style in the non client are we need create a style hook which descend of the TMouseTrackControlStyleHook and then override the PaintBackground and Create methods.

Check this sample code

  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;

And apply in this way 

TStyleManager.Engine.RegisterStyleHook(TForm1, TFormStyleHookNC);

After of that this is the result

Categories: Delphi, Delphi XE2, VCL Styles

Changing the color of Edit Controls with VCL Styles Enabled

February 6, 2012 7 comments

The Issue

The last weeks I found a couple questions and QC reports(100645, 101822, 102984) regarding to how change the color of a Edit Control (TEdit, TMaskEdit, TMemo and so on) when the VCL Styles are enabled. So today I will show you how you can change the colors of these controls even with the VCL Styles activated.

In a Standard VCL Form application you can change the Color property of Edit controls

But when the Vcl Styles Are applied these colors are not used, and the controls are painted using the colors of the current VCl Style.

The Solution

So what is the solution? well the answer is : Create a new TStyleHook (read this article to learn more about Style Hooks) . All the TWinControls uses a TStyleHook to paint the control when the vcl styles are actived, so you can modify the TStyleHook of a particular control to modify the way of how the component is painted.

Implementation

Before to implement a Custom Style hook you must be aware which this new TStyleHook will affect to all the controls of the same type used in the RegisterStyleHook method, because the Style hooks are implemented for a particular class type and not for an instance.

First let’s create a style hook for the TCustomEdit descendents, using the TEditStyleHook class, this new style hook can be used with controls like TEdit, TMaskEdit, TLabeledEdit and so on.

Check the next commented code

  TEditStyleHookColor = class(TEditStyleHook)
  private
    procedure UpdateColors;
  protected
    procedure WndProc(var Message: TMessage); override;
    constructor Create(AControl: TWinControl); override;
  end;

uses
  Vcl.Styles;

type
 TWinControlH= class(TWinControl);

constructor TEditStyleHookColor.Create(AControl: TWinControl);
begin
  inherited;
  //call the UpdateColors method to use the custom colors 
  UpdateColors;
end;

//Here you set the colors of the style hook 
procedure TEditStyleHookColor.UpdateColors;
var
  LStyle: TCustomStyleServices;
begin
 if Control.Enabled then
 begin
  Brush.Color := TWinControlH(Control).Color; //use the Control color
  FontColor   := TWinControlH(Control).Font.Color;//use the Control font color
 end
 else
 begin
  //if the control is disabled use the colors of the style
  LStyle := StyleServices;
  Brush.Color := LStyle.GetStyleColor(scEditDisabled);
  FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled);
 end;
end;

//Handle the messages of the control
procedure TEditStyleHookColor.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
      begin
        //Get the colors 
        UpdateColors;
        SetTextColor(Message.WParam, ColorToRGB(FontColor));
        SetBkColor(Message.WParam, ColorToRGB(Brush.Color));
        Message.Result := LRESULT(Brush.Handle);
        Handled := True;
      end;
    CM_ENABLEDCHANGED:
      begin
        //Get the colors 
        UpdateColors;
        Handled := False;
      end
  else
    inherited WndProc(Message);
  end;
end;

Now a style hook for the TCustomMemo using the TMemoStyleHook class.


  TMemoStyleHookColor = class(TMemoStyleHook)
  private
    procedure UpdateColors;
  protected
    procedure WndProc(var Message: TMessage); override;
    constructor Create(AControl: TWinControl); override;
  end;

constructor TMemoStyleHookColor.Create(AControl: TWinControl);
begin
  inherited;
  //call the UpdateColors method to use the custom colors 
  UpdateColors;
end;

//Set the colors to be used by the Style hook
procedure TMemoStyleHookColor.UpdateColors;
var
  LStyle: TCustomStyleServices;
begin
 if Control.Enabled then
 begin
  Brush.Color := TWinControlH(Control).Color;
  FontColor   := TWinControlH(Control).Font.Color;
 end
 else
 begin
  //if the control is disabled use the current style colors
  LStyle := StyleServices;
  Brush.Color := LStyle.GetStyleColor(scEditDisabled);
  FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled);
 end;
end;

//handle the messages 
procedure TMemoStyleHookColor.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
      begin
        //get the colors
        UpdateColors;
        SetTextColor(Message.WParam, ColorToRGB(FontColor));
        SetBkColor(Message.WParam, ColorToRGB(Brush.Color));
        Message.Result := LRESULT(Brush.Handle);
        Handled := True;
      end;
    CM_ENABLEDCHANGED:
      begin
        //get the colors
        UpdateColors;
        Handled := False;
      end
  else
    inherited WndProc(Message);
  end;
end;

Finally to apply the above code you must call the TStyleManager.Engine.RegisterStyleHook method in this way (ideally in the initialization part of you unit)

 TStyleManager.Engine.RegisterStyleHook(TEdit, TEditStyleHookColor);
 TStyleManager.Engine.RegisterStyleHook(TMaskEdit, TEditStyleHookColor);
 TStyleManager.Engine.RegisterStyleHook(TLabeledEdit, TEditStyleHookColor);
 TStyleManager.Engine.RegisterStyleHook(TButtonedEdit, TEditStyleHookColor);

 TStyleManager.Engine.RegisterStyleHook(TMemo, TMemoStyleHookColor);

Trick : If you only want apply these new hooks to the controls of a particular form, you can use a interposer class in the begining of your unit 

type
  TEdit= Class (Vcl.StdCtrls.TEdit);
  TMemo= Class (Vcl.StdCtrls.TMemo);
  TButtonedEdit= Class (Vcl.ExtCtrls.TButtonedEdit);
  TLabeledEdit= Class (Vcl.ExtCtrls.TLabeledEdit);

The final result

Now look how the forms with the vcl styles can have custom colors in the Edit controls

Download the full source code and a demo project from here

Categories: Delphi, Delphi XE2, VCL Styles
Follow

Get every new post delivered to your Inbox.

Join 61 other followers