[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    Once again, the dcr is attached...

    (*
    TTransparentGroupBox - Eddie Shipman

     TGroupBox that is transparent and allows colored bevels.

     Added two properties:
    ****************************************************************************
    ***
     Property: - BevelShadowColor-

        This is the color of the Bevel's Shadow, Default clBtnShadow.
        Change this color to change the color of the Bevel's Shadow.

    ****************************************************************************
    ***
     Property:  BevelHighlightColor-

        This is the color of the Bevel's Highlight, Default clBtnHighlight.
        Change this color to change the color of the Bevel's Highlight.

    ****************************************************************************
    ***
    12/22/97 - Added DrawFrame procedure to correct the way the frame
                   is drawn to let background actually show thorugh transparent
                   text., {ES}

    *)
    unit TransparentGroupBox;

    interface

    uses
      Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
      ExtCtrls, StdCtrls;

    type
      TTransparentGroupBox = class(TGroupBox)
      private
        { Private declarations }
        FBevelLowColor: TColor;
        FBevelHiColor: TColor;
        procedure SetBvlLowColor(Value: TColor);
        procedure SetBvlHiColor(Value: TColor);
        Procedure WMEraseBkGnd(Var Message:TWMEraseBkGnd); Message WM_EraseBkGnd;
        Procedure WMMove(Var Message:TWMMove); Message WM_Move;
      protected
        { Protected declarations }
        Procedure CreateParams(Var Params:TCreateParams); Override;
        Procedure Paint; Override;
        Procedure SetParent(AParent:TWinControl); Override;
        procedure DrawFrame(Rect:TRect);
      public
        { Public declarations }
        Constructor Create(AOwner:TComponent); Override;
        Procedure Invalidate; Override;
      published
        { Published declarations }
        property BevelShadowColor:TColor    read FBevelLowColor
                                           write SetBvlLowColor;
        property BevelHighlightColor:TColor read FBevelHiColor
                                           write SetBvlHiColor;
      end;

    procedure Register;

    implementation

    procedure Register;
    begin
      RegisterComponents('Standard', [TTransparentGroupBox]);
    end;

    constructor TTransparentGroupBox.Create (AOwner: TComponent);
    Begin
      Inherited Create(AOwner);
      ControlStyle:= ControlStyle - [csOpaque];
      FBevelLowColor := clBtnShadow;
      FBevelHiColor := clBtnHighlight;
    End;

    Procedure TTransparentGroupBox.CreateParams(Var Params:TCreateParams);
    Begin
      inherited CreateParams (Params);
      Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
    End;

    Procedure TTransparentGroupBox.Paint;
    var
      H: Integer;
      R: TRect;
    begin
      with Canvas do
      begin
        Font := Self.Font;
        H := TextHeight('0');
        R := Rect(0, H div 2 - 1, Width, Height);
        if Ctl3D then
        begin
          DrawFrame(R);
        end else
        begin
          Brush.Color := clWindowFrame;
          FrameRect(R);
        end;
        if Text <> '' then
        begin
          R := Rect(8, 0, 0, H);
          DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or
    DT_SINGLELINE or
            DT_CALCRECT);
          if Ctl3D then
            Brush.Style:= bsClear
          else
            Brush.Color := Color;
          DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or
    DT_SINGLELINE);
        end;
      end;
    End;

    Procedure TTransparentGroupBox.WMEraseBkGnd(Var Message:TWMEraseBkGnd);
    Begin
      Repaint;
    End;

    Procedure TTransparentGroupBox.SetParent(AParent:TWinControl);
    Begin
      Inherited SetParent(AParent);
      If Parent <> Nil then
        SetWindowLong(Parent.Handle, GWL_STYLE,
           GetWindowLong(Parent.Handle, GWL_STYLE)
              And Not WS_ClipChildren);
    End;

    Procedure TTransparentGroupBox.Invalidate;
    Var
      Rect :TRect;
    Begin
      Rect:= BoundsRect;
      If (Parent <> Nil) and Parent.HandleAllocated then
        InvalidateRect(Parent.Handle, @Rect, True)
      Else
        Inherited Invalidate;
    End;

    Procedure TTransparentGroupBox.WMMove(Var Message:TWMMove);
    Begin
      Invalidate;
    End;

    procedure TTransparentGroupBox.SetBvlLowColor(Value: TColor);
    begin
      if FBevelLowColor <> Value then
        FBevelLowColor := Value;
      Invalidate;
    end;

    procedure TTransparentGroupBox.SetBvlHiColor(Value: TColor);
    begin
      if FBevelHiColor <> Value then
        FBevelHiColor := Value;
      Invalidate;
    end;

    procedure TTransparentGroupBox.DrawFrame(Rect: TRect);
    var
      CaptionLength: Integer;
    begin
      with Canvas do
      begin
        Inc(Rect.Left);
        Inc(Rect.Top);
        Dec(Rect.Right);
        Dec(Rect.Bottom);
        CaptionLength := TextWidth(Text);
        Pen.Color := FBevelHiColor;
        MoveTo(Rect.Left, Rect.Top);
        LineTo(6,Rect.Top);
        MoveTo(8+CaptionLength+2, Rect.Top);
        LineTo(Rect.Right,Rect.Top);
        LineTo(Rect.Right,Rect.Bottom);
        LineTo(Rect.Left,Rect.Bottom);
        LineTo(Rect.Left, Rect.Top);
        OffsetRect(Rect, -1, -1);
        Pen.Color := FBevelLowColor;
        MoveTo(Rect.Left, Rect.Top);
        LineTo(6,Rect.Top);
        MoveTo(8+CaptionLength+2, Rect.Top);
        LineTo(Rect.Right,Rect.Top);
        LineTo(Rect.Right,Rect.Bottom);
        LineTo(Rect.Left,Rect.Bottom);
        LineTo(Rect.Left, Rect.Top);
      end;
    end;

    end.

    { --------------------------- TransparentGroupbox.dcr ------------------------------
    Content-Transfer-Encoding: base64
    { cut this out, and save to a file .. then use a base64 processor to create
      TransparentGroupbox.dcr  .. there is one in SWAG that works fine !}

    AAAAACAAAAD//wAA//8AAAAAAAAAAAAAAAAAAAAAAACIAQAASAAAAP//AgBUAFQAUgBBAE4AUwBQ
    AEEAUgBFAE4AVABHAFIATwBVAFAAQgBPAFgAAAAAAAAAAAAQEAkEAAAAAAAAAAAoAAAAGAAAABgA
    AAABAAQAAAAAACABAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAA
    AICAgADAwMAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////ADMzMzMzMzMzMzMzMzMzMzMzMzMz
    MzMzMzAAAAAAAAAAAAAAAzDMzMzMzMzMzMzMAzDMzMzMzMzMzMzMAzDMzd3d3d3d3d3cAzDMXFVV
    VVVVVVXSAzDMXczMzMzMzCXSAzDMXczMzMzMIiXSAzDvXe/v7+8iIiXSAzD+Xf7+/v7+IiXSAzDv
    Xe/v7+/v7yXSAzD+Xf7+/v7+/vXSAzDvXe/v7+/v7+XSAzD+Xf74jv7+/vXeAzDvXe+PuO/v7+Xf
    AzD+Xf4L+P7+/vXeAzDvXeDoDw8P7+XfAzD+XdDQ3Q0N3d7eAzDvVVAAUFBVVVXvAzD+/v4O8P7+
    /v7+AzAAAAAAAAAAAAAAAzMzMzMzMzMzMzMzMzMzMzMzMzMzMzMzMw==

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]