unit PCFormRoll;

interface

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

type
  EError = class(Exception);

  TRollerMode = ( mdRollDown, mdRollUp );
  TRollerNotifyEvent = procedure ( Sender: TObject; mode: TRollerMode ) of object;

  TPCRoller = class(TComponent)
  private
    { Private declarations }
    DefWinProc: TFarProc;
    DefWinProcInstance: Pointer;
    FEnabled: Boolean;
    FOnRoller: TRollerNotifyEvent;
//    FOnFormDestroy: TNotifyEvent;
    FRoller: Boolean;
    FVisible: Boolean;
    FRemainHeight: Integer;

    ButtonRect: TRect;
    DrawPushed: Boolean;
    Pushed: Boolean;
    RestoreWndProc: Boolean;
    rgn: HRGN;
    OwnerHandle: THandle;

    procedure CalcArea;
    function  GetShortHeight: Integer;
    function  HookMainWndProc( var Msg: TMessage ): Boolean;
    procedure HookWndProc;
    procedure UnHookWndProc;
//    procedure OnRollerDestroy( Sender: TObject );
    procedure PaintRollerButton;
    procedure Rollup;
    procedure SetEnabled( Val: Boolean );
    procedure SetRoller( Val: Boolean );
    procedure SetVisible( Val: Boolean );
    procedure WinProc(var Msg: TMessage);
    procedure SetRemainHeight( Val: Integer );

  public
    { Public declarations }
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Enabled: Boolean read FEnabled write SetEnabled;
    property RemainHeight: Integer read FRemainHeight write SetRemainHeight;
    property Roller: Boolean read FRoller write SetRoller default False;
    property Visible: Boolean read FVisible write SetVisible default True;
    property OnRoller: TRollerNotifyEvent read FOnRoller write FOnRoller;
  end;

var
  si: UINT;

implementation

const
  WM_ROLLREDRAW         = WM_USER + 2000;
  WM_PAINTEDGE          = WM_USER + 2001;
  WM_RECREATE           = WM_USER + 2002;
  WM_ROLLER_BUTTON_DOWN = WM_USER + 2003;


constructor TPCRoller.Create(Owner: TComponent);
begin
  inherited;
  FRoller := False;
  FVisible := True;
  DrawPushed := False;
  Pushed := False;
  FRemainHeight := 0;
//  if not (csDesigning in ComponentState) then
//  begin
    Application.HookMainWindow( HookMainWndProc );
//    FOnFormDestroy := TForm(Owner).OnDestroy;
//    TForm(Owner).OnDestroy := OnRollerDestroy;
//  end;
  HookWndProc;
end;

destructor TPCRoller.Destroy;
//var
//  proc: TNotifyEvent;
begin
//  if not (csDesigning in ComponentState) then
    Application.UnhookMainWindow( HookMainWndProc );
//  proc := OnRollerDestroy;
//  if Assigned(Owner) and (@proc = @TForm(Owner).OnDestroy) then
//    TForm(Owner).OnDestroy := FOnFormDestroy;
  UnHookWndProc;
  inherited;
  if csDesigning in ComponentState then
    SetWindowPos( OwnerHandle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_DRAWFRAME or
                  SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE );
//    ReDrawWindow( OwnerHandle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_UPDATENOW );
end;

procedure TPCRoller.HookWndProc;
begin
  OwnerHandle := TForm(Owner).Handle;
  rgn := 0;
  if not (Owner is TForm) then
    raise EError.Create('Class of the owner is not a TForm!');
  with TForm(Owner) do
//  if not (csDesigning in ComponentState) then
  begin    
    DefWinProcInstance := MakeObjectInstance(WinProc);
    DefWinProc := Pointer(SetWindowLong(OwnerHandle, GWL_WNDPROC, Longint(DefWinProcInstance)));
    RestoreWndProc := False;
    CalcArea;
  end;
end;

procedure TPCRoller.UnHookWndProc;
begin
  if RestoreWndProc then Exit;
  RestoreWndProc := True;
//  if not (csDesigning in ComponentState) then
//  begin
    SetWindowLong( OwnerHandle, GWL_WNDPROC, Longint(DefWinProc) );
    FreeObjectInstance( DefWinProcInstance );
//  end;
  if rgn <> 0 then
    DeleteObject( rgn );
  rgn := 0;
end;

function TPCRoller.HookMainWndProc( var Msg: TMessage ): Boolean;
begin
  Result := False;
  if Msg.Msg = WM_RECREATE then
  begin
    if Msg.lParam <> longint(Self) then exit;
    HookWndProc;
//    UpdateCaption;
  end;
end;
(* If the TPCRoller is created dynamically, it's destructor don't *)
(* be called automatically when the owner form is free. So must be *)
(* triggered the UnHookWndProc by this event .                     *)
(*
procedure TPCRoller.OnRollerDestroy( Sender: TObject );
begin
  SetWindowLong(TForm(Owner).Handle, GWL_WNDPROC, Longint(DefWinProc));
  FreeObjectInstance(DefWinProcInstance);
  RestoreWndProc := True;
  if Assigned( FOnFormDestroy ) then
    FOnFormDestroy( Sender );
end;
  *)
procedure TPCRoller.CalcArea;
var
  x1, y1, x2, y2: Integer;
  Icons: TBorderIcons;
  Style: TFormBorderStyle;
  AWidth: Integer;
  wr: TRect;
//  Style, ExStyle: UINT;
begin
//  Style := GetWindowLong( TForm(Owner).Handle, GWL_STYLE );
//  ExStyle := GetWindowLong( TForm(Owner).Handle, GWL_EXSTYLE );
  with TForm(Owner) do
  begin
    GetWindowRect( OwnerHandle, wr );
    AWidth := wr.Right - wr.Left;
    if csDesigning in ComponentState then
    begin
      Icons := [biSystemMenu, biMinimize, biMaximize];
      Style := bsSizeable;
    end
    else
    begin
      Icons := BorderIcons;
      Style := BorderStyle;
    end;
  end;
  if Style in [bsSizeToolWin, bsToolWindow] then
  begin
    if Style = bsToolWindow then
      x2 := GetSystemMetrics(SM_CXFIXEDFRAME) + 2
    else
      x2 := GetSystemMetrics(SM_CXSIZEFRAME) + 2;
    if biSystemMenu in Icons then
      Inc(x2, GetSystemMetrics(SM_CXSMSIZE) + 2);
    if Style = bsToolWindow then
      y1 := GetSystemMetrics(SM_CYFIXEDFRAME) + 2
    else
      y1 := GetSystemMetrics(SM_CYSIZEFRAME) + 2;
    y2 := y1 + GetSystemMetrics(SM_CYSMSIZE) - 4;
    x2 := AWidth - x2;
    x1 := x2 - GetSystemMetrics(SM_CXSMSIZE) + 2;
  end
  else
  begin
    if Style in [bsSingle, bsSizeable, bsDialog] then
    begin
      if Style = bsSingle then
        x2 := GetSystemMetrics(SM_CYFIXEDFRAME) + 2
      else
        x2 := GetSystemMetrics(SM_CXSIZEFRAME) + 2;
      if biSystemMenu in Icons then
      begin
        Inc(x2, GetSystemMetrics(SM_CXSIZE) + 2);
        if (Style <> bsDialog) and (Icons * [biMinimize, biMaximize] <> []) then
          Inc(x2, GetSystemMetrics(SM_CXSIZE) * 2 - 6)
        else if biHelp in Icons then
          Inc(x2, GetSystemMetrics(SM_CXSIZE) - 4);
      end;
      if Style in [bsSingle, bsDialog] then
        y1 := GetSystemMetrics(SM_CYFIXEDFRAME) + 2
      else
        y1 := GetSystemMetrics(SM_CYSIZEFRAME) + 2;
      y2 := y1 + GetSystemMetrics(SM_CYSIZE) - 4;
      x2 := AWidth - x2;
      x1 := x2 - GetSystemMetrics(SM_CXSIZE) + 2;
    end;
  end;
  SetRect( ButtonRect, x1 - AWidth, y1, x2 - AWidth, y2 );
end;

procedure TPCRoller.PaintRollerButton;
var
  h, dc: HDC;
  st: UINT;
  p: array[0..2] of TPoint;
  b: HBRUSH;
  r: HRGN;
  rect, OldRect: TRect;
  w: Integer;
  OldBmp, Bmp: HBitmap;

  procedure DrawTriangle( Up: Boolean; dd: Integer; co: Integer );
  var
    pen: HPEN;
    d, x1, x2, y1, y2: Integer;
  begin
    if DrawPushed then
      d := 1 + dd
    else
      d := 0 + dd;
    with rect do
    begin
      x1 := Left + 1 + d;
      x2 := Right - 3 + d;
      y1 := Top + d;
      y2 := Bottom + d;
    end;
    p[0].x := x1 + 3;
    p[1].x := ((x1 + x2) shr 1);
    p[2].x := p[1].x + p[1].x - p[0].x;
//    p[2].x := x2 - 3;
    if Up then
    begin
      p[0].y := ((y1 + y2) shr 1) - 2;
      p[1].y := y1 + 2;
      p[2].y := p[0].y;
    end
    else
    begin
      p[0].y := ((y1 + y2) shr 1);
      p[1].y := p[0].y + p[1].x - p[0].x;
//      p[1].y := y2 - 4;
      p[2].y := p[0].y;
    end;
    case co of
      0:
      begin
        pen := SelectObject( dc, GetStockObject( BLACK_PEN ) );
        b := SelectObject( dc, GetStockObject( BLACK_BRUSH ) );
      end;
      1:
      begin
        pen := SelectObject( dc, GetStockObject( WHITE_PEN ) );
        b := SelectObject( dc, GetStockObject( WHITE_BRUSH ) );
      end;
      else
      begin
        pen := SelectObject( dc, CreatePen( PS_SOLID, 0, GetSysColor( COLOR_BTNSHADOW ) ) );
        b := SelectObject( dc, GetStockObject( DKGRAY_BRUSH ) );
      end;
    end;
    if (Up and not FRoller) or (not Up and FRoller) then
      PolyGon( dc, p, 3 )
    else
    begin
      Inc( p[2].x );
      if Up then
        Inc( p[2].y )
      else
        Dec( p[2].y );
      PolyLine( dc, p, 3 );
      Inc( p[0].x );
      Dec( p[2].x );
      if Up then
        Inc( p[1].y )
      else
        Dec( p[1].y );
      PolyLine( dc, p, 3 );
    end;
    SelectObject( dc, b );
    if co = 2 then
      DeleteObject( SelectObject( dc, pen ) )
    else
      SelectObject( dc, pen );
  end;

begin
//  if not (csDesigning in ComponentState) then
    with TForm(Owner) do
      if not (BorderStyle = bsNone) then
      begin
        GetWindowRect( OwnerHandle, rect );
        w := rect.Right - rect.Left;
        rect.Left := ButtonRect.Left + w;
        rect.Right := ButtonRect.Right + w;
        rect.Top := ButtonRect.Top;
        rect.Bottom := ButtonRect.Bottom;
        if FVisible then
        begin
          h := GetWindowDC( OwnerHandle );
          try
            if h = 0 then Exit;
            dc := CreateCompatibleDC( h );
            try
              if dc = 0 then
                Exit;
              Bmp := CreateCompatibleBitmap( h, rect.Right - rect.Left, rect.Bottom - rect.Top );
              If Bmp = 0 then
                Exit;
              OldRect := rect;
              OffsetRect( rect, -rect.Left, -rect.Top );
              OldBmp := SelectObject( dc, Bmp );
              try
                if DrawPushed then
                  st := DFCS_PUSHED
                else
                  st := 0;
                DrawFrameControl( dc, rect, DFC_BUTTON, DFCS_BUTTONPUSH or st );
                if FEnabled then
                begin
                  DrawTriangle( True, 0, 0 );
                  DrawTriangle( False, 0, 0 );
                end
                else
                begin
                  DrawTriangle( True, 1, 1 );
                  DrawTriangle( False, 1, 1 );
                  DrawTriangle( True, 0, 2 );
                  DrawTriangle( False, 0, 2 );
                end;
                BitBlt( h, OldRect.Left, OldRect.Top, OldRect.Right - OldRect.Left,
                        OldRect.Bottom - OldRect.Top, dc, 0, 0, SRCCOPY);
              finally
                SelectObject( dc, OldBmp );
              end;
            finally
              DeleteDC( dc );
            end;
          finally
            ReleaseDC( OwnerHandle, h );
          end;
        end
        else
        begin
          r := CreateRectRgn(
            (* Get the most width of the border *)
            rect.Left - GetSystemMetrics(SM_CXSIZEFRAME),
            0,
            rect.Right,
            rect.Bottom );
          SendMessage( OwnerHandle, WM_NCPAINT, r, 0 );
          DeleteObject( r );
        end;
      end;
end;

procedure TPCRoller.SetEnabled( Val: Boolean );
begin
  if Val <> FEnabled then
  begin
    FEnabled := Val;
    PaintRollerButton;
  end;
end;

procedure TPCRoller.SetRemainHeight( Val: Integer );
begin
  if FRemainHeight <> Val then
  begin
    FRemainHeight := Val;
    if FRoller then
      RollUp;
  end;
end;

function TPCRoller.GetShortHeight: Integer;
begin
  with TForm(Owner) do
  begin
    if BorderStyle in [bsSingle, bsDialog, bsToolWindow] then
      Result := GetSystemMetrics( SM_CYCAPTION ) +
        GetSystemMetrics(SM_CYFIXEDFRAME) + 3
    else
      Result := GetSystemMetrics( SM_CYCAPTION ) +
        GetSystemMetrics(SM_CYSIZEFRAME) + 3;
  end;
  Inc( Result, FRemainHeight );
end;


procedure TPCRoller.Rollup;
var
  r: TRect;
  g: HRGN;
begin
  begin
    g := rgn;
    GetWindowRect( OwnerHandle, r );
    rgn := CreateRectRgn( 0, 0, r.Right - r.Left, GetShortHeight );
    SetWindowRgn( OwnerHandle, rgn, True );
    if g <> 0 then
      DeleteObject( g );
  end;
end;

procedure TPCRoller.SetRoller( Val: Boolean );
var
  r: TRect;
  g: HRGN;
begin
  if FEnabled and (Val <> FRoller) then
  begin
    FRoller := Val;
    if Val then
    begin
      Rollup;
      if Assigned( FOnRoller ) then FOnRoller( Self, mdRollUp );
    end
    else
    begin
      GetWindowRect( OwnerHandle, r );
      g := CreateRectRgn( 0, 0, r.Right - r.Left, GetShortHeight - 3 );
      SetWindowRgn( OwnerHandle, g, True );

      SetWindowRgn( OwnerHandle, 0, True );
      DeleteObject( g );
      if rgn <> 0 then
      begin
        DeleteObject( rgn );
        rgn := 0;
      end;
      if Assigned( FOnRoller ) then FOnRoller( Self, mdRollDown );
    end;
    PaintRollerButton;
  end;
end;

procedure TPCRoller.SetVisible( Val: Boolean );
begin
  if Val <> FVisible then
  begin
    FVisible := Val;
    CalcArea;
    if Val then
      PaintRollerButton;
  end;
end;

procedure TPCRoller.WinProc(var Msg: TMessage);
var
  h: HRGN;
  br, wr: TRect;
  dc: HDC;
  pen: HPEN;
  w: Integer;

  procedure Default;
  begin
    with Msg do
      Result := CallWindowProc(DefWinProc, OwnerHandle, Msg, wParam, lParam);
  end;

  function InArea( wr: TRect; InClient: Boolean ): Boolean;
  var
    p, pp: TPoint;
  begin
    p.x := Msg.lParamLo;
    p.y := Smallint(Msg.lParamHi);
    with TForm(Owner) do
    begin
      if InClient then
        p := ClientToScreen( p );
      Dec( p.x, Left );
      Dec( p.y, Top );
      if FormStyle = fsMDIChild then
      begin
        pp.x := 0;
        pp.y := 0;
        Windows.ClientToScreen( Application.MainForm.ClientHandle, pp );
        Dec( p.x, pp.x );
        Dec( p.y, pp.y );
      end;
    end;
    w := wr.Right - wr.Left;
    SetRect( br, ButtonRect.Left + w, ButtonRect.Top, ButtonRect.Right + w, ButtonRect.Bottom );
    Result := PtInRect( br, p );
  end;

begin
  if not FVisible then
    Default
  else
    case Msg.Msg of
      WM_SIZE://, WM_WINDOWPOSCHANGED:
      begin
        Default;
        CalcArea;
        if FRoller then
          RollUp;
      end;
      WM_MOUSEMOVE:
      begin
        if Pushed then
        begin
          GetWindowRect( OwnerHandle, wr );
          if not InArea( wr, True ) then
          begin
            if DrawPushed then
            begin
              DrawPushed := False;
              if FEnabled then
                PaintRollerButton;
            end;
          end
          else
          begin
            if not DrawPushed then
            begin
              DrawPushed := True;
              if FEnabled then
                PaintRollerButton;
            end;
          end;
          Msg.Result := 1;
        end
        else
          Default;
      end;
      WM_LBUTTONUP, WM_LBUTTONDBLCLK:
      begin
        DrawPushed := False;
        if Pushed then
        begin
          GetWindowRect( OwnerHandle, wr );
          if InArea( wr, True ) then
            Roller := not FRoller
          else if FEnabled then
            PaintRollerButton;
          Msg.Result := 1;
        end
        else
          Default;
        Pushed := False;
        ReleaseCapture;
      end;
      WM_ROLLER_BUTTON_DOWN:
      begin
        SetCapture( OwnerHandle );
        DrawPushed := True;
        Pushed := True;
        if FEnabled then
          PaintRollerButton;
        Msg.Result := 1;
      end;
      WM_NCLBUTTONDOWN, WM_NCLBUTTONDBLCLK:
      begin
        GetWindowRect( OwnerHandle, wr );
        if InArea( wr, False ) then
        begin
          SendMessage( OwnerHandle, WM_ROLLER_BUTTON_DOWN, 0, 0 );
          if Msg.Msg <> WM_NCLBUTTONDBLCLK then
            Default
          else
            Msg.Result := 1;
        end
        else
        begin
          Default;
          PaintRollerButton;
        end;
      end;
      WM_SETTINGCHANGE, WM_DISPLAYCHANGE(*, WM_WININICHANGE*):
      begin
        Default;
        CalcArea;
        if FRoller then
          Rollup;
      end;
      WM_NCACTIVATE:
      begin
        Default;
        if not TWMNCActivate(Msg).Active then
          PaintRollerButton;
      end;
      WM_NCPAINT:
      begin
        PaintRollerButton;
        dc := GetWindowDC( OwnerHandle );
        (* Don't get the width of window from the TForm's    *)
        (* property 'Width', because it is not being updated *)
        GetWindowRect( OwnerHandle, wr );
        w := wr.Right - wr.Left;
        SetRect(
          br,
          w + ButtonRect.Left,
          ButtonRect.Top,
          w + ButtonRect.Right,
          ButtonRect.Bottom );
        GetWindowRect( OwnerHandle, wr );
        h := CreateRectRgnIndirect( wr );
        try
          if SelectClipRgn( dc, Msg.wParam ) = ERROR then
            SelectClipRgn( dc, h );
          OffsetClipRgn( dc, -wr.Left, -wr.Top );
          ExcludeClipRect( dc, br.Left, br.Top, br.Right, br.Bottom );
          OffsetClipRgn( dc, wr.Left, wr.Top );
          GetClipRgn( dc, h );
          Msg.Result := CallWindowProc( DefWinProc, OwnerHandle, Msg.Msg, h, Msg.lParam )
        finally
          DeleteObject( h );
          ReleaseDC( OwnerHandle, dc );
        end;
        if TForm(Owner).FormStyle = fsMDIChild then
          PostMessage( OwnerHandle, WM_ROLLREDRAW, 0, 0 );
        if FRoller then
          PostMessage( OwnerHandle, WM_PAINTEDGE, 0, 0 );
      end;
      WM_ROLLREDRAW:
      begin
        Msg.Result := 1;
        PaintRollerButton;
      end;
      WM_SETCURSOR:
      begin
        Msg.Result := 1;
        case TWMSetCursor(Msg).HitTest of
          HTTOP,
          HTBOTTOM:      SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENS)));
          HTLEFT,
          HTRIGHT:       SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZEWE)));
          HTTOPRIGHT,
          HTBOTTOMLEFT:  SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENESW)));
          HTTOPLEFT,
          HTBOTTOMRIGHT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENWSE)));
        else
          Default;
        end;
      end;
      WM_PAINTEDGE: (* Suggestion by Trav *)
      begin
        dc := GetWindowDC( OwnerHandle );
        GetWindowRect( OwnerHandle, wr );
        wr.Right := wr.Right - wr.Left;
        wr.Left := 0;
        wr.Top  := 0;
        wr.Bottom := GetShortHeight;
        pen := SelectObject( dc, CreatePen( PS_SOLID, 0, GetSysColor( COLOR_BTNFACE ) ) );
        MoveToEx( dc, 1, wr.Bottom - 3, nil );
        LineTo( dc, wr.Right - 1, wr.Bottom - 3 );
        DeleteObject( SelectObject( dc, pen ) );
        DrawEdge( dc, wr, EDGE_RAISED, BF_LEFT or BF_BOTTOM or BF_RIGHT );
        ReleaseDC( OwnerHandle, dc );
      end;
      WM_DESTROY:
      begin
        if not (csDestroying in ComponentState) then
        begin
          UnHookWndProc;
          PostMessage( Application.Handle, WM_RECREATE, 0, Longint(Self) );
        end;
        Default;
      end;
      else
        Default;
    end;
end;

end.