Image auf Form dynamisch mit der Maus at run time erstellen ?

[thomas2009]

Delphi-Quellcode:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
procedure DrawImageBounds(X, Y: Integer);
procedure CreateImage;
procedure Reset;
procedure ListImages;
procedure DeleteImages;
procedure DeleteImageBounds;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
procedure TForm1.CreateImage;
  procedure Swap(var X1, X2: Integer);
  var
    Temp: Integer;
  begin
    Temp := X1;
    X1 := X2;
    X2 := Temp;
  end;
var
  Image: TImage;
begin
  SetLength(ImageArray, Length(ImageArray) + 1);
  Image := TImage.Create(nil);
  Image.Name := 'Image' + IntToStr(Length(ImageArray));
  Image.Parent := Form1;
  if (BottomRight.Y < TopLeft.Y) then
    Swap(BottomRight.Y, TopLeft.Y);
  if (BottomRight.X < TopLeft.X) then
    Swap(BottomRight.X, TopLeft.X);
  Image.Left := TopLeft.X;
  Image.Top := TopLeft.Y;
  Image.Height := BottomRight.Y - TopLeft.Y;
  Image.Width := BottomRight.X - TopLeft.X;
  //Image.Stretch := True;
  //Image.Proportional := True;
  Image.Picture.LoadFromFile('test.bmp');
  ImageArray[High(ImageArray)] := Image;
end;

procedure TForm1.DeleteImages;
var
  i: Integer;
begin
  for i := High(ImageArray) downto 0 do
  begin
    ImageArray[i].Free;
  end;
  SetLength(ImageArray, 0);
end;

procedure TForm1.ListImages;
var
  i: Integer;
begin
  ListBox1.Items.Clear;
  for i := 0 to ControlCount - 1 do
  begin
    if (Controls[i] is TImage) then
    begin
      ListBox1.Items.Add(Format('%s (%d / %d)', [TImage(Controls[i]).Name, TImage(Controls[i]).Width, TImage(Controls[i]).Height]));
    end;
  end;
end;

procedure TForm1.Reset;
begin
  IsMouseDown := False;
  TopLeft.X := 0;
  TopLeft.Y := 0;
  BottomRight.X := 0;
  BottomRight.Y := 0;
end;

procedure TForm1.DrawImageBounds(X, Y: Integer);
begin
  if not Assigned(ImageBoundsRect) then
  begin
    ImageBoundsRect := TShape.Create(Form1);
    ImageBoundsRect.Parent := Form14;
    ImageBoundsRect.Shape := stRectangle;
    ImageBoundsRect.Brush.Style := bsClear;
    ImageBoundsRect.Pen.Width := 1;
    ImageBoundsRect.Pen.Color := clBlack;
    ImageBoundsRect.Pen.Style := psDash;
  end;
  ImageBoundsRect.Left := TopLeft.X;
  ImageBoundsRect.Top := TopLeft.Y;
  ImageBoundsRect.Width := X - TopLeft.X;
  ImageBoundsRect.Height := Y - TopLeft.Y;
end;

procedure TForm1.DeleteImageBounds;
begin
  FreeAndNil(ImageBoundsRect);
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DeleteImages;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsMouseDown := True;
  TopLeft.X := X;
  TopLeft.Y := Y;
end;


procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if IsMouseDown then
  begin
    BottomRight.X := X;
    BottomRight.Y := Y;
    DrawImageBounds(X, Y);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if IsMouseDown then
  begin
    DeleteImageBounds;
    CreateImage;
    Reset;
    ListImages;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DeleteImages;
  ListImages;
end;

end.