Solved

Resizable Rectangular Region

Posted on 2001-09-02
8
354 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 2
  • 2
8 Comments
 
LVL 34

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 34

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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

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
 
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 34

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 34

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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Firemonkey webbrowser scrollbars ? 1 72
Firemonkey BASS_Init into a thread 17 84
Browsing a TTreeView in Delphi 5 49
TlistView is Really heavy on Android 3 44
In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Nobody understands Phishing better than an anti-spam company. That’s why we are providing Phishing Awareness Training to our customers. According to a report by Verizon, only 3% of targeted users report malicious emails to management. With compan…
Exchange organizations may use the Journaling Agent of the Transport Service to archive messages going through Exchange. However, if the Transport Service is integrated with some email content management application (such as an antispam), the admini…

739 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