grabbar.pas

动态提示控件

{$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }

{------------------------------------------------------------------------------}
{ TdfsGrabBar v1.16                                                            }
{------------------------------------------------------------------------------}
{ A grab bar, or splitter, to allow two windows to be resized simultaneously.  }
{                                                                              }
{ Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
{                                                                              }
{ Copyright:                                                                   }
{ All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
{ Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
{ property of the author.                                                      }
{                                                                              }
{ Distribution Rights:                                                         }
{ You are granted a non-exlusive, royalty-free right to produce and distribute }
{ compiled binary files (executables, DLLs, etc.) that are built with any of   }
{ the DFS source code unless specifically stated otherwise.                    }
{ You are further granted permission to redistribute any of the DFS source     }
{ code in source code form, provided that the original archive as found on the }
{ DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
{ example, if you create a descendant of TDFSColorButton, you must include in  }
{ the distribution package the colorbtn.zip file in the exact form that you    }
{ downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
{                                                                              }
{ Restrictions:                                                                }
{ Without the express written consent of the author, you may not:              }
{   * Distribute modified versions of any DFS source code by itself. You must  }
{     include the original archive as you found it at the DFS site.            }
{   * Sell or lease any portion of DFS source code. You are, of course, free   }
{     to sell any of your own original code that works with, enhances, etc.    }
{     DFS source code.                                                         }
{   * Distribute DFS source code for profit.                                   }
{                                                                              }
{ Warranty:                                                                    }
{ There is absolutely no warranty of any kind whatsoever with any of the DFS   }
{ source code (hereafter "software"). The software is provided to you "AS-IS", }
{ and all risks and losses associated with it's use are assumed by you. In no  }
{ event shall the author of the softare, Bradley D. Stowers, be held           }
{ accountable for any damages or losses that may occur from use or misuse of   }
{ the software.                                                                }
{                                                                              }
{ Support:                                                                     }
{ Support is provided via the DFS Support Forum, which is a web-based message  }
{ system.  You can find it at http://www.delphifreestuff.com/discus/           }
{ All DFS source code is provided free of charge. As such, I can not guarantee }
{ any support whatsoever. While I do try to answer all questions that I        }
{ receive, and address all problems that are reported to me, you must          }
{ understand that I simply can not guarantee that this will always be so.      }
{                                                                              }
{ Clarifications:                                                              }
{ If you need any further information, please feel free to contact me directly.}
{ This agreement can be found online at my site in the "Miscellaneous" section.}
{------------------------------------------------------------------------------}
{ The lateset version of my components are always available on the web at:     }
{   http://www.delphifreestuff.com/                                            }
{ See GrabBar.txt for notes, known issues, and revision history.               }
{------------------------------------------------------------------------------}
{ Date last modified:  June 28, 2001                                           }
{------------------------------------------------------------------------------}

unit GrabBar;

interface

{$IFDEF DFS_WIN32}
  {$R GrabBar.r32}
{$ELSE}
  {$R GrabBar.r16}
{$ENDIF}

uses
  SysUtils, WinTypes, WinProcs, Messages, Forms, Classes, Graphics, Controls,
  Dialogs;


const
  { This shuts up C++Builder 3 about the redefiniton being different. There
    seems to be no equivalent in C1.  Sorry. }
  {$IFDEF DFS_CPPB_3_UP}
  {$EXTERNALSYM DFS_COMPONENT_VERSION}
  {$ENDIF}
  DFS_COMPONENT_VERSION = 'TdfsGrabBar v1.16';

type
  TdfsGrabBarStyle = (gbHorizontal, gbVertical);

  TdfsGrabBar = class(TCustomControl)
  private
    { Property Variables }
    FBorderStyle: TBorderStyle;
    FStyle: TdfsGrabBarStyle;
    FWindowA,
    FWindowB: TWinControl;
    FWindowAMinSize : integer;    { 0 or negative value = no minimum }
    FWindowBMinSize : integer;
    FDragUpdate: boolean;

    { Event Variables }
    FOnMove: TNotifyEvent;

    { Internal Variables }
    LastRect: TRect;
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    FDragging: boolean;
    FSettingBounds:Boolean;

    { Utility functions }
    procedure HookParent;
    procedure UnhookParent;
    procedure HookWndProc(var Message: TMessage);

    function BarRect(APoint: TPoint): TRect;
    function ClientToParent(APoint: TPoint): TPoint;
    procedure InvertedRect(R: TRect; InvertLast: boolean);
    procedure MoveWindows;
    procedure ResizeBar;

    { Message response methods }
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure WMMove(var Msg: TWMMove); message WM_MOVE;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    { Property methods }
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetStyle(Value: TdfsGrabBarStyle);
    function GetThickness: Integer;
    procedure SetThickness(Value: Integer);
    procedure SetWindowA(Value: TWinControl);
    procedure SetWindowB(Value: TWinControl);
    function GetVersion: string;
    procedure SetVersion(const Val: string);

    { Overriden methods }
    procedure SetParent(Value: TWinControl); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
       override;
    procedure Notification(AComponent: TComponent; Operation: TOperation);
       override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    { Properties }
    property Version: string
       read GetVersion
       write SetVersion
       stored FALSE;
    property BorderStyle: TBorderStyle
       read FBorderStyle
       write SetBorderStyle
       default bsSingle;
    property DragUpdate: boolean
       read FDragUpdate
       write FDragUpdate
       default FALSE;
    property Style: TdfsGrabBarStyle
       read FStyle
       write SetStyle
       default gbHorizontal;
    property Thickness: integer
       read GetThickness
       write SetThickness;
    property WindowA: TWinControl
       read FWindowA
       write SetWindowA;
    property WindowAMinSize: integer
       read FWindowAMinSize
       write FWindowAMinSize;
    property WindowB: TWinControl
       read FWindowB
       write SetWindowB;
    property WindowBMinSize: integer
       read FWindowBMinSize
       write FWindowBMinSize;

    { Events }
    property OnMove: TNotifyEvent
       read FOnMove
       write FOnMove;

    { Publish Inherited Protected Properties }
    property Color;
    property Ctl3D;
    property Cursor
       default crVSplit;
    property Hint;
    property ParentColor;
    property ParentCtl3D;
    property ParentShowHint;
    property ShowHint;
    property Visible;

    { Publish Inherited Protected Events }
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

implementation

uses
  ExtCtrls;


{ Note that the "hook" is not installed here.  Parent is not valid in the }
{ constructor.  See SetParent.                                            }
constructor TdfsGrabBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { Initialize variables }
  FSettingBounds := FALSE;
  FDragging := FALSE;
  FDragUpdate := FALSE;
  NewWndProc := NIL;
  OldWndProc := NIL;
  SetRectEmpty(LastRect);
  { Set Defaults }
  FBorderStyle := bsSingle;
  FStyle := gbHorizontal;
  Cursor := crVSplit;
  Thickness := 4;
end;

destructor TdfsGrabBar.Destroy;
begin
  if FDragging then { Remove the clipping of the mouse cursor }
    ClipCursor(NIL);
  { Always make sure that the hook is removed. }
  UnhookParent;
  inherited Destroy;
end;

{ This procedure is used to get the parent's window procedure, save it,      }
{ and replace it with our own.  This allows see all of the parent's messages }
{ before it does.                                                            }
procedure TdfsGrabBar.HookParent;
begin
  { If there is no parent, we can't hook it. }
  if Parent = NIL then exit;
  { Get the old window procedure via API call and store it. }
  OldWndProc := TFarProc(GetWindowLong(Parent.Handle, GWL_WNDPROC));
  { Convert our object method into something Windows knows how to call }
  NewWndProc := MakeObjectInstance(HookWndProc);
  { Install it as the new Parent window procedure }
  SetWindowLong(Parent.Handle, GWL_WNDPROC, LongInt(NewWndProc));
end;

{ Remove our window function and reinstall the original. }
procedure TdfsGrabBar.UnhookParent;
begin
  { We must have a parent, and we must have already hooked it. }
  if (Parent <> NIL) and assigned(OldWndProc) then
    { Set back to original window procedure }
    SetWindowLong(Parent.Handle, GWL_WNDPROC, LongInt(OldWndProc));
  { If we have created a window procedure via MakeObjectInstance, }
  { it must be disposed of.                                       }
  if assigned(NewWndProc) then
    FreeObjectInstance(NewWndProc);
  { Reset variables to NIL }
  NewWndProc := NIL;
  OldWndProc := NIL;
end;

{ The window procedure that is installed into our parent. }
procedure TdfsGrabBar.HookWndProc(var Message: TMessage);
  function Max(i1, i2: integer): integer;
  begin
    if i1 > i2 then
      Result := i1
    else
      Result := i2;
  end;
begin
  { If there's no parent, something has really gone wrong. }
  if Parent = NIL then exit;
  with Message do begin
    { ALWAYS call the old window procedure so the parent can process its    }
    { messages.  Thanks to Gary Frerking for pointing me at CallWindowProc. }
    { I was trying to call the function directly, which died horribly.      }
    Result := CallWindowProc(OldWndProc, Parent.Handle, Msg, wParam, lParam);

    { If Parent gets a WM_SIZE message, it has been resized }
    if (Msg = WM_SIZE) and (wParam <> SIZE_MINIMIZED) then begin
      { We need to resize the bar so it fits in the new size, honor FWindowBMinSize }
      if FStyle = gbHorizontal then begin
        if Top > Parent.ClientHeight-FWindowBMinSize then
          Top := Parent.ClientHeight - FWindowBMinSize;
      end else
        if Left > Parent.ClientWidth-FWindowBMinSize then
          Left := Parent.ClientWidth - FWindowBMinSize;
      ResizeBar;
      { And update the positions of the windows we control }
      MoveWindows;
    end;
  end;
end;

{ Function to calculate rectangle coordinates of the bar given a point. }
function TdfsGrabBar.BarRect(APoint: TPoint): TRect;
begin
  SetRectEmpty(Result);
  if Parent = nil then exit;
  if FStyle = gbHorizontal then
    Result := Bounds(0, APoint.Y - (Thickness div 2),
                     Parent.ClientWidth, Thickness)
  else
    Result := Bounds(APoint.X - (Thickness div 2), 0,
                     Thickness, Parent.ClientHeight);
end;

{ Convert from our client coordinates to parent's client coordinates. }
function TdfsGrabBar.ClientToParent(APoint: TPoint): TPoint;
begin
  if Parent = NIL then
    Result := ClientToScreen(APoint)
  else begin
    Result := ClientToScreen(APoint);
    Result := Parent.ScreenToClient(Result);
  end;
end;

{ Draw an inverted rectangle on the parent to indicate where the bar }
{ will be when it is released.                                       }
procedure TdfsGrabBar.InvertedRect(R: TRect; InvertLast: boolean);
var
  aDC: hDC;
begin
  if Parent = nil then exit;
  { Get the parent's device context (something we can draw on).  Flags }
  { indicate that we want to be able to draw anywhere on the parent,   }
  { regardless of what it's child windows have to say about it.  Also  }
  { speed it up a bit.                                                 }
  aDC := GetDCEx(Parent.Handle, 0, DCX_PARENTCLIP or DCX_CACHE);
  { Invert the last rectange we drew to remove it. }
  { Inverted + Inverted = NOT Inverted.            }
  if InvertLast and not IsRectEmpty(LastRect) then
    InvertRect(aDC, LastRect);
  { Draw the new rectangle }
  InvertRect(aDC, R);
  { Release the DC when done with it or very bad things will happen. }
  ReleaseDC(Parent.Handle, aDC);
end;

{ Reposition the windows we are responsible for. }
procedure TdfsGrabBar.MoveWindows;
  { Move the top or left window by setting its height or width }
  procedure MoveWindowA;
  begin
    if FStyle = gbHorizontal then
      FWindowA.Height := Top - FWindowA.Top
    else
      FWindowA.Width := Left - FWindowA.Left;
  end;

  { Move the bottom or right window by recalculating its Top or Left }
  procedure MoveWindowB;
  var
    X: integer;
  begin
    if FStyle = gbHorizontal then begin
      X := Top + Thickness;
      with FWindowB do
        SetBounds(Left, X, Width, Height + Top - X);
    end else begin
      X := Left + Thickness;
      with FWindowB do
        SetBounds(X, Top, Width + (Left - X), Height);
    end;
  end;
var
  newSize: integer;
begin
  if Parent = NIL then exit;
  { Disable parent aligning until we move both windows.  If we don't, the    }
  { parent will try to reposition aligned controls when they are moved.      }
  { This produces scrollbars in some cases and annoying flicker most always. }
  Parent.DisableAlign;

  { Added by Beth Weiss, 2/12/97:                                            }
  { If the user has attempted to make one of the window's too small,         }