Link to home
Create AccountLog in
Avatar of pr2501
pr2501

asked on

Error messages

Same time ago i have built an app with many problems. So at one moment i decided to start everything from start.
And now am on a problem again which was resolved from:
epasquier:
https://www.experts-exchange.com/questions/26626765/Can't-move-TShape-while-app-is-runing-after.html
I have attached picture of line where i get error message to brake the code.


unit mirna9;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,stdctrls ,  extctrls ,  contnrs, Buttons, Menus,inifiles ;


type

 TMyObject=Class(TObject)
  private
   _Label:TLabel; // I use a _ convention instead of 'conventional' fXXX. I find it more readable
   _Shape:TShape;
   function GetLeft:Integer;
   function GetTop:Integer;
  public
   Constructor Create(aParent:TWinControl);
   Destructor Destroy; override;
   Procedure SetPosition(X,Y:Integer);
   property Labelmy:TLabel read _Label;
   property Shape:TShape read _Shape;
   property Left:Integer read GetLeft;
   property Top:Integer read GetTop;
  end;

  TForm1 = class(TForm)
    Edit1: TEdit;
    MainMenu1: TMainMenu;
    new1: TMenuItem;
    object1: TMenuItem;
    PopupMenu1: TPopupMenu;
    odpri1: TMenuItem;
    ime1: TMenuItem;
    brii1: TMenuItem;
    Button1: TButton;
    Edit2: TEdit;
    procedure object1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ime1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
     procedure checkshapeNoFree();
   

  private
    { Private declarations }
    _Pos: TPoint;
    FSelectedObject:TMyObject;
    FMyObjectList:TObjectList;

    procedure ShapeMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
        procedure ShapeMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
     procedure CreateNewObject  (Owner:TWinControl);

  public

    { Public declarations }
  end;

var
  Form1: TForm1;
     FShapeCount: Integer;
       
implementation

{$R *.dfm}

///////////////////////////////////////////////////////////////////////////////////START
procedure TForm1.FormCreate(Sender: TObject);
var
INIFile: TIniFile;
n,i,FLabelNumber:integer;
lbel:TLabel;
cmp:TShape;
begin
   FMyObjectList:=TObjectList.Create;


  INIFile := TINIFile.Create(ExtractFilePath(Application.Exename) + 'yourini.ini');
  try

    n := INIFIle.ReadInteger(Self.Name, 'Label', 0);

    for i := 1 to n do
    begin
      Lbel := TLabel(FindComponent('Label' + IntToStr(i)));
      if Lbel = nil then
      begin
        Lbel := TLabel.Create(Self);
        Lbel.Name := 'Label' + IntToStr(I);
        Lbel.Parent := Self;

        inc(FLabelNumber);
        Lbel.Caption := INIFIle.ReadString(Self.Name, Lbel.Name + ' Caption', Lbel.Caption);
        Lbel.Font.Color := TColor(INIFIle.ReadInteger(Self.Name, Lbel.Name + ' Font Color', integer(clWindowText)));
        Lbel.Font.name := INIFIle.ReadString(Self.Name, Lbel.Name + ' Font Name', Lbel.Font.Name);
        Lbel.Font.Size := INIFIle.ReadInteger(Self.Name, Lbel.Name + ' Font Size', Lbel.Font.Size);
        Lbel.Top := INIFIle.ReadInteger(Self.Name, Lbel.Name + ' Top', Lbel.Top);
        Lbel.Left :=INIFIle. ReadInteger(Self.Name, Lbel.Name + ' Left', Lbel.Left);
        Lbel.Transparent := INIFIle.ReadBool(Self.Name, Lbel.Name + ' Transparent', Lbel.Transparent);
        Lbel.WordWrap :=INIFIle. ReadBool(Self.Name, Lbel.Name + ' WordWrap', Lbel.WordWrap);
      end;
    end;
  finally
    //FreeAndNil(INIFile);
  end;
  try
    n := INIFile.ReadInteger(Self.Name, 'Shapes', 0);
    //edit1.Text:=inttostr(n);
    for i := 1 to n do
    begin
      cmp := TShape(FindComponent('Shape' + IntToStr(i)));
      if cmp = nil then
      begin
        cmp := TShape.Create(Self);
        cmp.Name := 'Shape' + IntToStr(I);
        cmp.Parent := Self;
        cmp.onMouseDown := ShapeMouseDown;
        cmp.onMouseMove := ShapeMouseMove;
        cmp.Brush.Color := TColor(INIFile.ReadInteger(Self.Name, cmp.Name + ' Brush Color', integer(clGreen)));
        cmp.Width := INIFile.ReadInteger(Self.Name, cmp.Name + ' Width', cmp.Width);
        cmp.Height := INIFile.ReadInteger(Self.Name, cmp.Name + ' Height', cmp.Height);
        cmp.Top := INIFile.ReadInteger(Self.Name, cmp.Name + ' Top', cmp.Top);
        cmp.Left := INIFile.ReadInteger(Self.Name, cmp.Name + ' Left', cmp.Left);
        cmp.hint := INIFile.readString(Self.Name, cmp.Name + ' Hint', '');
        cmp.showhint := INIFile.readBool(Self.Name, cmp.Name + ' ShowHint', cmp.Hint <> '');
      end;
    end;
  finally
    FreeAndNil(INIFile);
  end;

end;

//NEW OBJECT
///////////////////////////////////////////////////////////////////////////////NEW OBJECT
procedure TForm1.object1Click(Sender: TObject);
begin
 CreateNewObject(self);
end;

procedure TForm1.CreateNewObject(Owner:TWinControl);
begin
 FSelectedObject := TMyObject.Create(Owner);
 FMyObjectList.Add(FSelectedObject);
end ;
Constructor TMyObject.Create(aParent:TWinControl);  //create
begin
_Shape:=TShape.Create(aParent);
  With _Shape do
    begin
      Parent:=aParent;
      form1.checkshapeNoFree();
      Name := 'Shape' + IntToStr(FShapeCount);
      Tag:=Integer(Self);
      hint:= _Shape.Name;
      _Shape.ShowHint := True;
      Brush.Color := clwhite;
      onMouseDown := Form1.ShapeMouseDown;
      onMouseMove := Form1.ShapeMouseMove;
     //onMouseUp := Form2.ShapeMouseUp;
    Width := 10;
   Height := 10;
    end;
 _Label:=TLabel.Create(aParent);
 With _Label do
  begin
   Parent:=aParent;
   Tag:=Integer(Self);
   Width := 10; //
   Height := 10;
   Name := 'Label' + IntToStr(FShapeCount);
   Caption:= _Label.Name;
  end;    
  SetPosition(10,10);
end;
procedure TForm1.checkshapeNoFree();
   var
   i,ComponentCount :integer;
begin
      FShapeCount:=1;
           for I := 0 to 100 do  begin
              try
                if findcomponent ('shape'+inttostr(FShapeCount)) <> nil then begin
                 Form1.Edit1.text:=inttostr(FShapeCount);
                 inc(FShapeCount);
                end;
              except
                   exit;
              end;
           end;
end;

//MOUSE

/////////////////////////////////////////////////////////////////////////////////////////////////////////////MOUSE
 procedure TForm1.ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 var
 i:integer;
 begin
 FSelectedObject := TMyObject(TShape(Sender).Tag);
 if ssLeft in Shift then
  begin
   _Pos.X := FSelectedObject.Left-Mouse.CursorPos.X;
   _Pos.Y := FSelectedObject.Top-Mouse.CursorPos.Y;
  end;
  if ssRight in Shift Then
   begin
     PopupMenu1.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
  //  Exit;
   end;
end;
procedure TForm1.ShapeMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
 // only dragging with left mouse button
 if not (ssLeft in Shift) then FSelectedObject := nil;
 if not Assigned(FSelectedObject) then Exit;
 // Don't use X & Y directly as they are relative to the object, which is moving
 FSelectedObject.SetPosition( _Pos.X + Mouse.CursorPos.X , _Pos.Y + Mouse.CursorPos.Y );
end;
  //destroj
Destructor TMyObject.Destroy;   //destroy
begin
 _Label.Free;
 _Shape.Free;
end;
 function TMyObject.GetLeft:Integer; //left
begin
 Result:=_Label.Left;
end;
function TMyObject.GetTop:Integer; //top
begin
 Result:=_Label.Top;
end;
Procedure TMyObject.SetPosition(X,Y:Integer); //position
begin
 _Label.Left:=X;
 _Label.Top:=Y;
 _Shape.Left:=X;
 _Shape.Top:=Y+15;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FMyObjectList.Free;
end;
//NAME
////////////////////////////////////////////////////////////////////NAME
procedure TForm1.ime1Click(Sender: TObject);
var
strobjectName :string;
begin
strobjectName := '';
strobjectName  := InputBox('','Poimenuj stroj', strobjectName) ;
FSelectedObject._Shape.Hint := strobjectName ;
FSelectedObject._Shape.Brush.Color:= clgreen;
FSelectedObject._Label.Caption:= strobjectName;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  cmpshape: TShape;
  cmplabel: TLabel;
  j, LabelCount,I, ShapeCount: integer;
  E,F: TIniFile;
  FileName: string;
begin
FileName := IncludeTrailingPathDelimiter(ExtractFilePath(Application.Exename)) + 'yourini.ini';
  E := TINIFile.Create(FileName);
  try

    LabelCount := 0;
    for J := 0 to ComponentCount - 1 do
      if Components[J] is TLabel then
      begin
        cmplabel := TLabel(Components[J]);
        Inc(LabelCount);
        E.WriteInteger(Self.Name, cmpLabel.Name + ' Top', cmpLabel.Top);
        E.WriteInteger(Self.Name, cmpLabel.Name + ' Left', cmpLabel.Left);
        E.WriteString(Self.Name, cmpLabel.Name + ' Caption', cmpLabel.Caption);
      end;
    E.WriteInteger(Self.Name, 'Label', LabelCount);
  finally
    FreeAndNil(E);
  end ;

  F := TINIFile.Create(FileName);
  try

    ShapeCount := 0;
    for I := 0 to ComponentCount - 1 do
      if Components[I] is TShape then
      begin
        cmpshape := TShape(Components[I]);
        Inc(ShapeCount);
        F.WriteInteger(Self.Name, cmpshape.Name + ' Brush Color', cmpshape.Brush.Color);
        F.WriteInteger(Self.Name, cmpshape.Name + ' Width', cmpshape.Width);
        F.WriteInteger(Self.Name, cmpshape.Name + ' Height', cmpshape.Height);
        F.WriteInteger(Self.Name, cmpshape.Name + ' Top', cmpshape.Top);
        F.WriteInteger(Self.Name, cmpshape.Name + ' Left', cmpshape.Left);
        F.WriteString(Self.Name, cmpshape.Name + ' Hint', cmpshape.Hint);
        F.WriteBool(Self.Name, cmpshape.Name + ' ShowHint', cmpshape.Showhint);
      end;
    F.WriteInteger(Self.Name, 'Shapes', ShapeCount);
  finally
    FreeAndNil(F);
  end;

end;


end.

Open in new window

error.JPG
Avatar of systan
systan
Flag of Philippines image

_Label:=TLabel.Create(aParent);
 With _Label do
  begin
   Parent:=aParent;
   Tag:=Integer(Self);
   Width := 10; //
   Height := 10;
   Name := 'Label' + IntToStr(FShapeCount);
   Caption:= _Label.Name;
   
   //TRY to declare first during TObject Creation time, for the default value.
   Left := 10;

  end;
Avatar of jimyX
jimyX

What is the error? The error line is not showing at the event log.
Hi Systan, how are you?
Hope you enjoyed Christmas.
Wish you (as well as pr2501) a happy new year.
Hello jimyX;

I enjoyed Christmas a lot, same thing with this New Year day,  I got my stomach rigidly damage because of the food around.

Happy New Year too.


Cheers
Avatar of pr2501

ASKER

Happy new year!
Avatar of pr2501

ASKER

Yes.
I forget to explain.
I get  error after restarting of  app while clicking on TShape.
error2.JPG
I see some errors here --
in ShapeMouseDown you do this:

 FSelectedObject := TMyObject(TShape(Sender).Tag);
 if ssLeft in Shift then
  begin
   _Pos.X := FSelectedObject.Left-Mouse.CursorPos.X;    ///  AV occurs here, I guess
  ...

but
(1) objects created in FormCreate are *not* TMyObject, since you create TLabel and TShape separately;
(2) you don't set Tag in shapes created in FormCreate.
hence the access violation.

maybe use CreateNewObject(self) in FormCreate too, when you read objects back from ini
Avatar of pr2501

ASKER

Maybe in next way:

In CreateNewObject i do next for TLabel and TShape

Name := 'Label'  + IntToStr(Form1.checkshapeNoFree());
Tag:=Form1.checkshapeNoFree();  

And then when i close form:

for J := 0 to ComponentCount - 1 do
      if Components[J] is TLabel then
      begin
      cmplabel := TLabel(Components[J]);

E.Writestring(Self.Name, cmpLabel.Name + ' Name', cmpLabel.name);
         E.WriteInteger(Self.Name, cmpLabel.Name + ' Tag', cmpLabel.tag);


I hope in this way i get really the name and tag of  label which was find.
Let say if there were  100 components. Then if we presume that first label find has J=10. And this label is  name:= Label1 and tag:=1 i will store it in ini as it is: name:= Label1 and tag:=1
What is your point of "FSelectedObject := TMyObject(TShape(Sender).Tag);" ?

If you wan to get the Tag property of the clicked shape you can use the following line:

FSelectedObject._Shape.tag := TShape(Sender).Tag;
Avatar of pr2501

ASKER

One mistake fixed:
freeID:=form1.checkshapeNoFree();
Name := 'Label'  + IntToStr(freeID);
Tag:=freeID;  



cmp.Tag := i  ; (tsahape)

Lbel.Tag := i;  (tlabel)

And above i have added to form create ini.


But still some error message happens.

( lets sing:
Happy new year,
Happy new year,...)



Avatar of pr2501

ASKER

FSelectedObject._Shape.tag := TShape(Sender).Tag;

 Ok,  i understand but it doesn't help.
What you did is correct but to reduce the number of variables used:

Tag:=form1.checkshapeNoFree();
Name := 'Label'  + IntToStr(Tag);

What is the new error message please?
Avatar of pr2501

ASKER

Surly.
 Take a look at next code:
it has to be arranged in my actual code.
Sorry for confusion.  I see how hard is to work with programming. I go sleep for some ours more.
procedure TForm1.ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  // i now make a difference between selecting and dragging a shape
  // this make it possible to keep a selection and that is usefull for the speedbutton function
  if Assigned(Sender) and (Sender is TShape) then
  begin
   FSelectedShape := TShape(Sender); // Might be usefull for other treatments
      //ShapeMenu: TPopupMenu;
   if ssRight in Shift Then
   begin
     PopupMenu1.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
     Exit;
   end;
   if ssLeft in Shift then begin
      // set the last clicked shape with right button
      // get its start position relative to position of mouse when the click occurred
      _Pos.X := FSelectedShape.Left-Mouse.CursorPos.X;
      _Pos.Y := FSelectedShape.Top-Mouse.CursorPos.Y;
      FDragShape := FSelectedShape;
    end;
  end;
end;

procedure TForm1.ShapeMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  // only dragging with left mouse button
  if Not (ssLeft in Shift) then
    FDragShape := nil;
  if Not Assigned(FDragShape) then
    Exit;
  // Don't use X & Y directly as they are relative to the object, which is moving
  FDragShape.Left := _Pos.X + Mouse.CursorPos.X;
  FDragShape.Top := _Pos.Y + Mouse.CursorPos.Y;
  if Assigned(FSelectedShapelabel) then
  begin
    FSelectedShapelabel.Left:= _Pos.X + Mouse.CursorPos.X;
    FSelectedShapelabel.Top := _Pos.Y + Mouse.CursorPos.Y - 12;
  end;
end;

Open in new window

Avatar of pr2501

ASKER

"What is the new error message please?"

No error while debugging . Just message window: access violation..........  when run.

ASKER CERTIFIED SOLUTION
Avatar of jimyX
jimyX

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Avatar of pr2501

ASKER


   procedure TForm1.ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(Sender) and (Sender is TShape) then
  begin
   SelectedShape := TShape(Sender);


Here is how it know which TSahape it is: Shape 1, Shape2........

How to do for selectedlabel?
Avatar of pr2501

ASKER

  selectedlabel:=  TLabel(FindComponent('label' + IntToStr(SelectedShape.Tag)));
 

Ok. Thank you.
Now is working.
@pr2501

Consider this solution for your future use, I have made the whole system very easy, I created a new component called TLabeledShape so you dont have to keep track of separate labels.
This should be the best approach you take.

No need to worry about current positin of objects
object Form3: TForm3
  Left = 0
  Top = 0
  Caption = 'Form3'
  ClientHeight = 257
  ClientWidth = 447
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  OnDragDrop = FormDragDrop
  OnDragOver = FormDragOver
  PixelsPerInch = 96
  TextHeight = 13
  object MainMenu1: TMainMenu
    Left = 72
    Top = 80
    object File1: TMenuItem
      Caption = 'File'
      object AddShape1: TMenuItem
        Caption = 'Add Shape'
        OnClick = AddShape1Click
      end
      object DeleteShape1: TMenuItem
        Caption = 'Delete Shape'
        OnClick = DeleteShape1Click
      end
      object Exit1: TMenuItem
        Caption = 'Exit'
        OnClick = Exit1Click
      end
    end
  end
  object PopupMenu1: TPopupMenu
    Left = 192
    Top = 80
  end
end

Open in new window

unit Unit3;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IniFiles, ExtCtrls, uAppShape, Menus;

type
  TForm3 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    AddShape1: TMenuItem;
    DeleteShape1: TMenuItem;
    Exit1: TMenuItem;
    PopupMenu1: TPopupMenu;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Exit1Click(Sender: TObject);
    procedure AddShape1Click(Sender: TObject);
    procedure DeleteShape1Click(Sender: TObject);
    procedure FormDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure FormDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    FSelectedShape: TLabeledShape;
    FShapeNumber: Integer;
    function CreateShape(const AName, ACaption: string; ALeft, ATop: Integer): TLabeledShape;
    procedure ShapeClick(Sender: TObject);
    procedure ShapeMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure SetSelectedShape(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

procedure TForm3.AddShape1Click(Sender: TObject);
var
  LabelName: string;
begin
  Inc(FShapeNumber);
  LabelName := 'Shape' + IntToStr(FShapeNumber);
  CreateShape(LabelName, LabelName, 10, 40);
end;

function TForm3.CreateShape(const AName, ACaption: string; ALeft,
  ATop: Integer): TLabeledShape;
begin
  if Assigned(FSelectedShape) then
    FSelectedShape.ShapeLabel.Font.Style := [];

  Result := TLabeledShape.Create(Self);
  Result.Name := AName;
  Result.Top := ATop;
  Result.Left := ALeft;
  Result.Parent := Self;
  Result.ShapeLabel.Caption := ACaption;
  Result.Hint:= Result.Name;
  Result.ShowHint := True;
  Result.OnMouseDown := ShapeMouseDown;
  Result.OnClick := ShapeClick;
  Result.DragMode := dmAutomatic;
  Result.ShapeLabel.Font.Style := [fsBold];

  FSelectedShape := Result;
end;

procedure TForm3.DeleteShape1Click(Sender: TObject);
begin
  if Assigned(FSelectedShape) then
  begin
    FSelectedShape.Visible := False;
    FreeAndNil(FSelectedShape);
  end;
end;

procedure TForm3.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
var
  Shape: TLabeledShape;
  I, ShapeCount: Integer;
  E: TIniFile;
  FileName: string;
begin
  FileName := IncludeTrailingPathDelimiter(ExtractFilePath(Application.Exename)) + 'yourini.ini';

  E := TINIFile.Create(FileName);
  try
    E.EraseSection(Self.Name);
    ShapeCount := 0;
    for I := 0 to ComponentCount - 1 do
      if Components[I] is TLabeledShape then
      begin
        Shape := TLabeledShape(Components[I]);
        Inc(ShapeCount);
        E.WriteInteger(Self.Name, Shape.Name + ' Top', Shape.Top);
        E.WriteInteger(Self.Name, Shape.Name + ' Left', Shape.Left);
        E.WriteInteger(Self.Name, Shape.Name + ' Width', Shape.Width);
        E.WriteInteger(Self.Name, Shape.Name + ' Height', Shape.Height);

        E.WriteString(Self.Name, Shape.Name + ' Caption', Shape.ShapeLabel.Caption);
        E.WriteInteger(Self.Name, Shape.Name + ' Brush Color', Shape.Brush.Color);
        E.WriteString(Self.Name, Shape.Name + ' Hint', Shape.Hint);
        E.WriteBool(Self.Name, Shape.Name + ' ShowHint', Shape.Showhint);
      end;

    E.WriteInteger(Self.Name, 'Shape', ShapeCount);
  finally
    FreeAndNil(E);
  end;
end;

procedure TForm3.FormCreate(Sender: TObject);
var
  INIFile: TIniFile;
  I, N: Integer;
  Shape, FirstItem: TLabeledShape;
  LabelName: string;
begin
  FirstItem := nil;
  FShapeNumber := 1;
  INIFile := TINIFile.Create(ExtractFilePath(Application.Exename) + 'yourini.ini');
  try
    N := INIFIle.ReadInteger(Self.Name, 'Shape', 0);

    for I := 1 to N do
    begin
      Shape := TLabeledShape(FindComponent('Shape' + IntToStr(I)));
      if Shape = nil then
      begin
        LabelName := 'Shape' + IntToStr(I);
        Shape := CreateShape(LabelName, LabelName, 10, 10);

        Inc(FShapeNumber);
        Shape.ShapeLabel.Caption := INIFIle.ReadString(Self.Name, Shape.Name + ' Caption', Shape.ShapeLabel.Caption);
        Shape.ShapeLabel.Font.Color := TColor(INIFIle.ReadInteger(Self.Name, Shape.Name + ' Font Color', Integer(clWindowText)));
        Shape.ShapeLabel.Font.Name := INIFIle.ReadString(Self.Name, Shape.Name + ' Font Name', Shape.ShapeLabel.Font.Name);
        Shape.ShapeLabel.Font.Size := INIFIle.ReadInteger(Self.Name, Shape.Name + ' Font Size', Shape.ShapeLabel.Font.Size);
        Shape.ShapeLabel.Transparent := INIFIle.ReadBool(Self.Name, Shape.Name + ' Transparent', Shape.ShapeLabel.Transparent);
        Shape.ShapeLabel.WordWrap :=INIFIle. ReadBool(Self.Name, Shape.Name + ' WordWrap', Shape.ShapeLabel.WordWrap);

        Shape.Top := INIFIle.ReadInteger(Self.Name, Shape.Name + ' Top', Shape.Top) + Shape.ShapeLabel.Height;
        Shape.Left :=INIFIle. ReadInteger(Self.Name, Shape.Name + ' Left', Shape.Left);
        Shape.Width := INIFile.ReadInteger(Self.Name, Shape.Name + ' Width', Shape.Width);
        Shape.Height := INIFile.ReadInteger(Self.Name, Shape.Name + ' Height', Shape.Height);
        Shape.OnMouseDown := ShapeMouseDown;
        Shape.OnClick := ShapeClick;
        Shape.Brush.Color := TColor(INIFile.ReadInteger(Self.Name, Shape.Name + ' Brush Color', Shape.Brush.Color));
        Shape.hint := INIFile.readString(Self.Name, Shape.Name + ' Hint', '');
        Shape.showhint := INIFile.readBool(Self.Name, Shape.Name + ' ShowHint', Shape.Hint <> '');
      end;
      if not Assigned(FirstItem) then
        FirstItem := Shape;
    end;
  finally
    FreeAndNil(INIFile);
  end;

  if Assigned(FirstItem) then
    SetSelectedShape(FirstItem);
end;

procedure TForm3.FormDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if Source is TLabeledShape then
  begin
    SetSelectedShape(Source);
    FSelectedShape.Left := X;
    FSelectedShape.Top := Y;
  end;
end;

procedure TForm3.FormDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TLabeledShape;
end;

procedure TForm3.SetSelectedShape(Sender: TObject);
begin
  if Sender is TLabeledShape then
  begin
    if Assigned(FSelectedShape) then
      FSelectedShape.ShapeLabel.Font.Style := [];
    FSelectedShape := TLabeledShape(Sender);
    FSelectedShape.ShapeLabel.Font.Style := [fsBold];
  end;
end;

procedure TForm3.ShapeClick(Sender: TObject);
begin
  if Sender is TLabeledShape then
    if Assigned(FSelectedShape) and (FSelectedShape <> Sender) then
      SetSelectedShape(Sender);
end;

procedure TForm3.ShapeMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FSelectedShape) then
    FSelectedShape.ShapeLabel.Font.Style := [];

  FSelectedShape := TLabeledShape(Sender);
  FSelectedShape.ShapeLabel.Font.Style := [fsBold];

  if ssRight in Shift Then
    PopupMenu1.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
end;

end.

Open in new window

{It is much better to register this control and show it on the components tab,
 This way you can drag and drop it on your form}

unit uAppShape;

interface

uses                                                                  //if using delphi 2009+
  Windows, Classes, Messages, Controls, StdCtrls, ExtCtrls, StrUtils, AnsiStrings;

type
  TLabeledShape = class(TShape)
  private
    FLabel: TBoundLabel;
    FLabelPosition: TLabelPosition;
    FLabelSpacing: Integer;
    procedure SetLabelPosition(const Value: TLabelPosition);
    procedure SetLabelSpacing(const Value: Integer);
  protected
    procedure SetParent(AParent: TWinControl); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetName(const Value: TComponentName); override;
    procedure CMVisiblechanged(var Message: TMessage);
      message CM_VISIBLECHANGED;
    procedure CMEnabledchanged(var Message: TMessage);
      message CM_ENABLEDCHANGED;
    procedure CMBidimodechanged(var Message: TMessage);
      message CM_BIDIMODECHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;
    procedure SetupInternalLabel;
    property ShapeLabel: TBoundLabel read FLabel;
    property LabelPosition: TLabelPosition read FLabelPosition write SetLabelPosition default lpAbove;
    property LabelSpacing: Integer read FLabelSpacing write SetLabelSpacing default 3;
    property OnClick;
  end;

implementation

type
  TBoundLabelAccess = class(TBoundLabel)
  end;

{ TLabeledShape }

constructor TLabeledShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLabelPosition := lpAbove;
  FLabelSpacing := 3;
  SetupInternalLabel;
end;

procedure TLabeledShape.CMBidimodechanged(var Message: TMessage);
begin
  inherited;
  if FLabel <> nil then
    FLabel.BiDiMode := BiDiMode;
end;

procedure TLabeledShape.CMEnabledchanged(var Message: TMessage);
begin
  inherited;
  if FLabel <> nil then
    FLabel.Enabled := Enabled;
end;

procedure TLabeledShape.CMVisiblechanged(var Message: TMessage);
begin
  inherited;
  if FLabel <> nil then
    FLabel.Visible := Visible;
end;

procedure TLabeledShape.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = FLabel) and (Operation = opRemove) then
    FLabel := nil;
end;

procedure TLabeledShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  SetLabelPosition(FLabelPosition);
end;

procedure TLabeledShape.SetLabelPosition(const Value: TLabelPosition);
var
  P: TPoint;
begin
  if FLabel = nil then
    Exit;

  FLabelPosition := Value;
  case Value of
    lpAbove:
      P := Point(Left, Top - FLabel.Height - FLabelSpacing);
    lpBelow:
      P := Point(Left, Top + Height + FLabelSpacing);
      
    lpLeft : P := Point(Left - FLabel.Width - FLabelSpacing,
                    Top + ((Height - FLabel.Height) div 2));
    lpRight: P := Point(Left + Width + FLabelSpacing,
                    Top + ((Height - FLabel.Height) div 2));
  end;
  FLabel.SetBounds(P.x, P.y, FLabel.Width, FLabel.Height);
end;

procedure TLabeledShape.SetLabelSpacing(const Value: Integer);
begin
  FLabelSpacing := Value;
  SetLabelPosition(FLabelPosition);
end;

procedure TLabeledShape.SetName(const Value: TComponentName);
var
  LClearText: Boolean;
begin
  if (csDesigning in ComponentState) and (FLabel <> nil) and
     ((FLabel.GetTextLen = 0) or
     (CompareText(FLabel.Caption, Name) = 0)) then
    FLabel.Caption := Value;
  LClearText := (csDesigning in ComponentState) and (Text = '');
  inherited SetName(Value);
  if LClearText then
    Text := '';
end;

procedure TLabeledShape.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if FLabel = nil then
    Exit;
  FLabel.Parent := AParent;
  FLabel.Visible := True;
end;

procedure TLabeledShape.SetupInternalLabel;
begin
  if Assigned(FLabel) then
    Exit;
  FLabel := TBoundLabel.Create(Self);
  FLabel.FreeNotification(Self);
end;


end.

Open in new window