图形放大中的问题(简单,在线等待) (100分)

  • 主题发起人 主题发起人 橡皮巴
  • 开始时间 开始时间

橡皮巴

Unregistered / Unconfirmed
GUEST, unregistred user!
恕本人表达能力不强,先贴原码

main.pas

unit main;

interface

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

type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Label1: TLabel;
Label2: TLabel;
procedure FormCreate(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
StartPosX,StartPosY,EndPosX,EndPosy:integer;
DestRect, SourceRect : TRect;
Drawline:bool;
x1,y1:integer;
procedure Imagestreth;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
image1.Picture.LoadFromFile('c:/1.bmp');
image2.Canvas.CopyMode:=cmSrcCopy;
image1.Canvas.Pen.Mode:=pmXor;
image1.Canvas.Pen.Style:=psDot;
image1.Canvas.Pen.Width:=1;
image1.Canvas.Pen.Color:=clblack;
image1.Parent.DoubleBuffered:=true;
image2.Parent.DoubleBuffered:=true;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
StartPosX:=trunc(x/image1.Width*Image1.Picture.Bitmap.Width);
StartPosY:=trunc(y/image1.Height*Image1.Picture.Bitmap.Height);
x1:=StartPosX;
y1:=StartPosY;
Drawline:=true;
Image1.Canvas.MoveTo(StartPosX,StartPosY);
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
EndPosX:=trunc(x/image1.Width*Image1.Picture.Bitmap.Width);
EndPosY:=trunc(y/image1.Height*Image1.Picture.Bitmap.Height);
Drawline:=false;
Image1.Canvas.Rectangle(StartPosX,StartPosY,x1,y1);

//if (EndPosX-StartPosX>10) and (EndPosY-StartPosy>10) then
Imagestreth
end;

procedure TForm1.Imagestreth;
begin
SourceRect.Left:=StartPosX;
SourceRect.Top:=StartPosY;
SourceRect.Right:=EndPosX;
SourceRect.Bottom:=EndPosY;

DestRect.Left:=0;
DestRect.top:=0;
DestRect.Right:=Image2.Width;
DestRect.Bottom:=Image2.Height;

// image2.Canvas.StretchDraw(DestRect,Image1.Picture.Bitmap);
Image2.Canvas.CopyRect(DestRect, Image1.Canvas, SourceRect);

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
label1.caption:=inttostr(x);
label2.caption:=inttostr(y);
if drawline then
begin
Image1.Canvas.Rectangle(StartPosX,StartPosY,x1,y1 );
x1:=trunc(x/image1.Width*Image1.Picture.Bitmap.Width);
y1:=trunc(y/image1.Height*Image1.Picture.Bitmap.Height);
Image1.Canvas.Rectangle(StartPosX,StartPosY,x1,y1);

end;
end;

end.


main.dfm

object Form1: TForm1
Left = 256
Top = 146
Width = 728
Height = 428
AutoSize = True
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 0
Top = 0
Width = 240
Height = 201
Cursor = crCross
DragCursor = crCross
DragKind = dkDock
Stretch = True
OnMouseDown = Image1MouseDown
OnMouseMove = Image1MouseMove
OnMouseUp = Image1MouseUp
end
object Image2: TImage
Left = 240
Top = 0
Width = 480
Height = 401
AutoSize = True
Stretch = True
Transparent = True
end
object Label1: TLabel
Left = 32
Top = 352
Width = 32
Height = 13
Caption = 'Label1'
end
object Label2: TLabel
Left = 168
Top = 352
Width = 32
Height = 13
Caption = 'Label2'
end
end


大家运行以后应该发现问题所在了,就是在原图鼠标拖动划矩形的时候有问题,我已经
XORNOT了,还是不行,请指教,或帮改一下代码
 
有人看到会吐血的。^_^
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
EndPosX:=trunc(x/image1.Width*Image1.Picture.Bitmap.Width);
EndPosY:=trunc(y/image1.Height*Image1.Picture.Bitmap.Height);
Drawline:=false;
Image1.Canvas.Rectangle(StartPosX,StartPosY,x1,y1);
Image1.Canvas.Rectangle(StartPosX+1,StartPosY+1,x1+1,y1+1);

//if (EndPosX-StartPosX>10) and (EndPosY-StartPosy>10) then
Imagestreth;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
label1.caption:=inttostr(x);
label2.caption:=inttostr(y);
if drawline then
begin
Image1.Canvas.Rectangle(StartPosX,StartPosY,x1,y1 );
Image1.Canvas.Rectangle(StartPosX+1,StartPosY+1,x1+1,y1+1 );
x1:=trunc(x/image1.Width*Image1.Picture.Bitmap.Width);
y1:=trunc(y/image1.Height*Image1.Picture.Bitmap.Height);
Image1.Canvas.Rectangle(StartPosX,StartPosY ,x1,y1);
Image1.Canvas.Rectangle(StartPosX+1,StartPosY+1,x1+1,y1+1);
end;
end;
 
为了工作,我已经没血了
 

Similar threads

后退
顶部