tebkgrnd.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

  ClientToScreen(WndHandle, RAux.TopLeft);
  ScreenToClient(BkOptions.Control.Parent.Handle, RAux.TopLeft);
  ClientToScreen(WndHandle, RAux.BottomRight);
  ScreenToClient(BkOptions.Control.Parent.Handle, RAux.BottomRight);

  RAux2 := DrawR;
  LPToDP(Bmp.Canvas.Handle, RAux2, 2);
  SaveClipRgn := CreateRectRgn(0, 0, 0, 0);
  ExistsClipRgn := GetClipRgn(Bmp.Canvas.Handle, SaveClipRgn) = 1;
  ClipRgn := CreateRectRgn(RAux2.Left, RAux2.Top, RAux2.Right, RAux2.Bottom);
  SelectClipRgn(Bmp.Canvas.Handle, ClipRgn);
  DeleteObject(ClipRgn);
  try
    OffsetWindowOrgEx(Bmp.Canvas.Handle, RAux.Left-R.Left-(DrawR.Left-R.Left),
      RAux.Top-R.Top-(DrawR.Top-R.Top), P);
    try
      Limit := WndHandle;
      HasUpdateRect:= GetUpdateRect(TWinControl(BkOptions.Control).Handle,
        TRect(nil^), False);
      try
        RenderWindowToDC(BkOptions.Control.Parent.Handle, Limit,
          BkOptions.Control.Parent, Bmp.Canvas.Handle, RAux, True, False);
      finally
        if not HasUpdateRect then
          ValidateRect(TWinControl(BkOptions.Control).Handle, nil);
      end;
    finally
      SetWindowOrgEx(Bmp.Canvas.Handle, P.x, P.y, nil);
    end;
  finally
    if ExistsClipRgn
    then SelectClipRgn(Bmp.Canvas.Handle, SaveClipRgn)
    else SelectClipRgn(Bmp.Canvas.Handle, 0);
    DeleteObject(SaveClipRgn);
  end;
end;

procedure DrawBkgrndForm(BkOptions: TFCBackgroundOptions; Control: TControl;
  var Bmp: TBitmap; R, DrawR: TRect; BmpWidth, BmpHeight: Integer;
  PixelFormat: TPixelFormat);
var
  WndHandle: HWnd;
  RAux,
  RAux2: TRect;
  P: TPoint;
  SaveClipRgn,
  ClipRgn: HRGN;
  ExistsClipRgn: Boolean;
  BkForm: TCustomForm;
  ClientWidth,
  ClientHeight,
  OffSetH,
  OffsetV: Integer;
  ScrollInfoH,
  ScrollInfoV: TScrollInfo;
begin
  if Control is TWinControl
  then WndHandle := (Control as TWinControl).Handle
  else WndHandle := Control.Parent.Handle;

  BkForm := BkOptions.BkgrndForm;

  ClientWidth  := BkOptions.Control.ClientWidth;
  ClientHeight := BkOptions.Control.ClientHeight;
  OffSetH      := 0;
  OffSetV      := 0;

  if IsScrollBarVisible(BkOptions.Control, TWinControl(BkOptions.Control).Handle, sbHorizontal) then
  begin
    ScrollInfoH.cbSize := SizeOf(ScrollInfoH);
    ScrollInfoH.fMask  := SIF_ALL;
    GetScrollInfo(TWinControl(BkOptions.Control).Handle, SB_HORZ, ScrollInfoH);
    ClientWidth  := ScrollInfoH.nMax;
    OffSetH      := -ScrollInfoH.nPos;
  end;
  if IsScrollBarVisible(BkOptions.Control, TWinControl(BkOptions.Control).Handle, sbVertical) then
  begin
    ScrollInfoV.cbSize := SizeOf(ScrollInfoV);
    ScrollInfoV.fMask  := SIF_ALL;
    GetScrollInfo(TWinControl(BkOptions.Control).Handle, SB_VERT, ScrollInfoV);
    ClientHeight := ScrollInfoV.nMax;
    OffsetV      := -ScrollInfoV.nPos;
  end;

  RAux := Rect(0, 0, ClientWidth, ClientHeight);
  RAux.TopLeft     := ControlClientToScreen(BkOptions.Control, RAux.TopLeft);
  RAux.BottomRight := ControlClientToScreen(BkOptions.Control, RAux.BottomRight);
  OffsetRect(RAux, OffSetH, OffsetV);
  if not EqualRect(RAux, BkForm.BoundsRect) then
    BkForm.SetBounds(RAux.Left, RAux.Top, RAux.Right - RAux.Left,
      RAux.Bottom - RAux.Top);

  RAux := R;
  ClientToScreen(WndHandle    , RAux.TopLeft);
  ScreenToClient(BkForm.Handle, RAux.TopLeft);
  ClientToScreen(WndHandle    , RAux.BottomRight);
  ScreenToClient(BkForm.Handle, RAux.BottomRight);
  if BkOptions.Control <> Control then
  begin
    OffsetRect(RAux, -OffsetH, -OffsetV);
    if IsScrollBarVisible(Control, TWinControl(Control).Handle, sbHorizontal) then
    begin
      ScrollInfoH.cbSize := SizeOf(ScrollInfoH);
      ScrollInfoH.fMask  := SIF_POS;
      GetScrollInfo(TWinControl(Control).Handle, SB_HORZ, ScrollInfoH);
      OffsetRect(RAux, -ScrollInfoH.nPos, 0);
    end;
    if IsScrollBarVisible(Control, TWinControl(Control).Handle, sbVertical) then
    begin
      ScrollInfoV.cbSize := SizeOf(ScrollInfoV);
      ScrollInfoV.fMask  := SIF_POS;
      GetScrollInfo(TWinControl(Control).Handle, SB_VERT, ScrollInfoV);
      OffsetRect(RAux, 0, -ScrollInfoV.nPos);
    end;
  end;

  RAux2 := DrawR;
  LPToDP(Bmp.Canvas.Handle, RAux2, 2);
  SaveClipRgn := CreateRectRgn(0, 0, 0, 0);
  ExistsClipRgn := GetClipRgn(Bmp.Canvas.Handle, SaveClipRgn) = 1;
  ClipRgn := CreateRectRgn(RAux2.Left, RAux2.Top, RAux2.Right, RAux2.Bottom);
  SelectClipRgn(Bmp.Canvas.Handle, ClipRgn);
  DeleteObject(ClipRgn);
  try
    OffsetWindowOrgEx(Bmp.Canvas.Handle, RAux.Left-R.Left+OffSetH,
      RAux.Top-R.Top+OffsetV, P);
    try
      RenderWindowToDC(BkForm.Handle, 0, BkForm, Bmp.Canvas.Handle, RAux,
        True, False);
    finally
      SetWindowOrgEx(Bmp.Canvas.Handle, P.x, P.y, nil);
    end;
  finally
    if ExistsClipRgn
    then SelectClipRgn(Bmp.Canvas.Handle, SaveClipRgn)
    else SelectClipRgn(Bmp.Canvas.Handle, 0);
    DeleteObject(SaveClipRgn);
  end;
end;

procedure DrawPicture(BkOptions: TFCBackgroundOptions; Bmp: TBitmap; R: TRect;
  Ctrl: TControl);

  procedure TileBitmap(Pic: TPicture; Bmp: TBitmap; PicRect, R: TRect);
  var
    TileStart: TPoint;
    i,
    j,
    Cols,
    Rows,
    xPos,
    yPos: Integer;
  begin
    TileStart.X := R.Left - ((R.Left - PicRect.Left) mod Pic.Width );
    TileStart.Y := R.Top  - ((R.Top  - PicRect.Top ) mod Pic.Height);
    Cols        := (R.Right  - TileStart.X) div Pic.Width;
    if (R.Right  - TileStart.X) mod Pic.Width  <> 0 then
      Inc(Cols);
    Rows        := (R.Bottom - TileStart.Y) div Pic.Height;
    if (R.Bottom - TileStart.Y) mod Pic.Height <> 0 then
      Inc(Rows);

    xPos := TileStart.X;
    for i := 0 to Cols-1 do
    begin
      yPos := TileStart.Y;
      for j := 0 to Rows-1 do
      begin
        Bmp.Canvas.Draw(xPos, yPos, Pic.Graphic);
        Inc(yPos, Pic.Height);
      end;
      Inc(xPos, Pic.Width);
    end;
  end;

var
  aux,
  PicRect: TRect;
  Pic: TPicture;
begin
  Pic     := BkOptions.Picture;
  PicRect := PictureRect(BkOptions, Ctrl);
  IntersectRect(aux, PicRect, R);
  if IsRectEmpty(aux) then
    exit;

  if BkOptions.PictureTranspColor = clNone
  then Pic.Graphic.Transparent := False
  else
  begin
    Pic.Graphic.Transparent := True;
    if Pic.Graphic is TBitmap then
      TBitmap(Pic.Graphic).TransparentColor := BkOptions.PictureTranspColor;
  end;

  case BkOptions.PictureMode of
    fcpmCenter       : Bmp.Canvas.Draw(PicRect.Left, PicRect.Top, Pic.Graphic);
    fcpmCenterStretch: Bmp.Canvas.StretchDraw(PicRect, Pic.Graphic);
    fcpmStretch      : Bmp.Canvas.StretchDraw(PicRect, Pic.Graphic);
    fcpmTile         : TileBitmap(Pic, Bmp, PicRect, R);
  end;
end;

procedure BlendBkgrnd(BkOptions: TFCBackgroundOptions; Bmp: TBitmap;
  LocalBmp: Boolean; R: TRect; RWidth, RHeight: Integer;
  PixelFormat: TPixelFormat);
var
  BrushBmp: TBitmap;
  BrushAlign: TPoint;
  ParentForm: TCustomForm;
  Level: Integer;
  BmpRect: TRect;
  P: TPoint;
begin
  if PixelFormat = pf8bit
  then
  begin
    Level := Round((BkOptions.GlassTranslucencyToUse * 63) / 255);
    BrushBmp := TBitmap.Create;
    try
      BrushBmp.Monochrome := True;
      BrushBmp.Width      := 8;
      BrushBmp.Height     := 8;

      BrushAlign := ControlClientToScreen(BkOptions.Control, R.TopLeft);
      ParentForm := GetParentForm(BkOptions.Control);
      Dec(BrushAlign.x, ParentForm.Left);
      Dec(BrushAlign.y, ParentForm.Top);
      SetBrushOrgEx(Bmp.Canvas.Handle, -BrushAlign.x, -BrushAlign.y, @P);
      try
        BlendBmp(Bmp, BrushBmp, PixelFormat, BkOptions.GlassColor, R, Level);
      finally
        SetBrushOrgEx(Bmp.Canvas.Handle, P.x, P.y, nil);
      end;
    finally
      BrushBmp.Free;
    end;
  end
  else
  begin
    Level := BkOptions.GlassTranslucencyToUse;
    if LocalBmp
    then BmpRect := Rect(0, 0, Bmp.Width, Bmp.Height)
    else
    begin
      BmpRect := R;
      LPToDP(Bmp.Canvas.Handle, BmpRect, 2);
    end;
    if not IsRectEmpty(BmpRect) then
      BlendBmp(Bmp, nil, PixelFormat, BkOptions.GlassColor, BmpRect, Level);
  end;
end;

procedure DrawStandardBackground(Control: TFCControl; DC: HDC; R: TRect);
var
  Brush: HBrush;
begin
  {$ifdef D7UP}
  with ThemeServices do
  begin
    if ThemesEnabled and Assigned(Control.Parent) and
      (csParentBackground in Control.ControlStyle) then
      DrawParentBackground(TWinControl(Control).Handle, DC, nil, False, @R)
    else
    begin
        Brush := CreateSolidBrush(Graphics.ColorToRGB(TFCControl(Control).Color));
        FillRect(DC, R, Brush);
        DeleteObject(Brush);
    end;
  end;
  {$else}
    Brush := CreateSolidBrush(ColorToRGB(TFCControl(Control).Color));
    FillRect(DC, R, Brush);
    DeleteObject(Brush);
  {$endif D7UP}
end;

procedure TFCBackgroundOptions.DrawBackGround(
  DC: {$ifndef CLX}HDC{$else}QPixmapH{$endif CLX}; R: TRect);
var
  Bmp,
  CurBmpBak: TBitmap;
  LocalBmp: Boolean;
  PixelFormat: TPixelFormat;
  RWidth,
  RHeight: Integer;
  Rgn: HRGN;
  PictureBkOptions,
  BkFormBkOptions,
  GlassBkOptions: TFCBackgroundOptions;
  ScrollInfoH,
  ScrollInfoV: TScrollInfo;
  DrawR: TRect;
begin
    if IsActive
    then
    begin
      if IsRectEmpty(R) then
        R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight);
      DrawR := R;

      if IsScrollBarVisible(Control, TWinControl(Control).Handle, sbHorizontal) then
      begin
        ScrollInfoH.cbSize := SizeOf(ScrollInfoH);
        ScrollInfoH.fMask  := SIF_POS;
        GetScrollInfo(TWinControl(Control).Handle, SB_HORZ, ScrollInfoH);
        OffsetRect(DrawR, ScrollInfoH.nPos, 0);
      end;
      if IsScrollBarVisible(Control, TWinControl(Control).Handle, sbVertical) then
      begin
        ScrollInfoV.cbSize := SizeOf(ScrollInfoV);
        ScrollInfoV.fMask  := SIF_POS;
        GetScrollInfo(TWinControl(Control).Handle, SB_VERT, ScrollInfoV);
        OffsetRect(DrawR, 0, ScrollInfoV.nPos);
      end;

      PixelFormat := DevicePixelFormat(False);
      RWidth      := R.Right  - R.Left;
      RHeight     := R.Bottom - R.Top;
      LocalBmp    := CurBmp = nil;

      if not LocalBmp then
      begin
        Rgn := CreateRectRgn(0, 0, Control.Width, Control.Height);
        try
          LocalBmp :=
            GetWindowRgn((Control as TWinControl).Handle, Rgn) <> NULLREGION;
        finally
          DeleteObject(Rgn);
        end;
      end;

      CurBmpBak := CurBmp;
      try
        if not LocalBmp
        then
        begin
          Bmp         := CurBmp;
          PixelFormat := Bmp.PixelFormat;
        end
        else
        begin
          Bmp    := TBitmap.Create;
          CurBmp := Bmp;
          AdjustBmpForTransition(Bmp, 0, RWidth, RHeight, PixelFormat);
          SetWindowOrgEx(Bmp.Canvas.Handle, DrawR.Left, DrawR.Top, nil);
          Bmp.Canvas.Lock;
        end;

        try
          if PictureActive
          then PictureBkOptions := GetParentPicture
          else PictureBkOptions := nil;
          if BkFormActive
          then BkFormBkOptions  := GetParentBkgrndForm
          else BkFormBkOptions  := nil;
          if GlassActive
          then GlassBkOptions   := GetParentGlass
          else GlassBkOptions   := nil;

          if GlassActive and (GlassBkOptions.GlassTranslucencyToUse = 0)
          then
          begin
            Bmp.Canvas.Brush.Color := GlassBkOptions.GlassColor;
            Bmp.Canvas.FillRect(DrawR);
          end
          else
          begin
            if XRayActive(PictureBkOptions, DrawR)
            then DrawXRay(Self, Bmp, R, DrawR, RWidth, RHeight, PixelFormat)
            else
            begin
              if BkFormActive
              then DrawBkgrndForm(BkFormBkOptions, Control, Bmp, R, DrawR, RWidth, RHeight, PixelFormat)
              else
              begin
                if PictureActive
                then DrawStandardBackground(
                       TFCControl(PictureBkOptions.Control), Bmp.Canvas.Handle,
                       DrawR)
                else DrawStandardBackground(TFCControl(Control),
                       Bmp.Canvas.Handle, DrawR);
              end;
            end;
            if PictureActive then
              DrawPicture(PictureBkOptions, Bmp, DrawR, Control);

            if GlassActive and (GlassBkOptions.GlassTranslucencyToUse < 255) then
              BlendBkgrnd(GlassBkOptions, Bmp, LocalBmp, DrawR, RWidth, RHeight, PixelFormat);
          end;

          if LocalBmp then
            BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
              Bmp.Canvas.Handle, DrawR.Left, DrawR.Top, cmSrcCopy);
        finally
          if LocalBmp then
          begin
            Bmp.Canvas.Unlock;
            Bmp.Free;
          end;
        end;
      finally
        CurBmp := CurBmpBak;
      end;
    end
    else DrawStandardBackground(TFCControl(Control), DC, R);
end;

{$ifdef D7UP}
var
  OldDrawThemeParentBackground:
    function(hwnd: HWND; hdc: HDC; prc: PRECT): HRESULT; stdcall;

function BEDrawThemeParentBackground(hwnd: HWND; hdc: HDC;
  prc: PRECT): HRESULT; stdcall;
begin
  BEDrawParentBackgroundList.Add(Pointer(GetParent(hwnd)));
  try
    Result := OldDrawThemeParentBackground(hwnd, hdc, prc);
  finally
    BEDrawParentBackgroundList.Delete(BEDrawParentBackgroundList.Count-1);
  end;
end;

procedure ThemesSupport;
begin
  ThemeServices;
  if Assigned(DrawThemeParentBackground) then
  begin
    OldDrawThemeParentBackground := DrawThemeParentBackground;
    DrawThemeParentBackground    := BEDrawThemeParentBackground;
    BEDrawParentBackgroundList   := TList.Create;
  end;
end;

function BEParentBackgroundPainted(Handle: HWND): Boolean;
begin
  Result :=
    (BEDrawParentBackgroundList <> nil)    and
    (BEDrawParentBackgroundList.Count > 0) and
    (BEDrawParentBackgroundList.Items[BEDrawParentBackgroundList.Count-1] = Pointer(Handle));
end;
{$endif D7UP}

{$ifdef D7UP}
initialization
  ThemesSupport;

finalization
  BEDrawParentBackgroundList.Free;
{$endif D7UP}

end.