tebkgrnd.pas

delphi2007界面效果控件源码

  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);
    SaveTEXPRenderDisabled := TEXPRenderDisabled;
    TEXPRenderDisabled     := True;
    try
      RenderWindowToDC(BkForm.Handle, 0, BkForm, Bmp.Canvas.Handle, RAux,
        True, True, False, True);
    finally
      TEXPRenderDisabled := SaveTEXPRenderDisabled;
      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(Pic: TGraphic; PictureMode: TFCPictureMode;
  PictureTranspColor: TColor; PicCtrl: TWinControl; Bmp: TBitmap; R: TRect;
  Margin: Word; Ctrl: TControl);

  procedure TileBitmap(Pic: TGraphic; 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);
        Inc(yPos, Pic.Height);
      end;
      Inc(xPos, Pic.Width);
    end;
  end;

  procedure ZoomBitmap(Pic: TGraphic; Bmp: TBitmap; PicRect, R: TRect);
  var
    FullPicRect: TRect;
    Ratio,
    ZoomLevel: Double;
    NewSize,
    aux: Integer;
  begin
    FullPicRect := PicRect;
    Ratio := Pic.Width / Pic.Height;
    if Ratio > ((PicRect.Right - PicRect.Left) / (PicRect.Bottom - PicRect.Top))
    then // Zoomed picture is wider than the target canvas
    begin
      ZoomLevel := (PicRect.Bottom - PicRect.Top) / Pic.Height;
      NewSize   := Ceil(Pic.Width * ZoomLevel);
      aux       := (NewSize - (FullPicRect.Right - FullPicRect.Left)) div 2;
      FullPicRect.Left  := FullPicRect.Left - aux;
      FullPicRect.Right :=
        FullPicRect.Right + (NewSize - (FullPicRect.Right - FullPicRect.Left));
    end
    else // Zoomed picture is taller than the target canvas
    begin
      ZoomLevel := (PicRect.Right - PicRect.Left) / Pic.Width;
      NewSize   := Ceil(Pic.Height * ZoomLevel);
      aux       := (NewSize - (FullPicRect.Bottom - FullPicRect.Top)) div 2;
      FullPicRect.Top    := FullPicRect.Top - aux;
      FullPicRect.Bottom :=
        FullPicRect.Bottom + (NewSize - (FullPicRect.Bottom - FullPicRect.Top));
    end;
    Bmp.Canvas.StretchDraw(FullPicRect, Pic);
  end;

var
  aux,
  DrawRect,
  PicRect: TRect;
  SaveClipRgn: HRgn;
  UseClipRgn,
  ExistsClipRgn: Boolean;
begin
  if Assigned(Ctrl) and Assigned(PicCtrl)
  then
  begin
    PicRect := PictureRect(Pic, PictureMode, Margin, Ctrl, PicCtrl, DrawRect);

    IntersectRect(aux, DrawRect, R);
    if IsRectEmpty(aux) then
      exit;
  end
  else PicRect := R;

  if IsRectEmpty(PicRect) then
    exit;

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

  SaveClipRgn   := 0;
  ExistsClipRgn := False;
  UseClipRgn :=
    (Margin <> 0) and
    (PictureMode in [fcpmCenter, fcpmTile, fcpmZoom, fcpmTopLeft]);
  if UseClipRgn then
  begin
    // Remember current clipping region
    SaveClipRgn   := CreateRectRgn(0,0,0,0);
    ExistsClipRgn := GetClipRgn(Bmp.Canvas.Handle, SaveClipRgn) = 1;
  end;
  try
    if UseClipRgn then
    begin
      IntersectClipRect(Bmp.Canvas.Handle, DrawRect.Left, DrawRect.Top,
        DrawRect.Right, DrawRect.Bottom);
    end;

    case PictureMode of
      fcpmCenter,
      fcpmTopLeft      : Bmp.Canvas.Draw(PicRect.Left, PicRect.Top, Pic);
      fcpmCenterStretch: Bmp.Canvas.StretchDraw(PicRect, Pic);
      fcpmStretch      : Bmp.Canvas.StretchDraw(PicRect, Pic);
      fcpmTile         : TileBitmap(Pic, Bmp, PicRect, R);
      fcpmZoom         : ZoomBitmap(Pic, Bmp, PicRect, R);
    end;
  finally
    if UseClipRgn then
    begin
      if ExistsClipRgn
      then SelectClipRgn(Bmp.Canvas.Handle, SaveClipRgn)
      else SelectClipRgn(Bmp.Canvas.Handle, 0);
      DeleteObject(SaveClipRgn);
    end;
  end;
end;

function TEGetPictureModeDesc(PictureMode: TFCPictureMode): String;
begin
  Result := '';
  case PictureMode of
    fcpmCenter       : Result := 'Center';
    fcpmCenterStretch: Result := 'Center stretch';
    fcpmStretch      : Result := 'Stretch';
    fcpmTile         : Result := 'Tile';
    fcpmZoom         : Result := 'Zoom';
    fcpmTopLeft      : Result := 'Top left';
  end;
end;

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

      BrushAlign := ControlClientToScreen(BkOptions.Control, R.TopLeft);

      ParentControl := BkOptions.Control;
      while ParentControl.Parent <> nil do
        ParentControl := ParentControl.Parent;

      Dec(BrushAlign.x, ParentControl.Left);
      Dec(BrushAlign.y, ParentControl.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;
      BrushBmp.Canvas.Unlock;
    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;
  ThemesDisabled: Boolean);
var
  Brush: HBrush;
begin
  {$ifdef D7UP}
  with ThemeServices do
  begin
    if(not ThemesDisabled) and 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: HDC; DstBmp: TBitmap; R: TRect);
var
  Bmp: TBitmap;
  LocalBmp: Boolean;
  PixelFormat: TPixelFormat;
  RWidth,
  RHeight: Integer;
  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    :=
      (
        (DstBmp = nil) or
        (DstBmp.PixelFormat = pfDevice)
      ); {and
      (
        (TECurBmp = nil)                  or
        (TECurBmp.PixelFormat = pfDevice) or
        (TECurBmp.Canvas.Handle <> DC)    or
        (GlassActive and ControlClientAreaHasRegion(TWinControl(Control)))
      );}

    if not LocalBmp
    then
    begin
      Bmp := DstBmp;
      Bmp.Canvas.Lock;
//        if DstBmp <> nil
//        then Bmp := DstBmp
//        else Bmp := TECurBmp;
      PixelFormat := Bmp.PixelFormat;
    end
    else
    begin
      Bmp := TBitmap.Create;
//          TECurBmp := Bmp;
      Bmp.Canvas.Lock;
      AdjustBmpForTransition(Bmp, 0, RWidth, RHeight, PixelFormat);
      SetWindowOrgEx(Bmp.Canvas.Handle, DrawR.Left, DrawR.Top, nil);
    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, FThemesDisabled)
            else DrawStandardBackground(TFCControl(Control),
                   Bmp.Canvas.Handle, DrawR, FThemesDisabled);
          end;
        end;
        if PictureActive then
          DrawPicture(PictureBkOptions.Picture.Graphic,
            PictureBkOptions.PictureMode, PictureBkOptions.PictureTranspColor,
            TWinControl(PictureBkOptions.Control), Bmp, DrawR, 0, Control);

        if GlassActive 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
      Bmp.Canvas.Unlock;
      if LocalBmp then
        Bmp.Free;
    end;
  end
  else DrawStandardBackground(TFCControl(Control), DC, R, FThemesDisabled);
end;

{$ifdef D7UP}
procedure TFCBackgroundOptions.SetThemesDisabled(const Value: Boolean);
begin
  if FThemesDisabled <> Value then
  begin
    FThemesDisabled := Value;
    Changed;
  end;
end;

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;

{$ifndef NoVCL}
initialization
  ThemesSupport;

finalization
  BEDrawParentBackgroundList.Free;
{$endif NoVCL}
{$endif D7UP}

end.