mORMot Open Source

kevinday

Member

Registered: 2015-10-28

Posts: 11

Fix for TSQLRibbon.ChangeColorScheme AccessViolation

Hi Arnaud,

Thank you for a great library.  Thank you for allowing me to contribute.

I found a bug in the TSQLRibbon.ChangeColorScheme() method in mORMotToolbar when ChangeColorScheme() is called with just the ColorScheme and no other parameters.  An access violation is thrown on the line

if (Body<>nil) and Body.AdvOfficePagerStyler.InheritsFrom(TAdvOfficePagerOfficeStyler) then
  TAdvOfficePagerOfficeStyler(Body.AdvOfficePagerStyler).Style :=  TOfficePagerStyle(StatusBarStyler.Style);

The issue is that in this case the StatusBarStyler is nil

I propose a fix to the above line to:

  if (Body <> nil) and Body.AdvOfficePagerStyler.InheritsFrom(TAdvOfficePagerOfficeStyler) then
    TAdvOfficePagerOfficeStyler(Body.AdvOfficePagerStyler).Style := TOfficePagerStyle(StatusStyle);

Full code for this method thus would be:

procedure TSQLRibbon.ChangeColorScheme(const ColorScheme: TToolBarStyle;
  PanelStyler: TAdvPanelStyler; StatusBarStyler: TAdvOfficeStatusBarOfficeStyler;
  CustomStyle: TMemoryStream);
var
  PreviewStyle: TPreviewMenuStyle;
  StatusStyle: TOfficeStatusBarStyle;
  TBStyler: TAdvToolBarOfficeStyler;
  i, curr: integer;
  C: TComponent;
begin
  if not fToolBar.ToolBarStyler.InheritsFrom(TAdvToolBarOfficeStyler) then
    exit;
  TBStyler := TAdvToolBarOfficeStyler(ToolBar.ToolBarStyler);
  if TBStyler = nil then
    exit;
  TBStyler.Style := ColorScheme;
  case ColorScheme of // bulky TMS styles don't match :(
    bsCustom: begin
        if CustomStyle <> nil then begin
          CustomStyle.Seek(0, soFromBeginning);
          CustomStyle.ReadComponent(TBStyler);
        end;
        PreviewStyle := AdvPreviewMenuStylers.psOffice2003Olive;
        StatusStyle := AdvOfficeStatusBarStylers.psOffice2003Olive;
      end;
    bsOffice2007Silver: begin
        PreviewStyle := AdvPreviewMenuStylers.psOffice2007Silver;
        StatusStyle := AdvOfficeStatusBarStylers.psOffice2007Silver;
      end;
    bsOfficeXP: begin
        PreviewStyle := AdvPreviewMenuStylers.psOfficeXP;
        StatusStyle := AdvOfficeStatusBarStylers.psWindowsXP;
      end;
    bsWindowsVista .. high(TToolBarStyle): begin
        PreviewStyle := TPreviewMenuStyle(ColorScheme);
        StatusStyle := TOfficeStatusBarStyle(pred(ColorScheme));
      end;
  else begin
      PreviewStyle := TPreviewMenuStyle(ColorScheme);
      StatusStyle := TOfficeStatusBarStyle(ColorScheme);
    end;
  end;
  if (PreviewMenu <> nil) and PreviewMenu.Styler.InheritsFrom(TAdvPreviewMenuOfficeStyler) then
    TAdvPreviewMenuOfficeStyler(PreviewMenu.Styler).Style := PreviewStyle;
  if StatusBarStyler <> nil then
    StatusBarStyler.Style := StatusStyle;
  if PanelStyler <> nil then
    PanelStyler.Style := TToolBarStyleToPanel[ColorScheme];
  TBStyler.CaptionAppearance.Assign(TBStyler.GroupAppearance.CaptionAppearance);
  with TBStyler.GroupAppearance.TabAppearance do begin
    TBStyler.PagerCaption.TextColor := TextColor;
    TBStyler.PagerCaption.TextColorExtended := TextColorSelected;
  end;
//** Change here
  if (Body <> nil) and Body.AdvOfficePagerStyler.InheritsFrom(TAdvOfficePagerOfficeStyler) then
    TAdvOfficePagerOfficeStyler(Body.AdvOfficePagerStyler).Style := TOfficePagerStyle(StatusStyle);
    // update colors for windows
  for i := 0 to Application.ComponentCount - 1 do begin
    C := Application.Components[i];
    if C.InheritsFrom(TCustomForm) then
      SetStyle(C, TBStyler); // will set style for all embedded components
  end;
    // update report colors on every ribbon page
  curr := fToolBar.ActivePageIndex;
  for i := 0 to high(Page) do
    with Page[i] do begin
      if Report <> nil then
        Report.Color := TBStyler.QATAppearance.ColorTo;
      if i = curr then
        List.Invalidate; // repaint list first row with new colors
    end;
  if Form <> nil then
    Form.Invalidate; // whole form redraw
end;

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,666

Website

Re: Fix for TSQLRibbon.ChangeColorScheme AccessViolation

Nice catch.

Included as http://synopse.info/fossil/info/51e9c62af7