模仿QQ。delphi截圖(10分)

来自：hb_126, 时间：2006-4-11 9:15:58, ID：3410744
一个简单的例子
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Button2: TButton;
procedure Button2Click(Sender: TObject);
private
MouX, MouY: Integer;
procedure KeyDown1(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure MouseDown1(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseUp1(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);
var
FForm: TForm;
l:longint;
begin
Application.CreateForm(TForm,FForm);
with FForm do
begin
WindowState := wsMaximized;
BorderStyle := bsNone;
l:=GetWindowLong(Handle, GWL_EXSTYLE);
l := l Or $80000;
SetWindowLong (Handle, GWL_EXSTYLE, l);
SetLayeredWindowAttributes(Handle, 0, 1, 2);
OnKeyDown := KeyDown1;
OnMouseDown := MouseDown1;
OnMouseUp := MouseUp1;
ShowModal;
end;
end;

procedure TForm1.KeyDown1(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_ESCAPE then
begin
(Sender as TForm).Close;
end;
end;

procedure TForm1.MouseDown1(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
p: TPoint;
begin
GetCursorPos(P);
MouX := P.X;
MouY := p.Y;
end;

procedure TForm1.MouseUp1(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Mybmp : Tbitmap;
Mycan : Tcanvas;
dc: Integer;
R : TRect;
FPixFmt : TPixelFormat;
p: TPoint;
begin
FPixFmt := pf32bit;
Mybmp := Tbitmap.Create;
Mycan := TCanvas.Create;
dc := GetwindowDC(0);
try
Mycan.Handle := DC;
GetCursorPos(P);
R := Rect(MouX, MouY, P.X, P.Y);
Mybmp.Width := R.Right;
Mybmp.Height := R.Bottom;
Mybmp.PixelFormat := FPixFmt;
BitBlt(Mybmp.Canvas.Handle, MouX, MouY, P.X, P.Y, Mycan.Handle, 0, 0, SRCCOPY);
Mybmp.Canvas.CopyRect(R, Mycan, R);
finally
ReleaseDC(0, DC);
end;
Mycan.Handle := 0;
Mycan.Free;

self.Image1.Picture.Bitmap := Mybmp;
end;

end.


来自：pllink_qyd, 时间：2006-4-11 9:41:11, ID：3410775 | 编辑
hb_126:首先很感謝你為我解答，那少少分就當我的一點心意吧。。我的MSN，qyd_0591@hotmail.com..希望你能加我。。做個朋友。其實我想拜師。
其次,為什麼你最後的那個我運行的時候。。會提示這個錯誤：
Project Project1.exe raised exception class EReadError with message 'Invalid property value'.
這個是什麼原因阿？

麻煩各位也試下。。然後把解決結果告訴我。好嗎？

分少不是表示我吝嗇，而是我想問更多的問題。。
上面的代碼運行的時候。。會提示這個錯誤：
Project Project1.exe raised exception class EReadError with message 'Invalid property value'.
這個是什麼原因阿？麻煩各位幫幫忙

現在我調試沒有問題的。。但上面那段代碼不行阿。。沒辦法實現截圖效果阿。。誰能改下？

你哪个计算 R := Rect(MouX, MouY, P.X, P.Y);的是计算源距形大小（也就是鼠标框选大小）
所以下面哪个CopyRect
要计算目标距形大小Rect(0, 0, R.Right-r.Left, r.Bottom-r.Top)

// BitBlt(Mybmp.Canvas.Handle, MouX, MouY, P.X, P.Y, Mycan.Handle, 0, 0, SRCCOPY);
Mybmp.Canvas.CopyRect(Rect(0, 0, R.Right-r.Left, r.Bottom-r.Top), Mycan, R);

TO lqcros:
謝謝。通過你的方法，我現在可以畫了。但很不穩定。一會兒可以。。一會兒又不行，而且畫面是個小小白色的一塊canvas。。為什麼阿？怎麼操作才讓它出來阿？

是不是要加點什麼時間控制阿？我怎麼感覺太快的畫。一定不行。點了好幾下。突然畫了一塊白布出來了。。誰試過了嗎？是不是有同樣的問題阿？能告訴我怎麼解決嗎？還有為什麼會是白布阿？沒有畫面阿？

我可以提一个思路跟你们
你不是要截屏吗，
先截一个全屏复制到一个Canvas,
再生成一个跟屏幕一样大小的窗体，在窗体上画出Canvas,
然后再在上面选择要复制的块，并調好大小后，双击窗体后，复制到你要的地方，同时关闭窗体

其实我觉得QQ哪个截图也应该是这样的吧，先全屏截取，再截取自已想要的

TO lqcros:
不好意思，你說的我是懂拉。。但我就是不懂得怎麼做，我想知道源碼。。然後自己慢慢分析理解！！

晕，

第一个
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
Mybmp : Tbitmap;
Mycan : Tcanvas;
dc: Integer;
R : TRect;
FPixFmt : TPixelFormat;
p: TPoint;
begin
FPixFmt := pf32bit;
Mybmp := Tbitmap.Create;
Mycan := TCanvas.Create;
dc := GetwindowDC(0);
try
Mycan.Handle := DC;
R := Rect(0, 0, Screen.Width, Screen.Height);
Mybmp.Width := R.Right;
Mybmp.Height := R.Bottom;
Mybmp.PixelFormat := FPixFmt;
Mybmp.Canvas.CopyRect(R, Mycan, R);
finally
ReleaseDC(0, DC);
end;
Mycan.Handle := 0;
Mycan.Free;

self.Image1.Picture.Bitmap := Mybmp;

Form2.Show;


end;

end.


第二个文件

unit Unit2;

interface

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

type
TForm2 = class(TForm)
procedure FormDblClick(Sender: TObject);
procedure FormPaint(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);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form2: TForm2;
press: boolean;
Start, End1, OldPoint: TPoint;


implementation

uses Unit1;

{$R *.dfm}

procedure TForm2.FormDblClick(Sender: TObject);
begin
//这里就用来截取哈
Close;
end;

procedure TForm2.FormPaint(Sender: TObject);
begin
Canvas.CopyRect(Rect(0,0,Screen.Width, Screen.Height), Form1.Image1.Canvas, Rect(0,0,Screen.Width, Screen.Height));
Canvas.Font.Size := 32;
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := clRed;
Canvas.TextOut(0, 0 ,'双击退出');

Canvas.TextOut(0, 30 ,IntTOStr(Start.X));



end;

procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
press := true;
start.X := X;
start.Y := Y;
End1.X := X;
End1.Y := y;
OldPoint.X := X;
OldPoint.Y := y;


Canvas.Pen.Mode := pmXor;
Canvas.Pen.Color := clWhite;
Canvas.Rectangle(Start.X, Start.y, End1.X, End1.Y);
// Canvas.Brush.Style := bsClear;

end;
end;

procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if press = true then
begin


Canvas.Rectangle(Start.X, Start.y, OldPoint.X, OldPoint.Y);

OldPoint.X := End1.X;
OldPoint.y := End1.y;

End1.X := X;
End1.Y := y;

Canvas.Rectangle(Start.X, Start.y, End1.X, End1.Y);


end;
end;

procedure TForm2.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Press := false;
Start.X := 0;
Start.Y := 0;
End1.X := 0;
End1.Y := 0;
end;

end.

TO lqcros:
謝謝。。真的很感謝你.能加我MSN嗎？：qyd_0591@hotmail.com
或者加我QQ：28925043。我今年22歲，要是你比我大的話。。我能
拜你為師嗎？waiting....

不過好像還不能完全實現。。在拖拉鼠標的時候。。沒辦法定第一點。。看樣子想做QQ截圖那樣子沒那麼容易阿。。

哈哈，的确是啦，我用的是XORPEN，如果你要可以改变距形大小的话，在网上查查资料哈

第一个文件
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Image2: TImage;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
Mybmp : Tbitmap;
Mycan : Tcanvas;
dc: Integer;
R : TRect;
FPixFmt : TPixelFormat;
p: TPoint;
begin
FPixFmt := pf32bit;
Mybmp := Tbitmap.Create;
Mycan := TCanvas.Create;
dc := GetwindowDC(0);
try
Mycan.Handle := DC;
R := Rect(0, 0, Screen.Width, Screen.Height);
Mybmp.Width := R.Right;
Mybmp.Height := R.Bottom;
Mybmp.PixelFormat := FPixFmt;
Mybmp.Canvas.CopyRect(R, Mycan, R);
finally
ReleaseDC(0, DC);
end;
Mycan.Handle := 0;
Mycan.Free;


Image2.Picture.Bitmap := Mybmp;

Form2.Show;


end;

end.


下面是第二个文件，我用了双缓冲DoubleBuffered ,不会闪了
unit Unit2;

interface

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

type
TForm2 = class(TForm)
procedure FormDblClick(Sender: TObject);
procedure FormPaint(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 FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form2: TForm2;
press: boolean;
Start, End1: TPoint;


implementation

uses Unit1;

{$R *.dfm}

procedure TForm2.FormDblClick(Sender: TObject);
var
mybmp: TBitmap;
begin
//这里就用来截取哈

mybmp := TBitmap.Create;
mybmp.Width := End1.X - Start.X;
mybmp.Height := End1.Y - Start.Y;

Form1.Label1.Caption := IntToStr(mybmp.Height) + IntToStr(mybmp.Width);

Mybmp.Canvas.CopyRect(Rect(0,0, mybmp.Width, mybmp.Height), Form1.Image2.Canvas, Rect(start.X, start.Y, end1.X, end1.Y));

Form1.Image1.Picture.Bitmap.Assign(mybmp);

mybmp.SaveToFile('c:/1.bmp');


myBmp.Free;

Close;
end;

procedure TForm2.FormPaint(Sender: TObject);
begin
Canvas.CopyRect(Rect(0,0,Screen.Width, Screen.Height), Form1.Image2.Canvas, Rect(0,0,Screen.Width, Screen.Height));
Canvas.Font.Size := 32;
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := clRed;
Canvas.TextOut(0, 0 ,'双击退出');

Canvas.TextOut(0, 30 ,IntTOStr(Start.X));

Canvas.Rectangle(Start.X, Start.y, End1.X, End1.Y);

end;

procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
begin
press := true;
start.X := X;
start.Y := Y;

Canvas.Rectangle(Start.X, Start.y, End1.X, End1.Y);

end;
end;

procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if (ssLeft in Shift) and (press = true) then
begin
End1.X := X;
End1.Y := y;
Repaint;
end;
end;

procedure TForm2.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
begin
Press := false;
end;

end;

procedure TForm2.FormCreate(Sender: TObject);
begin
Form2.DoubleBuffered := true;
end;

end.

TO lqcros：
你是我在DFW裡面遇到最熱心的人了。。就算你不收我為徒。。我也要向你敬禮！！真的十分感謝。。THANKS。我不結貼。。是因為我向讓更多的人知道你。。我的貼從來分都很少的。。但熱心的人我都會留住。。

你结帖了别人照样可以看到，不给分不要拿这种理由来，不厚到！

哈哈，哪里，只不过我今天有空，可帮帮你啦，

哦。我的意思是我給分了。我就不能把問題提前了。。我給分了。。我是剛來的。不懂，。見諒！