Solved

Resizable Rectangular Region

Posted on 2001-09-02
8
334 Views
Last Modified: 2010-04-06
I am trying to make a graphical control (derived from TCustomControl...maybe) that represents a rectangular region that can be resized and repositioned at run time.

The actual resizing and repositioning is the easy part, I can do that. Detecting the drag event is what I will need help with. I know it has something to do with creating a TDragObject at some point. Where do I create it, and how do I manipulate it?

Thanks,

TheTaxMan
0
Comment
Question by:TheTaxMan
  • 4
  • 2
  • 2
8 Comments
 
LVL 33

Expert Comment

by:Slick812
ID: 6449563
??? what are you draging this onto? or what are you draging onto this? ? From your description - "that can be resized and repositioned at run time" doesn't seem to be a drag and drop type of thing. Have you thought about using a TGraphicControl? More info might be helpful
0
 
LVL 6

Expert Comment

by:zebada
ID: 6449716
unit Main;

interface

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

type
  TSizeDirection = set of (sizeRight,sizeBottom);

  TResizeRectangle = class(TGraphicControl)
  private
    // Local storage
    sizeDirection: TSizeDirection;
    anchor: TPoint;
    roam: TPoint;

    // Property storage
    FBorder: integer;

    // Property accessors

    // Procedures and functions

  protected
    // Procedures and functions
    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
    // Constructors and Destructors
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    // Procedures and functions
    procedure RubberBand;
    procedure Paint; override;

    // Properties
    property Border: integer read FBorder write FBorder;
  end;

  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    rr: TResizeRectangle;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

// _________________________________________________________________________
procedure TForm1.FormCreate(Sender: TObject);
begin
  rr := TResizeRectangle.Create(self);
end;

// =========================================================================
// TResizeRectangle
// =========================================================================
constructor TResizeRectangle.Create(AOwner: TComponent);
begin
  inherited;
  ControlStyle := ControlStyle + [csOpaque];
  Parent := AOwner as TWinControl;
  Left := 20;
  Top := 10;
  Width := 200;
  Height := 100;
  FBorder := 5;
end;

// _________________________________________________________________________
destructor TResizeRectangle.Destroy;
begin
  inherited;

end;

// _________________________________________________________________________
procedure TResizeRectangle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if ( Button<>mbLeft ) then
    exit;

  sizeDirection := [];
  if ( (X>=Width-Border) ) then
    sizeDirection := sizeDirection+[sizeRight];
  if ( (Y>=Height-Border) ) then
    sizeDirection := sizeDirection+[sizeBottom];
  anchor := Point(X,Y);
  roam := Point(0,0);
  RubberBand;
end;

// _________________________________________________________________________
procedure TResizeRectangle.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if ( (sizeRight in sizeDirection) ) then
    Width := Width+roam.X;
  if ( (sizeBottom in sizeDirection) ) then
    Height := Height+roam.Y;
  sizeDirection := [];
  Invalidate;
end;

// _________________________________________________________________________
procedure TResizeRectangle.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;

  Cursor := crDefault;
  if ( (X>=Width-Border) ) then
    Cursor := crSizeWE;
  if ( (Y>=Height-Border) ) then
    if ( Cursor=crSizeWE ) then
      Cursor := crSizeNWSE
    else
      Cursor := crSizeNS;

  if ( not (ssLeft in shift) ) then
    exit;
  RubberBand;
  if ( (sizeRight in sizeDirection) ) then
    roam.X := X-anchor.X;
  if ( (sizeBottom in sizeDirection) ) then
    roam.Y := Y-anchor.Y;
  RubberBand;
end;

// _________________________________________________________________________
procedure TResizeRectangle.RubberBand;
begin
  with (Parent as TForm) do
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Color := clWhite;
    Canvas.Pen.Mode := pmXor;
    Canvas.Rectangle(self.Left,self.Top,self.Left+self.Width+roam.X,self.Top+self.Height+roam.Y);
//    Canvas.MoveTo(self.Left,self.Top);
//    Canvas.Lineto(self.Left+self.Width+roam.X,self.Top+self.Height+roam.Y);
  end;
end;

// _________________________________________________________________________
procedure TResizeRectangle.Paint;
begin
  inherited;
  Canvas.Brush.Color := clNavy;
  Canvas.Pen.Color := clNavy;
  Canvas.Pen.Mode := pmCopy;
  Canvas.FillRect(ClientRect);
end;

end.
0
 
LVL 33

Accepted Solution

by:
Slick812 earned 200 total points
ID: 6451269
TaxMan, I remembered doing a component that did the drag to new position and drag to resize. It used the TCustomControl class so I could use the standard windows OS drag repostion and resize. this control has the standard windows thickFrame resize Border which gets the resize arrows on MouseOver. here's some code , I left out the Register , uses and some other things

TSizeCanvas = class(TCustomControl)
    private
    { Private declarations }

    protected
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMMouseDown(Var Msg: TMessage); message wm_LButtonDown;
    procedure WMEraseBkgnd (var Msg : TMessage); message WM_ERASEBKGND;

    public
    { Public declarations }

    published
    { Published declarations }

end;

procedure TSizeCanvas.WMMouseDown(Var Msg: TMessage);
Const SC_DragMove = $F012;
begin
  Self.perform(WM_SysCommand, SC_DragMove, 0);
{the $F012 SysCommand makes the control DragMove
in the standard windows OS fashion}
end;

procedure TSizeCanvas.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CHILD or WS_THICKFRAME or WS_VISIBLE;
{by including the WS_THICKFRAME style you make this control "sizable" with the standard windows OS size Border and size operations}
end;

procedure TSizeCanvas.Paint;
begin
Canvas.Brush.Color := clRed;
Canvas.Ellipse(5,5,30,15);
{do the painting you need, this ellipse is just an example}
end;

procedure TSizeCanvas.WMEraseBkGnd;
begin
{this may not be usefull to you, just included it to
show how to paint the background, you can also change
the background brush in the TSizeCanvas.CreateParams}
{Inherited;}
Canvas.Brush.Color := clWhite;
Canvas.FillRect(ClientRect);
Paint; // may not be neccessary
Msg.Result := 1;
end;

 -- - - - - - - - - - - - - - - - - - - - - - -
this makes it easy to let windows do the movement and resizing, if you don't mind the thick border. . . .
let me know
0
 

Author Comment

by:TheTaxMan
ID: 6459674
Zebada,

thanks very much for the suggestion, I especially like the idea of using XOR for the "rubber band". I found that using MouseDown, MouseUp and MouseMove can make the control appear to "flicker" too much though.

Slick812,

I like your suggestion a lot. I am using this control on top of a TImage component, the idea being that it overlays on a setion of the image.

I make the covered section of the underlying TImage appear on the surface of the rectangle control, resulting in an amusing "refraction" effect because of the thick border. This I don't mind, I think it looks cool..!

I want to know: when Microsoft releases other versions of Windows, will the messages used in the code you posted still be valid?
0
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 6

Expert Comment

by:zebada
ID: 6460387
Did you use the code as I posted it? It doesn't flicker when I use it. Under what conditions does it flicker?
Just curious.
Paul
0
 
LVL 33

Expert Comment

by:Slick812
ID: 6462698
OK Tax,as to "when Microsoft releases other versions of Windows, will the messages used in the code
you posted still be valid", your guess is as good as mine as to what Microsoft will do in their next versions, Ha Ha. . . . but you seem to think I have used some exotic or Unusuall api messages, the messages I used are in the move and resize of every window that the OS moves or resizes, so they may can find other things to change before these. You should study the windows messaging, it will be a GREAT value to you in programming. . . . I liked this sizable rect also. I made it do some more stuff, like change the sizable border color. . would you like to see the code?

 flicker. I have found that a TImage is prone to flicker, because it will update itself more than some other controls. I use a PaintBox for animation or Changeing images.
0
 

Author Comment

by:TheTaxMan
ID: 6475482
Thanks Slick, that code would be very handy. Could you send it to r.jain@mail.com?
Thanks also for your answer to my question. Thankyou also Zebada, but I will go with Slick's this time.

Regards,

TheTaxMan
0
 
LVL 33

Expert Comment

by:Slick812
ID: 6475673
here it is

unit MoveSize;

interface
uses
  Windows, Messages, Classes, Graphics, Controls;

type
TMoveSize = class(TCustomControl)
   private
   { Private declarations }
   FNewBorder: Boolean;
   FFrameWidth: Integer;
   FColor, FBorColor: TColor;
   FOnPaint: TNotifyEvent;
   procedure setNewBorder(Value: Boolean);
   procedure setFColor(Value: TColor);
   procedure setFBorColor(Value: TColor);

   protected
   procedure Paint; override;
   procedure CreateParams(var Params: TCreateParams); override;
   procedure WMMouseDown(Var Msg: TMessage); message wm_LButtonDown;
   procedure WMMouseUp(Var Msg: TMessage); message wm_LButtonUp;
   procedure WMEraseBkgnd (var Msg : TMessage); message WM_ERASEBKGND;
   procedure WMNCPaint(var Msg : TMessage); message WM_NCPAINT;

   public
   { Public declarations }
   constructor Create(AOwner: TComponent); override;
   property Canvas;

   published
   { Published declarations }
   property Height default 70;
   property Width default 70;
   property Left;
   property Top;
   property Name;
   property ShowHint;
   property ParentShowHint;
   property Hint;
   property Tag;
   property HelpContext;
   property Cursor;
   property Visible;
   property NewBorder: Boolean read FNewBorder write setNewBorder default False;
{this is true for a NEW type of colored border}
   property FaceColor: TColor read FColor write setFColor default clWhite;
   property BorderColor: TColor read FBorColor write setFBorColor default clBlack;
   property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;

end;

procedure Register;

implementation

procedure Register;
  begin
    RegisterComponents('Samples', [TMoveSize]);
  end;

constructor TMoveSize.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ControlStyle:= ControlStyle - [csSetCaption];}
Width := 70;
Height := 70;
if not SystemParametersInfo(SPI_GETBORDER, 0, @FFrameWidth, 0) then
FFrameWidth := 2;
FNewBorder := False;
FColor := clWhite;
FBorColor := clBlack;
end;

procedure TMoveSize.WMMouseDown(Var Msg: TMessage);
Const SC_DragMove = $F012;
begin
  if Enabled then
  begin
  Self.perform(WM_SysCommand, SC_DragMove, 0);
  SetCapture(Handle);
  end;
inherited;
if Enabled then
ReleaseCapture;
end;

procedure TMoveSize.WMMouseUp(Var Msg: TMessage);
begin
ReleaseCapture;
{seems to fix double click wierdness}
end;

procedure TMoveSize.setFColor(Value: TColor);
var
Mesg : TMessage;
begin
if FColor = Value then Exit;
FColor := Value;
WMEraseBkGnd(Mesg);
Paint;
end;

procedure TMoveSize.setNewBorder(Value: Boolean);
var
Mesg : TMessage;
begin
if FNewBorder = Value then Exit;
FNewBorder := Value;
WMNCPaint(Mesg);
end;

procedure TMoveSize.setFBorColor(Value: TColor);
var
Mesg : TMessage;
begin
if FBorColor = Value then Exit;
FBorColor := Value;
if FNewBorder then
WMNCPaint(Mesg);
end;

procedure TMoveSize.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CHILD or WS_THICKFRAME or WS_VISIBLE;
end;

procedure TMoveSize.Paint;
var
Mesg: TMessage;
begin
WMNCPaint(Mesg);
if Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure TMoveSize.WMEraseBkGnd;
begin
Canvas.Brush.Color := FColor;
Canvas.FillRect(ClientRect);
  Msg.Result := 1;
end;

procedure TMoveSize.WMNCPaint;
var
DC: HDC;
i: Integer;
Pen1: HPEN;
begin
if FNewBorder then
  begin
  DC := GetWindowDC(Self.Handle);
  Pen1 := CreatePen(PS_SOLID,0,FBorColor);
  SelectObject(DC,Pen1);
  SelectObject(DC,GetStockObject(HOLLOW_BRUSH));
  for i := 0 to FFrameWidth+1 do
    Rectangle(DC,i,i, Self.Width-i,Self.Height-i);
  DeleteObject(Pen1);
  ReleaseDC(Self.Handle,DC);
  end else
  inherited;
end;

end.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now