How to create a resizable TPanel with a size grip (Views: 713)
Problem/Question/Abstract: How can I create a TPanel that can be resized by grip in the lower right corner (just like the grip, the TStatusBar has)? Answer: Solve 1: Try this one. It may need some refinement in painting the grip. unit SizeablePanel; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TSizeablePanel = class(TPanel) private FDragging: Boolean; FLastPos: TPoint; protected procedure Paint; 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; public { Public declarations } published { Published declarations } end; procedure Register; implementation procedure Register; begin RegisterComponents('PBGoodies', [TSizeablePanel]); end; procedure TSizeablePanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) and ((Width - x) < 10) and ((Height - y) < 10) then begin FDragging := TRue; FLastPos := Point(x, y); MouseCapture := true; Screen.cursor := crSizeNWSE; end else inherited; end; procedure TSizeablePanel.MouseMove(Shift: TShiftState; X, Y: Integer); var r: TRect; begin if FDragging then begin r := BoundsRect; SetBounds(r.left, r.top, r.right - r.left + X - FlastPos.X, r.bottom - r.top + Y - Flastpos.Y); FLastPos := Point(x, y); end else begin inherited; if ((Width - x) < 10) and ((Height - y) < 10) then Cursor := crSizeNWSE else Cursor := crDefault; end; end; procedure TSizeablePanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if FDragging then begin FDragging := False; MouseCapture := false; Screen.Cursor := crDefault; end else inherited; end; procedure TSizeablePanel.Paint; var x, y: Integer; begin inherited; Canvas.Font.Name := 'Marlett'; Canvas.Font.Size := 10; Canvas.Brush.Style := bsClear; x := clientwidth - canvas.textwidth('o'); y := clientheight - canvas.textheight('o'); canvas.textout(x, y, 'o'); end; end. Solve 2: Here's a component that will do that and also looks like it has a statusbar at the bottom: unit SizeGripPanel; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TSizeGripPanel = class(TPanel) private {Private declarations} FAllowMove, FAllowSize, FShowSizeGrip: Boolean; procedure SetAllowMove(Value: Boolean); procedure SetAllowSize(Value: Boolean); procedure SetShowSizeGrip(Value: Boolean); protected {Protected declarations} procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure Paint; override; public {Public declarations} published {Published declarations} property ShowSizeGrip: Boolean read FShowSizeGrip write SetShowSizeGrip; property AllowMove: Boolean read FAllowMove write SetAllowMove; property AllowSize: Boolean read FAllowSize write SetAllowSize; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TSizeGripPanel]); end; procedure TSizeGripPanel.WMNCHitTest(var Msg: TWMNCHitTest); var ScreenPt: TPoint; MoveArea: TRect; HANDLE_WIDTH: Integer; SIZEGRIP: Integer; begin {This code came from Lou's Tip of the Day web site... with changes} HANDLE_WIDTH := BevelWidth; Sizegrip := 19; inherited; if not (csDesigning in ComponentState) then begin ScreenPt := ScreenToClient(Point(Msg.Xpos, Msg.Ypos)); MoveArea := Rect(HANDLE_WIDTH, HANDLE_WIDTH, Width - HANDLE_WIDTH, Height - HANDLE_WIDTH); if FAllowSize then begin {left side} if (ScreenPt.x < HANDLE_WIDTH) then Msg.Result := HTLEFT {top side} else if (ScreenPt.y < HANDLE_WIDTH) then Msg.Result := HTTOP {right side} else if (ScreenPt.x >= Width - HANDLE_WIDTH) then Msg.Result := HTRIGHT {bottom side} else if (ScreenPt.y >= Height - HANDLE_WIDTH) then Msg.Result := HTBOTTOM {top left corner} else if (ScreenPt.x < Sizegrip) and (ScreenPt.y < Sizegrip) then Msg.Result := HTTOPLEFT {bottom left corner} else if (ScreenPt.x < Sizegrip) and (ScreenPt.y >= Height - Sizegrip) then Msg.Result := HTBOTTOMLEFT {top right corner} else if (ScreenPt.x >= Width - Sizegrip) and (ScreenPt.y < Sizegrip) then Msg.Result := HTTOPRIGHT {bottom right corner} else if (ScreenPt.x >= Width - Sizegrip) and (ScreenPt.y >= Height - Sizegrip) then Msg.Result := HTBOTTOMRIGHT; end {no sides or corners, this will do the dragging} else if PtInRect(MoveArea, ScreenPt) and FAllowMove then Msg.Result := HTCAPTION; end; end; procedure TSizeGripPanel.Paint; const Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER); var Rect: TRect; TopColor, BottomColor: TColor; FontHeight: Integer; LineBeg, LineEnd: TPoint; Flags: Longint; R: TRect; procedure AdjustColors(Bevel: TPanelBevel); begin TopColor := clBtnHighlight; if Bevel = bvLowered then TopColor := clBtnShadow; BottomColor := clBtnShadow; if Bevel = bvLowered then BottomColor := clBtnHighlight; end; procedure DrawCorner(pane: TRect); begin {Got this code from a Codeguru post. It was a CStatusBar descendant and written in C} OffsetRect(pane, -1, -1); with Canvas do begin Canvas.Pen.Color := clBtnHighlight; MoveTo(pane.right - 15, pane.bottom); LineTo(pane.right, pane.bottom - 15); MoveTo(pane.right - 11, pane.bottom); LineTo(pane.right, pane.bottom - 11); MoveTo(pane.right - 7, pane.bottom); LineTo(pane.right, pane.bottom - 7); MoveTo(pane.right - 3, pane.bottom); LineTo(pane.right, pane.bottom - 3); Canvas.Pen.Color := clBtnShadow; MoveTo(pane.right - 14, pane.bottom); LineTo(pane.right, pane.bottom - 14); MoveTo(pane.right - 10, pane.bottom); LineTo(pane.right, pane.bottom - 10); MoveTo(pane.right - 6, pane.bottom); LineTo(pane.right, pane.bottom - 6); MoveTo(pane.right - 2, pane.bottom); LineTo(pane.right, pane.bottom - 2); MoveTo(pane.right - 13, pane.bottom); LineTo(pane.right, pane.bottom - 13); MoveTo(pane.right - 9, pane.bottom); LineTo(pane.right, pane.bottom - 9); MoveTo(pane.right - 5, pane.bottom); LineTo(pane.right, pane.bottom - 5); MoveTo(pane.right - 1, pane.bottom); LineTo(pane.right, pane.bottom); end; end; begin Rect := GetClientRect; if BevelOuter <> bvNone then begin AdjustColors(BevelOuter); Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); end; Frame3D(Canvas, Rect, Color, Color, BorderWidth); if BevelInner <> bvNone then begin AdjustColors(BevelInner); Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); end; with Canvas do begin Brush.Color := Color; FillRect(Rect); Brush.Style := bsClear; Font := Self.Font; FontHeight := TextHeight('W'); with Rect do begin Top := ((Bottom + Top) - FontHeight) div 2; Bottom := Top + FontHeight; end; Flags := DT_EXPANDTABS or DT_VCENTER or Alignments[Alignment]; Flags := DrawTextBiDiModeFlags(Flags); DrawText(Handle, PChar(Caption), -1, Rect, Flags); Rect := GetClientRect; if FShowSizeGrip then begin R := Rect; R.Top := Height - 19; R.Left := Rect.Left + BevelWidth; R.Bottom := Rect.Bottom - BevelWidth; R.Right := Rect.Right - BevelWidth; AdjustColors(BevelOuter); {Always have sunken statusbar! If you want a bar that is raised when your panel is sunken, use this line, instead: Frame3D(Canvas, R, BottomColor, TopColor, 1);} Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1); DrawCorner(R); end; end; end; procedure TSizeGripPanel.SetAllowMove(Value: Boolean); begin if Value <> FAllowMove then begin FAllowMove := Value; Invalidate; end; end; procedure TSizeGripPanel.SetAllowSize(Value: Boolean); begin if Value <> FAllowSize then begin FAllowSize := Value; FShowSizeGrip := Value; Invalidate; end; end; procedure TSizeGripPanel.SetShowSizeGrip(Value: Boolean); begin if Value <> FShowSizeGrip then begin FShowSizeGrip := Value; Invalidate; end; end; end. |