thememgr.pas

Last change: 2008-02-03 This is the source code of KCeasy。

  begin
    with TPanelCast(Control) do
    begin
      Canvas.Handle := DC;
      try
        Canvas.Font := Font;
        Rect := GetClientRect;
        if BevelOuter <> bvNone then
        begin
          AdjustColors(BevelOuter);
          Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
        end;
        InflateRect(Rect, -BorderWidth, -BorderWidth);
        if BevelInner <> bvNone then
        begin
          AdjustColors(BevelInner);
          Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
        end;
        if ParentColor or ((Control.Parent <> nil) and (Control.Parent.Brush.Color = Color)) then
        begin
          if TWinControl(Control.Parent).DoubleBuffered then
            PerformEraseBackground(Control, PS.hdc)
          else
          begin
            Details := ThemeServices.GetElementDetails(tbGroupBoxNormal);
            ThemeServices.DrawParentBackground(Handle, DC, @Details, False, @Rect);
          end
        end
        else
        begin
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Color;
          FillRect(PS.hdc, Rect, Canvas.Brush.Handle);
        end;
        FontHeight := Canvas.TextHeight('W');
        with Rect do
        begin
          Top := ((Bottom + Top) - FontHeight) div 2;
          Bottom := Top + FontHeight;
        end;
        Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment];
        Flags := DrawTextBiDiModeFlags(Flags);
        OldFont := SelectObject(DC, Font.Handle);
        SetBKMode(DC, TRANSPARENT);
        SetTextColor(DC, ColorToRGB(Font.Color));
        DrawText(DC, PChar(Caption), -1, Rect, Flags);
        SelectObject(DC, OldFont);
      finally
        Canvas.Handle := 0;
      end;
    end;
  end;

  //--------------- end local function ----------------------------------------

begin
  if not DoControlMessage(Control, Message) then
  begin
    if ThemeServices.ThemesEnabled and TPanelCast(Control).ParentColor or
      (Assigned(Control.Parent) and (Control.Parent.Brush.Color = TPanelCast(Control).Color)) then
    begin
      case Message.Msg of
        WM_ERASEBKGND:
          with TPanelCast(Control) do
          begin
            DC := TWMEraseBkGnd(Message).DC;
            // Get the parent to draw its background into the control's background.
            if TWinControl(Control.Parent).DoubleBuffered then
              PerformEraseBackground(Control, DC)
            else
            begin
              Details := ThemeServices.GetElementDetails(tbGroupBoxNormal);
              ThemeServices.DrawParentBackground(Handle, DC, @Details, False);
            end;
            Message.Result := 1;
          end;
        WM_NCPAINT:
          with TPanelCast(Control) do
          begin
            FPanelList.DispatchMessage(Control, Message);
            if BorderStyle <> bsNone then
            begin
              DrawRect := BoundsRect;
              OffsetRect(DrawRect, -Left, -Top);
              DC := GetWindowDC(Handle);
              try
                Details := ThemeServices.GetElementDetails(trBandNormal);
                ThemeServices.DrawEdge(DC, Details, DrawRect, EDGE_SUNKEN, BF_RECT);
              finally
                ReleaseDC(Handle, DC);
              end;
            end;
            Message.Result := 0;
          end;
        WM_PAINT:
          with TPanelCast(Control) do
          begin
            DC := BeginPaint(Handle, PS);
            NewPaint;
            PaintControls(DC, nil);
            EndPaint(Handle, PS);
            Message.Result := 0;
          end;
        WM_PRINTCLIENT:
          with TPanelCast(Control) do
          begin
            DC := TWMPrintClient(Message).DC;
            NewPaint;
            PaintControls(DC, nil);
            Message.Result := 0;
          end;
      else
        FPanelList.DispatchMessage(Control, Message);
      end;
    end
    else
      FPanelList.DispatchMessage(Control, Message);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TThemeManager.SetThemeOptions(const Value: TThemeOptions);

var
  Flags: Cardinal;
  I: Integer;

begin
  // If this instance is the main manager then apply the options directly. Otherwise let the current main manager do it.
  Lock.Enter;
  try
    if Assigned(MainManager) and (MainManager <> Self) then
      MainManager.Options := Value
    else
    begin
      if FOptions <> Value then
      begin
        FOptions := Value;

        if ThemeServices.ThemesAvailable and not FSubclassingDisabled and not (csDesigning in ComponentState) then
        begin
          Flags := 0;
          if toAllowNonClientArea in FOptions then
            Flags := Flags or STAP_ALLOW_NONCLIENT;
          if toAllowControls in FOptions then
            Flags := Flags or STAP_ALLOW_CONTROLS;
          if toAllowWebContent in FOptions then
            Flags := Flags or STAP_ALLOW_WEBCONTENT;
          SetThemeAppProperties(Flags);
          if ComponentState * [csLoading, csReading] = [] then
          begin
            UpdateThemes;

            // Tell the application that we changed the options.
            BroadcastThemeChange;
            // Notify all theme manager instances about the change.
            SendAppMessage(WM_THEMECHANGED, 0, 0);

            for I := 0 to Screen.FormCount - 1 do
              RedrawWindow(Screen.Forms[I].Handle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_INTERNALPAINT or
                RDW_ERASENOW or RDW_UPDATENOW or RDW_ALLCHILDREN);
          end;
        end;
      end;
    end;
  finally
    Lock.Leave;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

type
  TSpeedButtonCast = class(TSpeedButton);

procedure TThemeManager.SpeedButtonWindowProc(Control: TControl; var Message: TMessage);

var
  Button: TThemedButton;
  P: TPoint;

begin
  if not DoControlMessage(Control, Message) then
  begin
    if ThemeServices.ThemesEnabled then
    begin
      case Message.Msg of
        WM_PAINT:
          with TWMPaint(Message) do
          begin
            // We cannot use the theme parent paint for the background of general speed buttons (because they are not
            // window controls).
            PerformEraseBackground(Control, DC);

            // Speed buttons are not window controls and are painted by a call of their parent with a given DC.
            if not Control.Enabled then
              Button := tbPushButtonDisabled
            else
              if TSpeedButtonCast(Control).FState in [bsDown, bsExclusive] then
                Button := tbPushButtonPressed
              else
              with TSpeedButtonCast(Control) do
              begin
                // Check the hot style here. If the button has a flat style then this check is easy. Otherwise
                // some more work is necessary.
                Button := tbPushButtonNormal;
                if Flat then
                begin
                  if MouseInControl then
                    Button := tbPushButtonHot;
                end
                else
                begin
                  GetCursorPos(P);
                  if FindDragTarget(P, True) = Control then
                    Button := tbPushButtonHot;
                end;
              end;
            DrawButton(Control, Button, DC, Control.ClientRect, False);
            Message.Result := 0;
          end;
        CM_MOUSEENTER,
        CM_MOUSELEAVE:
          begin
            // Non-flat speed buttons don't have a hot-tracking style. We have to emulate this.
            if not TSpeedButtonCast(Control).Flat and Control.Enabled then
              Control.Invalidate;
            FSpeedButtonList.DispatchMessage(Control, Message);
          end;
      else
        FSpeedButtonList.DispatchMessage(Control, Message);
      end;
    end
    else
      FSpeedButtonList.DispatchMessage(Control, Message);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TThemeManager.SplitterWindowProc(Control: TControl; var Message: TMessage);

begin
  if not DoControlMessage(Control, Message) then
  begin
    if ThemeServices.ThemesEnabled then
    begin
      case Message.Msg of
        WM_PAINT:
          with TWMPaint(Message) do
          begin
            PerformEraseBackground(Control, DC);
            Message.Result := 0;
          end;
      else
        FSplitterList.DispatchMessage(Control, Message);
      end;
    end
    else
      FSplitterList.DispatchMessage(Control, Message);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

type
  TCustomStatusBarCast = class(TCustomStatusBar);

procedure TThemeManager.StatusBarWindowProc(Control: TControl; var Message: TMessage);

var
  Details: TThemedElementDetails;

begin
  if not DoControlMessage(Control, Message) then
  begin
    if ThemeServices.ThemesEnabled then
    begin
      case Message.Msg of
        WM_NCCALCSIZE:
          with TWMNCCalcSize(Message) do
          begin
            FStatusBarList.DispatchMessage(Control, Message);
            // We cannot simply override the window class' CS_HREDRAW and CS_VREDRAW styles but the following
            // does the job very well too.
            // Note: this may produce trouble with embedded controls (e.g. progress bars).
            if CalcValidRects then
              Result := Result or WVR_REDRAW;
          end;
        WM_ERASEBKGND:
          with TWMEraseBkGnd(Message) do
          begin
            Details := ThemeServices.GetElementDetails(tsStatusRoot);
            ThemeServices.DrawElement(DC, Details, Control.ClientRect);
            Message.Result := 1;
          end;
      else
        FStatusBarList.DispatchMessage(Control, Message);
      end;
    end
    else
      FStatusBarList.DispatchMessage(Control, Message);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TThemeManager.TabSheetWindowProc(Control: TControl; var Message: TMessage);

var
  DrawRect: TRect;
  Details: TThemedElementDetails;
  DC: HDC;

begin
  if not DoControlMessage(Control, Message) then
  begin
    if ThemeServices.ThemesEnabled then
    begin
      case Message.Msg of
        // Paint the border (and erase the background)
        WM_NCPAINT:
          with TTabSheet(Control) do
          begin
            DC := GetWindowDC(Handle);
            try
              // Exclude the client area from painting. We only want to erase the non-client area.
              DrawRect := ClientRect;
              OffsetRect(DrawRect, BorderWidth, BorderWidth);
              with DrawRect do
                ExcludeClipRect(DC, Left, Top, Right, Bottom);
              // The parent paints relative to the control's client area. We have to compensate for this by
              // shifting the dc's window origin.
              SetWindowOrgEx(DC, -BorderWidth, -BorderWidth, nil);
              Details := ThemeServices.GetElementDetails(ttBody);
              ThemeServices.DrawParentBackground(TWinControl(Control).Handle, DC, @Details, False);
            finally
              ReleaseDC(Handle, DC);
            end;
            Message.Result := 0;
          end;
        WM_PRINTCLIENT,
        WM_ERASEBKGND:
          begin
            if Message.Msg = WM_PRINTCLIENT then
              DC := TWMPrintClient(Message).DC
            else
              DC := TWMEraseBkGnd(Message).DC;
            // Using the parent's background here does not always work. Particularly, it does not work in cases
            // where the parent (pane) background does not include the body background. One way to solve this problem
            // would be to paint the body background here. However this produces a lot of problems all caused by
            // the fact that these backgrounds might be tiled or might otherwise have special drawing style.
            // Due to the near-to-non-existing documentation on all the themes APIs I use the lesser evil by default and
            // paint the parent background, which works in most cases very well.
            // However you may want to enable the other way, if needed.
            i