//主要思路是guanyueguan(BCB_DG)http://iamgyg.blog.163.com的高速屏传代码
这是其中主要的代码
unit UntMonitorThread;
interface
uses
IdTCPClient, Classes, windows,Graphics,ZLibEx,IdGlobal;
const
DEF_STEP = 19;
OFF_SET = 24;
type
PCapCmd = ^TCapCmd;
TCapCmd = packed record
Cmd: Byte;
Size: Integer;
Width: Word;
Height: Word;
end;
PCtlCmd = ^TCtlCmd;
TCtlCmd = packed record
Cmd: Byte;
X, Y: Word;
end;
TStripMonitorThread = class(TThread)
private
FScrStream: TMemoryStream;
FSendStream: TMemoryStream;
FFullBmp, FLineBmp, FRectBmp: TBitmap;
FWidth, FHeight, FLine: Integer;
FRect: TRect;
FDC: HDC;
FSocket: TIdTCPClient;
FCmd: TCapCmd;
FPixelFormat: TPixelFormat;
FIncSize: Byte;
first:boolean;
//
function CheckScr: Boolean;
function GetFirst: Boolean;
function GetNext: Boolean;
function Compress: Boolean;
function SendInfo: Boolean;
function SendData: Boolean;
procedure CopyRect(rt: TRect);
procedure SetPixelFormat(Value: TPixelFormat);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
property Socket: TIdTCPClient read FSocket;
property PixelFormat: TPixelFormat read FPixelFormat write SetPixelFormat;
end;
implementation
uses Unit1,DisposalCmdUnit;
constructor TstripMonitorThread.Create;
begin
inherited Create(true);
FSocket:=TIdTCPClient.Create(nil);
//Fsocket.IOHandler.RecvBufferSize:= 4096;
// Fsocket.IOHandler.SendBufferSize:= 4096;
//Fsocket.ReadTimeout:=15000;
FScrStream := TMemoryStream.Create;
FSendStream := TMemoryStream.Create;
FFullBmp := TBitmap.Create;
FLineBmp := TBitmap.Create;
FRectBmp := TBitmap.Create;
FWidth := 0;
FHeight := 0;
FIncSize := 4;
//case ThisPicPixFmt of //转换的像素颜色位 1 2 4 8 16 24 32
FPixelFormat := pf8bit;
// 5: FPixelFormat := pf32bit;
// else
// FPixelFormat := pf32bit;
// end;
FreeOnTerminate := True; //主动释放,不是自动释放
Suspended := False; //立即执行
ScreenOver:=True;
end;
destructor TStripMonitorThread.Destroy;
begin
FSocket.Free;
ScreenOver:=false;
FScrStream.Free;
FSendStream.Free;
FRectBmp.Free;
FFullBmp.Free;
FLineBmp.Free;
inherited destroy;
end;
procedure TStripMonitorThread.Execute;
var
CmdBuf: array[0..SizeOf(TCtlCmd) - 1] of Byte;
pt: TPoint;
Request:string;
buf:TidBytes;
begin
if form1.ConRpcport(FSocket) then
begin
try
FSocket.IOHandler.Write('002'+EOL);
except
FSocket.Free;
Exit;
end;
Request:=FSocket.IOHandler.ReadLn(EOL);
end;
if CheckScr then First :=true;
try
repeat
FSocket.IOHandler.ReadBytes(buf, SizeOf(TCtlCmd));
BytesToRaw(buf,CmdBuf,sizeof(TCtlCmd));
if TCtlCmd(CmdBuf).Cmd in [1..5] then
begin
pt := Point(TCtlCmd(CmdBuf).X, TCtlCmd(CmdBuf).Y);
SetCursorPos(pt.X, pt.Y);
SetCapture(WindowFromPoint(pt));
end;
case TCtlCmd(CmdBuf).Cmd of
8: if First then GetFirst else GetNext;
0: PixelFormat := TPixelFormat(TCtlCmd(CmdBuf).X);
1: ;//mouse move
2: mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
3: mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
4: mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);
5: mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);
6: keybd_event(Byte(TCtlCmd(CmdBuf).X), MapVirtualKey(Byte(TCtlCmd(CmdBuf).X), 0), 0, 0);
7: keybd_event(Byte(TCtlCmd(CmdBuf).X), MapVirtualKey(Byte(TCtlCmd(CmdBuf).X), 0), KEYEVENTF_KEYUP, 0);
end;
until FSocket.Connected=False;
except
end;
FSocket.Disconnect;
end;
function TStripMonitorThread.CheckScr: Boolean;
var
nWidth, nHeight: Integer;
begin
Result := False;
nWidth := GetSystemMetrics(SM_CXSCREEN);//取得屏幕长宽
nHeight := GetSystemMetrics(SM_CYSCREEN);
if (nWidth <> FWidth) or (nHeight <> FHeight) then
begin
FWidth := nWidth;
FHeight := nHeight;
FFullBmp.Canvas.Lock;
FLineBmp.Canvas.Lock;
FRectBmp.Canvas.Lock;
FFullBmp.Width := FWidth;
FFullBmp.Height := FHeight;
FLineBmp.Width := FWidth;
FLineBmp.Height := 1;
FFullBmp.PixelFormat := FPixelFormat;
FLineBmp.PixelFormat := FPixelFormat;
FRectBmp.PixelFormat := FPixelFormat;
FFullBmp.Canvas.Unlock;
FLineBmp.Canvas.Unlock;
FRectBmp.Canvas.Unlock;
FLine := 0;
Result := True;
end;
end;
//压缩数据
function TStripMonitorThread.Compress: Boolean;
begin
Result := False;
try
FSendStream.Clear;
FScrStream.Position := 0;
ZCompressStream(FScrStream, FSendStream);
FSendStream.Position := 0;
Result := True;
except
end;
end;
procedure TStripMonitorThread.CopyRect(rt: TRect);
begin
FFullBmp.Canvas.Lock;
FRectBmp.Canvas.Lock;
try
FRectBmp.Width := rt.Right - rt.Left;//截取的图片宽与高
FRectBmp.Height := rt.Bottom - rt.Top;
BitBlt(FFullBmp.Canvas.Handle, rt.Left, rt.Top, FRectBmp.Width, FRectBmp.Height, FDC, rt.Left, rt.Top, SRCCOPY);
BitBlt(FRectBmp.Canvas.Handle, 0, 0, FRectBmp.Width, FRectBmp.Height, FFullBmp.Canvas.Handle, rt.Left, rt.Top, SRCCOPY);
FScrStream.WriteBuffer(FRect, SizeOf(TRect));
FRectBmp.SaveToStream(FScrStream);
finally
FFullBmp.Canvas.Unlock;
FRectBmp.Canvas.Unlock;
end;
end;
//拷第一个图
function TStripMonitorThread.GetFirst: Boolean;
begin
Result := False;
FDC := GetDC(0);
FFullBmp.Canvas.Lock;
BitBlt(FFullBmp.Canvas.Handle, 0, 0, FWidth, FHeight, FDC, 0, 0, SRCCOPY);//
FFullBmp.Canvas.Unlock;
ReleaseDC(0, FDC);
SetRect(FRect, 0, 0, FWidth, FHeight);//赋值FRect
FScrStream.Clear;
FScrStream.WriteBuffer(FRect, SizeOf(TRect)); //把FRect读入流
FFullBmp.SaveToStream(FScrStream); //把图片也读入流中
if Compress and SendInfo then Result := SendData; //压缩并且发送数据
First :=not Result;
end;
//后续屏幕
function TStripMonitorThread.GetNext: Boolean;
var
p1, p2: PDWORD;
i, j: Integer;
begin
Result := False;
FScrStream.Clear;
FDC := GetDC(0);
i := FLine;
while i < FHeight do
begin
FLineBmp.Canvas.Lock;
BitBlt(FLineBmp.Canvas.Handle, 0, 0, FWidth, 1, FDC, 0, i, SRCCOPY);//逐行
FLineBmp.Canvas.Unlock;
p1 := FFullBmp.ScanLine[i];
p2 := FLineBmp.ScanLine[0];
SetRect(FRect, -1, i - DEF_STEP, -1, i + DEF_STEP * 2);//初始化FRect
//Left Top Right Bottom
j := 0;
while j < FWidth do
begin
if (p1^ <> p2^) then
begin
if (FRect.Right < 0) then FRect.Left := j - OFF_SET;
FRect.Right := j + OFF_SET;
end;
Inc(p1);
Inc(p2);
Inc(j, FIncSize);
end;
if (FRect.Right > -1) then //如果屏幕有变化
begin
with FRect do
begin
Left := Max(Left, 0);
Top := Max(Top, 0);
Right := Min(Right, FWidth);
Bottom := Min(Bottom, FHeight);
end;
CopyRect(FRect);
Inc(i, DEF_STEP);
end;
Inc(i, DEF_STEP);
end;
ReleaseDC(0, FDC);
FLine := (FLine + 3) mod DEF_STEP; //?
if (FScrStream.Position > 0) and Compress then Result := SendData;
end;
function TStripMonitorThread.SendInfo: Boolean;
begin
try
FCmd.Cmd := 1; //发送第一副图
FCmd.Size := 0;
FCmd.Width := FWidth; //传屏幕长宽
FCmd.Height := FHeight;
FSocket.IOHandler.Write(RawToBytes(FCmd, SizeOf(TCapCmd)));
Result := True;
except
Result := False;
end;
end;
function TStripMonitorThread.SendData: Boolean;
begin
try
FCmd.Cmd := 2;
FCmd.Size := FSendStream.Size;
FSocket.IOHandler.Write(RawToBytes(FCmd, SizeOf(TCapCmd)));
FSocket.IOHandler.Write(FSendStream,FCmd.Size,false);
Result := True;
except
Result := False;
end;
end;
procedure TStripMonitorThread.SetPixelFormat(Value: TPixelFormat);
begin
if (FPixelFormat <> Value) then
begin
FPixelFormat := Value;
case FPixelFormat of
pf1bit: FIncSize := 32;
pf4bit: FIncSize := 8;
pf8bit: FIncSize := 4;
pf16bit: FIncSize := 2;
pf32bit: FIncSize := 1;
else
FPixelFormat := pf8bit;
FIncSize := 4;
end;
FFullBmp.PixelFormat := FPixelFormat;
FLineBmp.PixelFormat := FPixelFormat;
FRectBmp.PixelFormat := FPixelFormat;
end;
end;
end.
//以下为主控制端///
unit showpic;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, IdTCPServer,ComCtrls, ZLibEx,IdGlobal, Menus,
ExtCtrls,RemoteScrUnit,IdContext, Buttons, StdCtrls;
type
Tshowpm = class;
PCapCmd = ^TCapCmd;
TCapCmd = packed record
Cmd: Byte;
Size: Integer;
Width: Word;
Height: Word;
end;
PCtlCmd = ^TCtlCmd;
TCtlCmd = packed record
Cmd: Byte;
X, Y: Word;
end;
PMyData = ^TMyData;
TMyData = packed record
Socket: TIdContext;
Form: Tshowpm;
//Item: TListItem;
Color: Byte;
end;
PPMyData = ^PMyData;
Tshowpm = class(TForm)
Panel1: TPanel;
StopButton: TSpeedButton;
StartButton: TSpeedButton;
ShubiaoButton: TSpeedButton;
jianpanButton: TSpeedButton;
SpeedButton5: TSpeedButton;
winButton: TSpeedButton;
ShiftButton: TSpeedButton;
ctrlButton: TSpeedButton;
altButton: TSpeedButton;
escButton: TSpeedButton;
tabButton: TSpeedButton;
sba: TScrollBox;
pba: TPaintBox;
tmrA: TTimer;
Timer1: TTimer;
StatusBar1: TStatusBar;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure pbaMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbaMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure pbaMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
//procedure pbaPaint(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure StartButtonClick(Sender: TObject);
procedure tmrATimer(Sender: TObject);
procedure StopButtonClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure SpeedButton5Click(Sender: TObject);
procedure pbaPaint(Sender: TObject);
procedure Edit1Change(Sender: TObject);
protected
procedure CreateParams(var Params: TCreateParams); override;
private
FRecBmp, FFullBmp: TBitmap;
FRecStream: TMemoryStream;
FScrStream: TMemoryStream;
FButton: TMouseButton;
FCCmd: TCtlCmd;
FRect: TRect;
FControl: Boolean;
speed,Thetime,color:integer;
//FData: Tshowpm;
procedure SetSize(nWidth, nHeight: Word);
procedure SendCmd(ACmd: TCtlCmd);
procedure SendCmdA(ACmd: TCtlCmd);
procedure showimage;
// procedure CheckMenu(var Msg: TMessage); message WM_SYSCOMMAND;
public
FSocket : TIdContext;
procedure ReadData;
//property Data: Tshowpm read FData write FData;
end;
var
showpm: Tshowpm;
Num,speed,averageSpeed,tm:Integer;
totalrev :Int64;
implementation
uses Unit1;
{$R *.dfm}
{ Tshowpm }
function FormatSize (size : Int64 ):string; //将字节转换成易读的单位
begin
if Size < 1024 then
Result := Format('%dByte',[Size])
else if (Size >= 1024) and (Size < (1024*1024)) then
Result := Format('%.2fKB',[Size / 1024])
else if (Size >= (1024*1024)) and (Size < (1024*1024*1024))then
Result := Format('%.2fMB',[Size / (1024*1024)])
else
Result := Format('%.2fGB',[Size / (1024*1024*1024)]);
end;
procedure Tshowpm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.WndParent := 0;
end;
procedure Tshowpm.SendCmd(ACmd: TCtlCmd);
var
sby:TidBytes;
begin
if Assigned(FSocket) and (FSocket.Connection.Connected) and CurrentThread.Connection.Connected then
begin
sBy:=RawTOBytes(ACmd,SizeOf(TCtlCmd));
form1.ZhuDongCmdSend('013', '0', True);
CurrentThread.Connection.IOHandler.Write(sBy);
end;
end;
procedure Tshowpm.SendCmdA(ACmd: TCtlCmd);
var
sby:TidBytes;
begin
if Assigned(FSocket) and FSocket.Connection.Connected then
begin
sBy:=RawTOBytes(ACmd,SizeOf(TCtlCmd));
FSocket.Connection.IOHandler.Write(sBy);
end;
end;
procedure Tshowpm.SetSize(nWidth, nHeight: Word);
begin
if (pbA.Width <> nWidth) or (pbA.Height <> nHeight) then
begin
sbA.HorzScrollBar.Position:=0;//增加
sbA.VertScrollBar.Position:=0;//增加
pbA.Left := 0;
pbA.Top := 0;
pbA.Width := nWidth;
pbA.Height := nHeight;
//ClientWidth := nWidth;
//ClientHeight := nHeight;
FFullBmp.Width := nWidth;
FFullBmp.Height := nHeight;
end;
end;
procedure Tshowpm.FormCreate(Sender: TObject);
begin
inherited;
sba.DoubleBuffered := True;
//FSysMenu := GetSystemMenu(Handle, False);
//AppendMenu(FSysMenu, MF_SEPARATOR, IDM_SEP, nil);
//AppendMenu(FSysMenu, MF_STRING, IDM_CTRL, IDM_CTRLS);
FControl := False;
//FView := nil;
FRecBmp := TBitmap.Create;
FFullBmp := TBitmap.Create;
FRecStream := TMemoryStream.Create;
FScrStream := TMemoryStream.Create;
end;
procedure Tshowpm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
inherited;
tmrA.Enabled := False;
timer1.Enabled := false;
jianpanButton.Down:=False;
ShubiaoButton.Down:=False;
StopButton.Down:=True;
if fsocket<>nil then
FSocket.Connection.Disconnect;
//Fdata :=nil;
FRecBmp.Free;
FFullBmp.Free;
FRecStream.Free;
FScrStream.Free;
FRecBmp := nil;
FFullBmp := nil;
FRecStream := nil;
FScrStream := nil;
Action := caFree;
end;
procedure Tshowpm.showimage;
begin
{ if (pba.Width<>FFullBmp.Width)
or (pba.Height <> FFullBmp.Height) then
begin
pba.Top:=0;
pba.Left:=0;
pba.Width := FFullBmp.Width;
pba.Height := FFullBmp.Height;
end;
pbA.Canvas.Lock;
FFullBmp.Canvas.Lock;
pba.Canvas.Draw(0, 0, FFullBmp);
FFullBmp.Canvas.Unlock;
pbA.Canvas.Unlock; }
try
pbA.Canvas.Lock;
FFullBmp.Canvas.Lock;
//BitBlt(pbA.Canvas.Handle, 0, 0, FFullBmp.Width, FFullBmp.Height, FFullBmp.Canvas.Handle, 0, 0, SRCCOPY);
BitBlt(pbA.Canvas.Handle,
sbA.HorzScrollBar.Position,
sbA.VertScrollBar.Position,
sbA.Width,
sbA.Height,
FFullBmp.Canvas.Handle,
sbA.HorzScrollBar.Position,
sbA.VertScrollBar.Position,
SRCCOPY);
FFullBmp.Canvas.Unlock;
pbA.Canvas.Unlock;
except
end;
end;
procedure Tshowpm.ReadData;
var
CmdBuf: array[0..SizeOf(TCapCmd) - 1] of Byte;
Buffer: array[0..4095] of Byte;
i: Integer;
buf:TidBytes;
begin
tmrA.Enabled := True;
//FRecStream := TMemoryStream.Create;
//FScrStream := TMemoryStream.Create;
while (Fsocket.Connection.Connected) do
begin
try
FSocket.Connection.IOHandler.ReadBytes(buf,sizeof(TCapCmd));
BytesToRaw(buf,CmdBuf,sizeof(TCapCmd));
buf:=0;
if TCapCmd(CmdBuf).Cmd = 1 then SetSize(TCapCmd(CmdBuf).Width, TCapCmd(CmdBuf).Height)
else if TCapCmd(CmdBuf).Cmd = 2 then
begin
FRecStream.Clear;
Inc(Num );
i:= TCapCmd(CmdBuf).Size;
StatusBar1.Panels[0].Text := Format('正在接受第%d帧,大小%dByte',[Num,i]);
//try
FSocket.Connection.IOHandler.ReadStream(FRecStream,TCapCmd(CmdBuf).Size,False);
//except
{ if (Fsocket.Connection.Connected= false) then
begin
FRecStream.Free;
FScrStream.Free;
exit;
end; }
//end;
FRecStream.Position := 0;
FScrStream.Clear;
ZDecompressStream(FRecStream, FScrStream);
FScrStream.Position := 0;
//FRecBmp := TBitmap.Create;
try
while FScrStream.Position < FScrStream.Size do
begin
FScrStream.Read(FRect, SizeOf(TRect));//不断的读出发生变化的区块
with FRecBmp do
begin
Width := FRect.Right - FRect.Left;
Height := FRect.Bottom - FRect.Top;
LoadFromStream(FScrStream);
end;
FFullBmp.Canvas.Lock;
FRecBmp.Canvas.Lock;
FFullBmp.Canvas.Draw(FRect.Left, FRect.Top, FRecBmp); //把变化的区块填入
FRecBmp.Canvas.Unlock;
FFullBmp.Canvas.Unlock;
end;
Inc(totalrev,i);
Inc(speed );
finally
//FRecBmp.Free;
Application.ProcessMessages; //连续抓屏
end;
//showimage;
pbaPaint(nil)
end;
except
Fsocket.Connection.Disconnect;
end;
end;
//until (Fsocket.Connection.Connected= false);
//FRecStream.free;
//FScrStream.free;
tmrA.Enabled := false;
end;
procedure Tshowpm.pbaMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ShubiaoButton.Down =true then
begin
FButton := Button;
FCCmd.X := X;
FCCmd.Y := Y;
if FButton = mbLeft then
FCCmd.Cmd := 3
else
FCCmd.Cmd := 5;
SendCmd(FCCmd);
end;
end;
procedure Tshowpm.pbaMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if ShubiaoButton.Down =true then
begin
FCCmd.Cmd := 1;
FCCmd.X := X;
FCCmd.Y := Y;
SendCmd(FCCmd);
end;
end;
procedure Tshowpm.pbaMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ShubiaoButton.Down =true then
begin
FButton := Button;
FCCmd.X := X;
FCCmd.Y := Y;
if FButton = mbLeft then
FCCmd.Cmd := 2
else
FCCmd.Cmd := 4;
SendCmd(FCCmd);
end;
end;
procedure Tshowpm.FormKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if jianpanButton.Down =true then
begin
FCCmd.Cmd := 7;
FCCmd.X := Key;
SendCmd(FCCmd);
end;
end;
procedure Tshowpm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if jianpanButton.Down =true then
begin
FCCmd.Cmd := 6;
FCCmd.X := Key;
SendCmd(FCCmd);
end;
end;
procedure Tshowpm.StartButtonClick(Sender: TObject);
begin
form1.ZhuDongCmdSend('013', '0', True);
timer1.Enabled := true;
Num := 0;
averageSpeed :=0;
tm:=0;
totalrev := 0;
end;
procedure Tshowpm.tmrATimer(Sender: TObject);
begin
tmrA.Enabled := False;
FCCmd.Cmd := 8;
SendCmdA(FCCmd);
tmrA.Enabled := True;
end;
procedure Tshowpm.StopButtonClick(Sender: TObject);
begin
form1.ZhuDongCmdSend('004', '0', True);
if assigned( Fsocket) then
fsocket.Connection.Disconnect;
tmrA.Enabled := false;
timer1.Enabled := false;
end;
{procedure Tshowpm.SpeedButton5Click(Sender: TObject);
begin
RemoteScrFm.ShowModal;
if RemoteScrFm.Tag =0 then exit;
case RemoteScrFm.RadioGroup2.ItemIndex of
0: color := 1;
1: color := 2;
2: color := 3;
3: color := 5;
4: color := 7;
else
color := 3;
end;
FCCmd.Cmd := 0;
FCCmd.X := color;
SendCmdA(FCCmd);
end;}
//测试用
procedure Tshowpm.Timer1Timer(Sender: TObject);
begin
StatusBar1.Panels[1].Text := Format('当前:%d帧/s',[speed ]);
Inc(averageSpeed,speed);
Inc(tm);
StatusBar1.Panels[2].Text := Format('平均:%d帧/s',[averageSpeed div tm]);
speed := 0;
StatusBar1.Panels[3].Text := Format('平均速度:%s/s',[FormatSize(totalrev div tm )]);
StatusBar1.Panels[4].Text := '总共传输数据量:'+FormatSize(totalrev);
end;
procedure Tshowpm.SpeedButton5Click(Sender: TObject);
begin
RemoteScrFm.ShowModal;
if RemoteScrFm.Tag =0 then exit;
case RemoteScrFm.RadioGroup2.ItemIndex of
0: color := 1;
1: color := 2;
2: color := 3;
3: color := 5;
4: color := 7;
else
color := 3;
end;
FCCmd.Cmd := 0;
FCCmd.X := color;
SendCmdA(FCCmd);
end;
procedure Tshowpm.pbaPaint(Sender: TObject);
begin
try
pbA.Canvas.Lock;
FFullBmp.Canvas.Lock;
//BitBlt(pbA.Canvas.Handle, 0, 0, FFullBmp.Width, FFullBmp.Height, FFullBmp.Canvas.Handle, 0, 0, SRCCOPY);
BitBlt(pbA.Canvas.Handle,
sbA.HorzScrollBar.Position,
sbA.VertScrollBar.Position,
sbA.Width,
sbA.Height,
FFullBmp.Canvas.Handle,
sbA.HorzScrollBar.Position,
sbA.VertScrollBar.Position,
SRCCOPY);
FFullBmp.Canvas.Unlock;
pbA.Canvas.Unlock;
except
end;
end;
procedure Tshowpm.Edit1Change(Sender: TObject);
begin
tmrA.Interval :=strtoint(edit1.text);
end;
end.