home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d56 / RMCTL.ZIP / rmSplit.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-22  |  11KB  |  424 lines
  1. {================================================================================
  2. Copyright (C) 1997-2001 Mills Enterprise
  3.  
  4. Unit     : rmSplit
  5. Purpose  : Fix for original Delphi Bug.  Further enhancements included....
  6. Date     : 02-18-1999
  7. Author   : Ryan J. Mills
  8. Version  : 1.80
  9. ================================================================================}
  10.  
  11. unit rmSplit;
  12.  
  13. interface
  14.  
  15. {$I CompilerDefines.INC}
  16.  
  17. uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics,
  18.   StdCtrls;
  19.  
  20. type
  21.   NaturalNumber = 1..High(Integer);
  22.  
  23.   TCanResizeEvent = procedure(Sender: TObject; var NewSize: Integer;
  24.     var Accept: Boolean) of object;
  25.  
  26.   TResizeStyle = (rsNone, rsLine, rsUpdate, rsPattern);
  27.  
  28.   TrmSplitter = class(TGraphicControl)
  29.   private
  30.     FActiveControl: TWinControl;
  31.     FBeveled: Boolean;
  32.     FBrush: TBrush;
  33.     FControl: TControl;
  34.     FDownPos: TPoint;
  35.     FLineDC: HDC;
  36.     FLineVisible: Boolean;
  37.     FMinSize: NaturalNumber;
  38.     FMaxSize: Integer;
  39.     FNewSize: Integer;
  40.     FOldKeyDown: TKeyEvent;
  41.     FOldSize: Integer;
  42.     FPrevBrush: HBrush;
  43.     FResizeStyle: TResizeStyle;
  44.     FSplit: Integer;
  45.     FOnCanResize: TCanResizeEvent;
  46.     FOnMoved: TNotifyEvent;
  47.     FOnPaint: TNotifyEvent;
  48.     procedure AllocateLineDC;
  49.     procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
  50.     procedure DrawLine;
  51.     function FindControl: TControl;
  52.     procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  53.     procedure ReleaseLineDC;
  54.     procedure SetBeveled(Value: Boolean);
  55.     procedure UpdateControlSize;
  56.     procedure UpdateSize(X, Y: Integer);
  57.   protected
  58.     function CanResize(var NewSize: Integer): Boolean; {$ifdef D4_OR_HIGHER} reintroduce; {$endif} virtual;
  59.  
  60.     function DoCanResize(var NewSize: Integer): Boolean; virtual;
  61.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  62.       X, Y: Integer); override;
  63.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  64.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  65.       X, Y: Integer); override;
  66.     procedure Paint; override;
  67.     procedure RequestAlign; override;
  68.     procedure StopSizing; dynamic;
  69.   public
  70.     constructor Create(AOwner: TComponent); override;
  71.     destructor Destroy; override;
  72.   published
  73.     property Align default alLeft;
  74.     property Beveled: Boolean read FBeveled write SetBeveled default False;
  75.     property Color;
  76.     {$ifdef D4_OR_HIGHER}
  77.     property Constraints;
  78.     {$endif}
  79.     property MinSize: NaturalNumber read FMinSize write FMinSize default 30;
  80.     property ParentColor;
  81.     property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle
  82.       default rsPattern;
  83.     property Visible;
  84.     property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;
  85.     property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;
  86.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  87.   end;
  88.  
  89. implementation
  90.  
  91. { TrmSplitter }
  92.  
  93. type
  94.   TWinControlAccess = class(TWinControl);
  95.  
  96. constructor TrmSplitter.Create(AOwner: TComponent);
  97. begin
  98.   inherited Create(AOwner);
  99.   Align := alLeft;
  100.   Width := 3;
  101.   Cursor := crHSplit;
  102.   FMinSize := 30;
  103.   FResizeStyle := rsPattern;
  104.   FOldSize := -1;
  105. end;
  106.  
  107. destructor TrmSplitter.Destroy;
  108. begin
  109.   FBrush.Free;
  110.   inherited Destroy;
  111. end;
  112.  
  113. procedure TrmSplitter.AllocateLineDC;
  114. begin
  115.   FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
  116.     or DCX_LOCKWINDOWUPDATE);
  117.   if ResizeStyle = rsPattern then
  118.   begin
  119.     if FBrush = nil then
  120.     begin
  121.       FBrush := TBrush.Create;
  122.       FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);
  123.     end;
  124.     FPrevBrush := SelectObject(FLineDC, FBrush.Handle);
  125.   end;
  126. end;
  127.  
  128. procedure TrmSplitter.DrawLine;
  129. var
  130.   P: TPoint;
  131. begin
  132.   FLineVisible := not FLineVisible;
  133.   P := Point(Left, Top);
  134.   if Align in [alLeft, alRight] then
  135.     P.X := Left + FSplit else
  136.     P.Y := Top + FSplit;
  137.   with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);
  138. end;
  139.  
  140. procedure TrmSplitter.ReleaseLineDC;
  141. begin
  142.   if FPrevBrush <> 0 then
  143.     SelectObject(FLineDC, FPrevBrush);
  144.   ReleaseDC(Parent.Handle, FLineDC);
  145.   if FBrush <> nil then
  146.   begin
  147.     FBrush.Free;
  148.     FBrush := nil;
  149.   end;
  150. end;
  151.  
  152. function TrmSplitter.FindControl: TControl;
  153. var
  154.   P: TPoint;
  155.   I: Integer;
  156.   R: TRect;
  157. begin
  158.   Result := nil;
  159.   P := Point(Left, Top);
  160.   case Align of
  161.     alLeft: Dec(P.X);
  162.     alRight: Inc(P.X, Width);
  163.     alTop: Dec(P.Y);
  164.     alBottom: Inc(P.Y, Height);
  165.   else
  166.     Exit;
  167.   end;
  168.   for I := 0 to Parent.ControlCount - 1 do
  169.   begin
  170.     Result := Parent.Controls[I];
  171.     if Result.Visible and Result.Enabled then
  172.     begin
  173.       R := Result.BoundsRect;
  174.       if (R.Right - R.Left) = 0 then
  175.         if Align in [alTop, alLeft] then
  176.           Dec(R.Left)
  177.         else
  178.           Inc(R.Right);
  179.       if (R.Bottom - R.Top) = 0 then
  180.         if Align in [alTop, alLeft] then
  181.           Dec(R.Top)
  182.         else
  183.           Inc(R.Bottom);
  184.       if PtInRect(R, P) then Exit;
  185.     end;
  186.   end;
  187.   Result := nil;
  188. end;
  189.  
  190. procedure TrmSplitter.RequestAlign;
  191. begin
  192.   inherited RequestAlign;
  193.   if (Cursor <> crVSplit) and (Cursor <> crHSplit) then Exit;
  194.   if Align in [alBottom, alTop] then
  195.     Cursor := crVSplit
  196.   else
  197.     Cursor := crHSplit;
  198. end;
  199.  
  200. procedure TrmSplitter.Paint;
  201. const
  202.   XorColor = $00FFD8CE;
  203. var
  204.   FrameBrush: HBRUSH;
  205.   R: TRect;
  206. begin
  207.   R := ClientRect;
  208.   Canvas.Brush.Color := Color;
  209.   Canvas.FillRect(ClientRect);
  210.   if Beveled then
  211.   begin
  212.     if Align in [alLeft, alRight] then
  213.       InflateRect(R, -1, 2) else
  214.       InflateRect(R, 2, -1);
  215.     OffsetRect(R, 1, 1);
  216.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
  217.     FrameRect(Canvas.Handle, R, FrameBrush);
  218.     DeleteObject(FrameBrush);
  219.     OffsetRect(R, -2, -2);
  220.     FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
  221.     FrameRect(Canvas.Handle, R, FrameBrush);
  222.     DeleteObject(FrameBrush);
  223.   end;
  224.   if csDesigning in ComponentState then
  225.     { Draw outline }
  226.     with Canvas do
  227.     begin
  228.       Pen.Style := psDot;
  229.       Pen.Mode := pmXor;
  230.       Pen.Color := XorColor;
  231.       Brush.Style := bsClear;
  232.       Rectangle(0, 0, ClientWidth, ClientHeight);
  233.     end;
  234.   if Assigned(FOnPaint) then FOnPaint(Self);
  235. end;
  236.  
  237. function TrmSplitter.DoCanResize(var NewSize: Integer): Boolean;
  238. begin
  239.   Result := CanResize(NewSize);
  240.   if Result and (NewSize <= MinSize) then
  241.     NewSize := MinSize;
  242. end;
  243.  
  244. function TrmSplitter.CanResize(var NewSize: Integer): Boolean;
  245. begin
  246.   Result := True;
  247.   if Assigned(FOnCanResize) then FOnCanResize(Self, NewSize, Result);
  248. end;
  249.  
  250. procedure TrmSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;
  251.   X, Y: Integer);
  252. var
  253.   I: Integer;
  254. begin
  255.   inherited MouseDown(Button, Shift, X, Y);
  256.   if Button = mbLeft then
  257.   begin
  258.     FControl := FindControl;
  259.     FDownPos := Point(X, Y);
  260.     if Assigned(FControl) then
  261.     begin
  262.       if Align in [alLeft, alRight] then
  263.       begin
  264.         FMaxSize := Parent.ClientWidth - FMinSize;
  265.         for I := 0 to Parent.ControlCount - 1 do
  266.           with Parent.Controls[I] do
  267.             if Align in [alLeft, alRight] then Dec(FMaxSize, Width);
  268.         Inc(FMaxSize, FControl.Width);
  269.       end
  270.       else
  271.       begin
  272.         FMaxSize := Parent.ClientHeight - FMinSize;
  273.         for I := 0 to Parent.ControlCount - 1 do
  274.           with Parent.Controls[I] do
  275.             if Align in [alTop, alBottom] then Dec(FMaxSize, Height);
  276.         Inc(FMaxSize, FControl.Height);
  277.       end;
  278.       UpdateSize(X, Y);
  279.       AllocateLineDC;
  280.       with ValidParentForm(Self) do
  281.         if ActiveControl <> nil then
  282.         begin
  283.           FActiveControl := ActiveControl;
  284.           FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown;
  285.           TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown;
  286.         end;
  287.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  288.     end;
  289.   end;
  290. end;
  291.  
  292. procedure TrmSplitter.UpdateControlSize;
  293. begin
  294.   if FNewSize <> FOldSize then
  295.   begin
  296.     case Align of
  297.       alLeft: FControl.Width := FNewSize;
  298.       alTop: FControl.Height := FNewSize;
  299.       alRight:
  300.         begin
  301.           Parent.DisableAlign;
  302.           try
  303.             FControl.Left := FControl.Left + (FControl.Width - FNewSize);
  304.             FControl.Width := FNewSize;
  305.           finally
  306.             Parent.EnableAlign;
  307.           end;
  308.         end;
  309.       alBottom:
  310.         begin
  311.           Parent.DisableAlign;
  312.           try
  313.             FControl.Top := FControl.Top + (FControl.Height - FNewSize);
  314.             FControl.Height := FNewSize;
  315.           finally
  316.             Parent.EnableAlign;
  317.           end;
  318.         end;
  319.     end;
  320.     Update;
  321.     if Assigned(FOnMoved) then FOnMoved(Self);
  322.     FOldSize := FNewSize;
  323.   end;
  324. end;
  325.  
  326. procedure TrmSplitter.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);
  327. var
  328.   S: Integer;
  329. begin
  330.   if Align in [alLeft, alRight] then
  331.     Split := X - FDownPos.X
  332.   else
  333.     Split := Y - FDownPos.Y;
  334.   S := 0;
  335.   case Align of
  336.     alLeft: S := FControl.Width + Split;
  337.     alRight: S := FControl.Width - Split;
  338.     alTop: S := FControl.Height + Split;
  339.     alBottom: S := FControl.Height - Split;
  340.   end;
  341.   NewSize := S;
  342.   if S < FMinSize then
  343.     NewSize := FMinSize
  344.   else if S > FMaxSize then
  345.     NewSize := FMaxSize;
  346.   if S <> NewSize then
  347.   begin
  348.     if Align in [alRight, alBottom] then
  349.       S := S - NewSize else
  350.       S := NewSize - S;
  351.     Inc(Split, S);
  352.   end;
  353. end;
  354.  
  355. procedure TrmSplitter.UpdateSize(X, Y: Integer);
  356. begin
  357.   CalcSplitSize(X, Y, FNewSize, FSplit);
  358. end;
  359.  
  360. procedure TrmSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);
  361. var
  362.   NewSize, Split: Integer;
  363. begin
  364.   inherited;
  365.   if (ssLeft in Shift) and Assigned(FControl) then
  366.   begin
  367.     CalcSplitSize(X, Y, NewSize, Split);
  368.     if DoCanResize(NewSize) then
  369.     begin
  370.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  371.       FNewSize := NewSize;
  372.       FSplit := Split;
  373.       if ResizeStyle = rsUpdate then UpdateControlSize;
  374.       if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  375.     end;
  376.   end;
  377. end;
  378.  
  379. procedure TrmSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;
  380.   X, Y: Integer);
  381. begin
  382.   inherited;
  383.   if Assigned(FControl) then
  384.   begin
  385.     if ResizeStyle in [rsLine, rsPattern] then DrawLine;
  386.     UpdateControlSize;
  387.     StopSizing;
  388.   end;
  389. end;
  390.  
  391. procedure TrmSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  392. begin
  393.   if Key = VK_ESCAPE then
  394.     StopSizing
  395.   else if Assigned(FOldKeyDown) then
  396.     FOldKeyDown(Sender, Key, Shift);
  397. end;
  398.  
  399. procedure TrmSplitter.SetBeveled(Value: Boolean);
  400. begin
  401.   FBeveled := Value;
  402.   Repaint;
  403. end;
  404.  
  405. procedure TrmSplitter.StopSizing;
  406. begin
  407.   if Assigned(FControl) then
  408.   begin
  409.     if FLineVisible then DrawLine;
  410.     FControl := nil;
  411.     ReleaseLineDC;
  412.     if Assigned(FActiveControl) then
  413.     begin
  414.       TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown;
  415.       FActiveControl := nil;
  416.     end;
  417.   end;
  418.   if Assigned(FOnMoved) then
  419.     FOnMoved(Self);
  420. end;
  421.  
  422.  
  423. end.
  424.