150分求“每秒抓超过7次的整屏图像到文件中(仅80060016M色就可以了)”(50分)

dark_eagle · 2001-10-21

我试过了,有时可以,有时又不行,大家一起努力吧!

硬木花椒 · 2001-10-21

多线程同时启用不行吗？

wql · 2001-10-22

好！继续！

wql · 2001-10-24

to xwings:

1. 我是信守诺言的！发email: wqlem@km169.net后或贴出来，继续加分都好商量，
你开个价！

2. 其他的同志也一样要信守诺言，若xwings发布后，你们要另开问题让xwings去白
拿分数。

3. 希望看过的同志和准备发表的同志把下面这句话加在后面：

“同志们：请把问题提前，谢谢！！！”

wanxu · 2001-11-01

xwings,wgl：
你们正在讨论的问题我很感兴趣，我现在正在做一个局域网的管理系统，在同一时间需要
对网络中的一台计算机进行屏幕监控，至于颜色要求倒不高，256色足也！被监控的机器有
800×600，也有1024×768。但是我在监控端只是需要280×160左右的显示区域，被抓取的
图象可以不保存，你们有好的建议吗？我用的是socket进行通讯！！我的OICQ：173472；
我的电子邮件：waxu@btamail.net.cn

xwings · 2001-11-05

sorry... )

最近机器出了点问题. 没有上DFW. 而且我现在在写一个ADO的数据库. 呵呵. 我不太会. 所以
directx的抓屏暂时停顿一下, 谢谢大家.

现在我把程序原型贴出来. 大家一起修改一下, 我的程序中没有任何优化措施的.高手看看如何优化拉.
有兴趣的看看算法如何修改.

以后我想实现图象缩放就是 wangxu 说的监控端的缩小显示. 还有更好的压缩方法(基本上还是rle,
这样速度和实现难度最简单)等等.

xwings · 2001-11-05

代码:

<code><pre>
<font face="Courier New"><font color="#000080">unit</font> Unit1<font color="#000080">;</font>

<font color="#000080">interface</font>

<font color="#000080">uses</font>
  Windows<font color="#000080">,</font> Messages<font color="#000080">,</font> SysUtils<font color="#000080">,</font> Classes<font color="#000080">,</font> Graphics<font color="#000080">,</font> Controls<font color="#000080">,</font> Forms<font color="#000080">,</font> Dialogs<font color="#000080">,</font>
  DXDraws<font color="#000080">,</font> StdCtrls<font color="#000080">,</font>DXClass<font color="#000080">,</font> DirectX<font color="#000080">,</font>RLEUnit<font color="#000080">;</font>

<font color="#000080">type</font>
  TRGB16<font color="#000080">=</font>TWordArray<font color="#000080">;</font>
  PRGB16<font color="#000080">=</font><font color="#000080">^</font>TRGB16<font color="#000080">;</font>

  TForm1 <font color="#000080">=</font> <font color="#000080">class</font><font color="#000080">(</font>TForm<font color="#000080">)</font>
    DXDraw1<font color="#000080">:</font> TDXDraw<font color="#000080">;</font>
    DXTimer1<font color="#000080">:</font> TDXTimer<font color="#000080">;</font>
    Label1<font color="#000080">:</font> TLabel<font color="#000080">;</font>
    <font color="#000080">procedure</font> DXDraw1InitializeSurface<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
    <font color="#000080">procedure</font> DXDraw1FinalizeSurface<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>

    <font color="#000080">procedure</font> FormClose<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">;</font> <font color="#000080">var</font> Action<font color="#000080">:</font> TCloseAction<font color="#000080">)</font><font color="#000080">;</font>
    <font color="#000080">procedure</font> FormShow<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
    <font color="#000080">procedure</font> DXTimer1Timer<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">;</font> LagCount<font color="#000080">:</font> Integer<font color="#000080">)</font><font color="#000080">;</font>
    <font color="#000080">procedure</font> FormCreate<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
  <font color="#000080">private</font>
    <font color="#800000">{ Private declarations }</font>
  <font color="#000080">public</font>
    <font color="#800000">{ Public declarations }</font>
  <font color="#000080">end</font><font color="#000080">;</font>
<font color="#000080">const</font>
  WW<font color="#000080">:</font>Integer<font color="#000080">=</font><font color="#FF0000">640</font><font color="#000080">;</font>   <font color="#800000">//抓屏宽度和高度</font>
  HH<font color="#000080">:</font>Integer<font color="#000080">=</font><font color="#FF0000">480</font><font color="#000080">;</font>
<font color="#000080">var</font>
  Form1<font color="#000080">:</font> TForm1<font color="#000080">;</font>
  FSurface<font color="#000080">:</font>TDirectDrawSurface<font color="#000080">;</font>
  ScrDC<font color="#000080">:</font>HDC<font color="#000080">;</font>
  i<font color="#000080">:</font>Integer<font color="#000080">;</font>
  mPos<font color="#000080">:</font>TPoint<font color="#000080">;</font>
  posX<font color="#000080">,</font>posY<font color="#000080">:</font>Integer<font color="#000080">;</font>
  ImgBuf<font color="#000080">:</font>PRGB16<font color="#000080">;</font>

<font color="#000080">procedure</font> ProcImage<font color="#000080">(</font>SrcImgBuf<font color="#000080">:</font>Pointer<font color="#000080">;</font>Count<font color="#000080">:</font>integer<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">implementation</font>
<font color="#000080">uses</font>
  unit2<font color="#000080">;</font>
<font color="#800000">{$R *.DFM}</font>

<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>DXDraw1InitializeSurface<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
<font color="#800000">//Create a offline surface</font>
  FSurface<font color="#000080">:=</font>TDirectDrawSurface<font color="#000080">.</font>Create<font color="#000080">(</font>DXDraw1<font color="#000080">.</font>DDraw<font color="#000080">)</font><font color="#000080">;</font>
  FSurface<font color="#000080">.</font>SetSize<font color="#000080">(</font>WW<font color="#000080">,</font>HH<font color="#000080">)</font><font color="#000080">;</font>
  FSurface<font color="#000080">.</font>SystemMemory<font color="#000080">:=</font>true<font color="#000080">;</font>
  fsurface<font color="#000080">.</font>Fill<font color="#000080">(</font><font color="#FF0000">0</font><font color="#000080">)</font><font color="#000080">;</font>
<font color="#800000">//get Screen DC</font>
  ScrDC<font color="#000080">:=</font>getDC<font color="#000080">(</font><font color="#FF0000">0</font><font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>

<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>DXDraw1FinalizeSurface<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
  FSurface<font color="#000080">.</font>Free<font color="#000080">;</font>
  FSurface<font color="#000080">:=</font><font color="#000080">nil</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>

<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>FormCreate<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
  ImgBuf<font color="#000080">:=</font>GlobalAllocPtr<font color="#000080">(</font>GPTR<font color="#000080">,</font>WW<font color="#000080">*</font>HH<font color="#000080">*</font><font color="#FF0000">2</font><font color="#000080">)</font><font color="#000080">;</font>  <font color="#800000">//16bits</font>

<font color="#000080">end</font><font color="#000080">;</font>
<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>FormClose<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">;</font> <font color="#000080">var</font> Action<font color="#000080">:</font> TCloseAction<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
  DXTimer1<font color="#000080">.</font>Enabled<font color="#000080">:=</font>False<font color="#000080">;</font>
  GlobalFreePtr<font color="#000080">(</font>ImgBuf<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>

<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>FormShow<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
DXTimer1<font color="#000080">.</font>Enabled<font color="#000080">:=</font>True<font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>

<font color="#000080">procedure</font> TForm1<font color="#000080">.</font>DXTimer1Timer<font color="#000080">(</font>Sender<font color="#000080">:</font> TObject<font color="#000080">;</font> LagCount<font color="#000080">:</font> Integer<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">var</font>
<font color="#800000">//the structure of surface</font>
  SurfaceDESC<font color="#000080">:</font>TDDSurfaceDesc<font color="#000080">;</font>
<font color="#000080">begin
</font>
  <font color="#800000">//GetCursorPos(mPos);</font>
  mPos<font color="#000080">.</font>x<font color="#000080">:=</font><font color="#FF0000">400</font><font color="#000080">;</font>
  mPos<font color="#000080">.</font>y<font color="#000080">:=</font><font color="#FF0000">300</font><font color="#000080">;</font>
  <font color="#800000">//clear surface</font>
  FSurface<font color="#000080">.</font>Fill<font color="#000080">(</font><font color="#FF0000">0</font><font color="#000080">)</font><font color="#000080">;</font>
  <font color="#800000">// use hardware bitblt Image form ScreenDC to Surface</font>
  BitBlt<font color="#000080">(</font>FSurface<font color="#000080">.</font>Canvas<font color="#000080">.</font>Handle<font color="#000080">,</font><font color="#FF0000">0</font><font color="#000080">,</font><font color="#FF0000">0</font><font color="#000080">,</font>WW<font color="#000080">,</font>HH<font color="#000080">,</font>ScrDC<font color="#000080">,</font>mPos<font color="#000080">.</font>x<font color="#000080">-</font>WW <font color="#000080">div</font> <font color="#FF0000">2</font><font color="#000080">,</font>mPos<font color="#000080">.</font>y<font color="#000080">-</font>HH <font color="#000080">div</font> <font color="#FF0000">2</font><font color="#000080">,</font>SRCCOPY<font color="#000080">)</font><font color="#000080">;</font>
 <font color="#800000">// Free Surface DC Handel</font>
  FSurface<font color="#000080">.</font>Canvas<font color="#000080">.</font>Release<font color="#000080">;</font>

<font color="#800000">{Get Image Data from Surface bits}</font>
  <font color="#000080">if</font> FSurface<font color="#000080">.</font>Lock<font color="#000080">(</font>SurfaceDESC<font color="#000080">)</font><font color="#000080">=</font>true <font color="#000080">then
</font>
  <font color="#000080">begin
</font>
    ProcImage<font color="#000080">(</font>SurfaceDesc<font color="#000080">.</font>lpSurface<font color="#000080">,</font>WW<font color="#000080">*</font>HH<font color="#000080">*</font><font color="#FF0000">2</font><font color="#000080">)</font><font color="#000080">;</font>
    FSurface<font color="#000080">.</font>UnLock<font color="#000080">;</font>
  <font color="#000080">end</font>
  <font color="#000080">else
</font> Beep<font color="#000080">;</font>
  Caption<font color="#000080">:=</font>Format<font color="#000080">(</font><font color="#008080">'Current FPS: %d'</font><font color="#000080">,</font><font color="#000080">[</font>dxtimer1<font color="#000080">.</font>FrameRate<font color="#000080">]</font><font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>

<font color="#000080">procedure</font> ProcImage<font color="#000080">(</font>SrcImgBuf<font color="#000080">:</font>Pointer<font color="#000080">;</font>Count<font color="#000080">:</font>integer<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">begin
</font>
  Move<font color="#000080">(</font>srcImgBuf<font color="#000080">^</font><font color="#000080">,</font>ImgBuf<font color="#000080">^</font><font color="#000080">,</font>Count<font color="#000080">)</font><font color="#000080">;</font>
  unit2<font color="#000080">.</font>showImg<font color="#000080">(</font>ImgBuf<font color="#000080">,</font>Count<font color="#000080">)</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">;</font>
<font color="#000080">end</font><font color="#000080">.</font></font>
</pre></code>

caowei · 2001-11-05

太高深了.......

看不太懂的说.......

xwings · 2001-11-05

不好意思. 贴错了. )

xwings · 2001-11-05

project1.dpr
///////////////////////////////////////////////////////////////////////////////
program Project1;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin

Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
Application.Run;
end.

///////////////////////////////////// unit1.dfm //////////////////////////////////////////
object Form1: TForm1
Left = 190
Top = 107
BorderStyle = bsSingle
Caption = 'Show Direct Draw '
ClientHeight = 25
ClientWidth = 252
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
FormStyle = fsStayOnTop
OldCreateOrder = False
OnClose = FormClose
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 16
Top = 8
Width = 32
Height = 13
Caption = 'Label1'
end
object DXDraw1: TDXDraw
Left = 0
Top = 0
Width = 0
Height = 0
AutoInitialize = True
AutoSize = True
Color = clBtnFace
Display.BitCount = 16
Display.FixedBitCount = True
Display.FixedRatio = True
Display.FixedSize = False
Display.Height = 768
Display.Width = 1024
Options = [doAllowReboot,do
WaitVBlank,do
Center,do
DirectX7Mode,do
Hardware,do
SelectDriver]
SurfaceHeight = 0
SurfaceWidth = 0
OnFinalizeSurface = DXDraw1FinalizeSurface
OnInitializeSurface = DXDraw1InitializeSurface
TabOrder = 0
end
object DXTimer1: TDXTimer
ActiveOnly = False
Enabled = False
Interval = 0
OnTimer = DXTimer1Timer
Left = 312
Top = 40
end
end

/////////////////////////////////// unit1.pas //////////////////////////////////////////////////
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
DXDraws, StdCtrls,DXClass, DirectX,RLEUnit;

type
TRGB16=TWordArray;
PRGB16=^TRGB16;

TForm1 = class(TForm)
DXDraw1: TDXDraw;
DXTimer1: TDXTimer;
Label1: TLabel;
procedure DXDraw1InitializeSurface(Sender: TObject);
procedure DXDraw1FinalizeSurface(Sender: TObject);

procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure FormShow(Sender: TObject);
procedure DXTimer1Timer(Sender: TObject;
LagCount: Integer);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

const
WW:Integer=640;
//抓屏宽度和高度
HH:Integer=480;
var
Form1: TForm1;
FSurface:TDirectDrawSurface;
ScrDC:HDC;
i:Integer;
mPos:TPoint;
posX,posY:Integer;
ImgBuf

RGB16;

procedure ProcImage(SrcImgBuf

ointer;Count:integer);
implementation
uses
unit2;
{$R *.DFM}

procedure TForm1.DXDraw1InitializeSurface(Sender: TObject);
begin

//Create a offline surface
FSurface:=TDirectDrawSurface.Create(DXDraw1.DDraw);
FSurface.SetSize(WW,HH);
FSurface.SystemMemory:=true;
fsurface.Fill(0);
//get Screen DC
ScrDC:=getDC(0);
end;

procedure TForm1.DXDraw1FinalizeSurface(Sender: TObject);
begin

FSurface.Free;
FSurface:=nil;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

ImgBuf:=GlobalAllocPtr(GPTR,WW*HH*2);
//16bits

end;

procedure TForm1.FormClose(Sender: TObject;
var Action: TCloseAction);
begin

DXTimer1.Enabled:=False;
GlobalFreePtr(ImgBuf);
end;

procedure TForm1.FormShow(Sender: TObject);
begin

DXTimer1.Enabled:=True;
end;

procedure TForm1.DXTimer1Timer(Sender: TObject;
LagCount: Integer);
var
//the structure of surface
SurfaceDESC:TDDSurfaceDesc;
begin

//GetCursorPos(mPos);
mPos.x:=400;
mPos.y:=300;
//clear surface
FSurface.Fill(0);
// use hardware bitblt Image form ScreenDC to Surface
BitBlt(FSurface.Canvas.Handle,0,0,WW,HH,ScrDC,mPos.x-WW div 2,mPos.y-HH div 2,SRCCOPY);
// Free Surface DC Handel
FSurface.Canvas.Release;

{Get Image Data from Surface bits}
if FSurface.Lock(SurfaceDESC)=true then

begin

ProcImage(SurfaceDesc.lpSurface,WW*HH*2);
FSurface.UnLock;
end
else
Beep;
Caption:=Format('Current FPS: %d',[dxtimer1.FrameRate]);
end;

procedure ProcImage(SrcImgBuf

ointer;Count:integer);
begin

Move(srcImgBuf^,ImgBuf^,Count);
unit2.showImg(ImgBuf,Count);
end;

end.

//////////////////////////////////// unit2.dfm //////////////////////////////////////////////
object Form2: TForm2
Left = 692
Top = 305
BorderStyle = bsSingle
Caption = 'Show Bitmap'
ClientHeight = 406
ClientWidth = 321
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
FormStyle = fsStayOnTop
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 0
Top = 0
Width = 320
Height = 200
end
object Image2: TImage
Left = 0
Top = 204
Width = 320
Height = 200
end
end

////////////////////////////////////// unit2.pas ///////////////////////////////////////////
unit Unit2;

interface

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

type
TForm2 = class(TForm)
Image1: TImage;
Image2: TImage;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

const
KeyFrameStep=80
//关键帧大小
var
Form2 : TForm2;
Pbuffer,
KeybmpP

RGB16;
DstP,
kfP

ointer;
TmpBmp,
KeyFrameBmp :Tbitmap;
KeyFrameCount:Integer=KeyFrameStep;
CompressedBuf,
DecodedBuf

RGB16;
compressedSize:Integer;
procedure showImg(const Pbuf

RGB16;Count:Integer);
procedure DrawCursor(Tbmp:TBitmap;offsetX:Integer=0;
offsetY:Integer=0;MPos:Boolean=True);
implementation

{$R *.DFM}
procedure showImg(const Pbuf

RGB16;Count:Integer);
var
x,y:Integer;
KbmpP,tmpP,tmpDstP

RGB16;
a,b:word;
clipx,clipy:Integer;
mpos:TPoint;
begin

tmpP:=Pbuf;
tmpDstP:=Pbuffer;
KbmpP:=KeybmpP;
clipx:=Form2.Image1.Width;
clipy:=Form2.Image1.Height;
getCursorPos(Mpos);
Form2.Caption:=IntToStr(KeyFrameCount);
if KeyFrameCount< KeyFrameStep then

//不是关键帧时的处理
begin

for y:=0 to HH-1do

begin

Application.ProcessMessages;
// 此处我逐象素的处理了, 目的是看看出来的图象对不对
//其实可以使用XOR方法,速度就会快多了.
for x:=0 to WW-1do

begin

a:=tmpP[x];
b:=kbmpp[x];
if a=$0 then
a:=$821;
if a=b then
a:=$0000;
tmpDstP[x]:=(a);
end;

dec(integer(KbmpP),WW*2);
dec(integer(tmpDstP),WW*2);
inc(Integer(tmpP),WW*2);
end;

DrawCursor(TmpBmp);
//监视窗显示的是裁减过的图象, 显示内容随鼠标移动
//image1 为动态的图象 ,image2 为关键帧显示
with Form2do

begin

Image2.Canvas.Brush.Color:=clNavy;
Image2.Canvas.FillRect(Rect(0,0,clipx,clipy));
Image2.Canvas.Draw(clipx div 2-mpos.x,clipy div 2-mpos.y,KeyFrameBmp);
Image1.Canvas.Brush.Color:=clNavy;
Image1.Canvas.FillRect(Rect(0,0,clipx,clipy));
Image1.Canvas.Draw(clipx div 2-mpos.x,clipy div 2-mpos.y,tmpBmp);
DrawCursor(Image2.Picture.Bitmap,clipx div 2,clipy div 2,False);
end;

Inc(KeyFrameCount);
end
else
begin

//处理关键帧
for y:=0 to HH-1do

begin

Move(tmpP^, tmpDstP^,WW*2);
dec(integer(tmpDstP),WW*2);
inc(Integer(tmpP),WW*2);
end;

Move(dstP^,KfP^,WW*HH*2);
with Form2do

begin

Image2.Canvas.Draw(clipx div 2-mpos.x,clipy div 2-mpos.y,KeyFrameBmp);
Image1.Canvas.Draw(clipx div 2-mpos.x,clipy div 2-mpos.y,tmpBmp);
DrawCursor(TmpBmp);
DrawCursor(Image2.Picture.Bitmap,clipx,clipy,False);
end;

KeyFrameCount:=0;
end;

compressedSize:=EncodeRLE(DstP,CompressedBuf,WW*HH,2);
Form1.label1.Caption:=Format('Compressed Size:%d rate:%f%%, %dKb/s',
[compressedSize, compressedSize*100 / (WW*HH*2),
compressedSize div 1024 * form1.dxtimer1.FrameRate]);
DecodeRLE(CompressedBuf,DecodedBuf,WW*HH*2,16);
end;

procedure TForm2.FormCreate(Sender: TObject);
begin

form2.show;
TmpBmp:=Tbitmap.Create;
Tmpbmp.HandleType:=bmDIB;
tmpBmp.Width:=WW;
TmpBmp.Height:=HH;
TmpBmp.PixelFormat:=pf16bit;
Pbuffer:=TmpBmp.ScanLine[0];
DstP:=TmpBmp.ScanLine[HH-1];

KeyFrameBmp:=TBitmap.Create;
with KeyFrameBmpdo

begin

HandleType:=bmDIB
Width := WW
Height := HH
PixelFormat := pf16bit
KeybmpP:=ScanLine[0];
kfP:=ScanLine[HH-1];
end;

CompressedBuf:=GlobalAllocPtr(GPTR,WW*HH*2);
DecodedBuf:=GlobalAllocPtr(GPTR,WW*HH*2);
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin

TmpBmp.Free;
KeyFrameBmp.Free;
GlobalFreePtr(CompressedBuf);
GlobalFreePtr(DecodedBuf);
end;

//获取屏幕鼠标形状
procedure DrawCursor(Tbmp:TBitmap;offsetX:Integer=0;
offsetY:Integer=0;MPos:Boolean=True);
var
GlobalCur :TIcon;
windowhld :hwnd;
threadld :dword;
Pos :TPoint;
PIconInfo :TIconInfo;
begin

GetCursorPos(Pos);
windowhld:=WindowFromPoint(Pos);
//windowhld:=GetForegroundWindow;
threadld:=GetWindowThreadProcessId(Windowhld,nil);
AttachThreadInput(GetCurrentThreadId,threadld,true);
GlobalCur:=TIcon.Create;
GlobalCur.handle:=GetCursor;
AttachThreadInput(GetCurrentThreadId,threadld,false);
GetIconInfo(GlobalCur.Handle,PiconInfo);
Tbmp.canvas.brush.Style:=bsclear;
if Mpos=True then

Tbmp.canvas.draw(Pos.x-PIconInfo.xHotspot+offsetX,
Pos.y-PIconInfo.yHotspot+offsetY,GlobalCur)
else

Tbmp.canvas.Draw(offsetX-PIconInfo.xHotspot,
offsetY-PIconInfo.yHotspot,GlobalCur);

GlobalCur.Free;
end;

end.

/////////////////////////////////////////////////////////////////////////////////

ps: 把上面的源代码分别贴进记事本中, 存储的文件名分别为 *.pas *.dfm *.prj 放在同一个目录中
然后就可以用d5 打开运行拉.

要确保你的d5 上安装了delphix , 另外这个程序只能运行在 16bit 色彩模式下.

xwings · 2001-11-06

“同志们：请把问题提前，谢谢！！！”

LeeChange · 2001-11-07

xwings的方法不是通用的。
我用它抓播放中的MPEG1图象和采集卡得到的Overlay方式显示的图象，都是黑的。

xwings · 2001-11-07

呵呵, 我又没有说可以抓活动图象啊. 不过有时候可以抓到几秒钟的图象的. 原因我也不知道.
而且overlay 层不是标准的 surface. 我没有去枚举,当然抓不到了. ) 其实用directx 抓屏的
好处就是CPU占用小一点而已.

黄海波 · 2001-11-07

你可以先保存在内存中，等应用程序空闲（多线程）时再写入硬盘[

]

xwings · 2001-11-08

没有空闲的时候. 200K/s 要多少缓冲才够呢?

xxhsh · 2001-11-13

xwings 的程序怎么无法运行呢？
RLEUnit是什么单元？？？？？？？

xwings · 2001-11-13

Sorry )

RLEUnit.pas
/////////////////////////////////////////////////////////////////////////////////
unit RLEUnit;

interface
uses
windows,sysutils,graphics,math;

function EncodeRLE(const Source, Target: Pointer;
Count, BPP: Integer): Integer;
//BBP : Byte Per Point;
16bit: 2
24bit: 3
function DecodeRLE(const Source, Target: Pointer;
Count, ColorDepth: Cardinal): Integer;
function CountDiffPixels(P: PByte;
BPP: Byte;
Count: Integer): Integer;
function CountSamePixels(P: PByte;
BPP: Byte;
Count: Integer): Integer;
function GetPixel(P: PByte;
BPP: Byte): Cardinal;

implementation
//******************************************************************************
function EncodeRLE(const Source, Target: Pointer;
Count, BPP: Integer): Integer;
var
DiffCount, // pixel count until two identical
SameCount: Integer;
// number of identical adjacent pixels
SourcePtr,
TargetPtr: PByte;
begin

Result := 0;
SourcePtr := Source;
TargetPtr := Target;
while Count > 0do

begin

DiffCount := CountDiffPixels(SourcePtr, BPP, Count);
SameCount := CountSamePixels(SourcePtr, BPP, Count);
if DiffCount > 128 then
DiffCount := 128;
if SameCount > 128 then
SameCount := 128;

if DiffCount > 0 then

begin

// create a raw packet
TargetPtr^ := DiffCount - 1;
Inc(TargetPtr);
Dec(Count, DiffCount);
Inc(Result, (DiffCount * BPP) + 1);
while DiffCount > 0do

begin

TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
if BPP > 1 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

if BPP > 2 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

if BPP > 3 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

Dec(DiffCount);
end;

end;

if SameCount > 1 then

begin

// create a RLE packet
TargetPtr^ := (SameCount - 1) or $80;
Inc(TargetPtr);
Dec(Count, SameCount);
Inc(Result, BPP + 1);
Inc(SourcePtr, (SameCount - 1) * BPP);
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
if BPP > 1 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

if BPP > 2 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

if BPP > 3 then
begin
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
end;

end;

end;

end;

//******************************************************************************
function DecodeRLE(const Source, Target: Pointer;
Count, ColorDepth: Cardinal): Integer;
type
PCardinalArray = ^TCardinalArray;
TCardinalArray = array[0..MaxInt div 4 - 1] of Cardinal;
var
I: Integer;
SourcePtr,
TargetPtr: PByte;
RunLength: Cardinal;
Counter: Cardinal;
SourceCardinal: Cardinal;
begin

Result := 0;
Counter := 0;
TargetPtr := Target;
SourcePtr := Source;
// unrolled decoder loop to speed up process
case ColorDepth of
8:
while Counter < Countdo

begin

RunLength := 1 + (SourcePtr^ and $7F);
if SourcePtr^ > $7F then

begin

Inc(SourcePtr);
FillChar(TargetPtr^, RunLength, SourcePtr^);
Inc(TargetPtr, RunLength);
Inc(SourcePtr);
Inc(Result, 2);
end
else

begin

Inc(SourcePtr);
Move(SourcePtr^, TargetPtr^, RunLength);
Inc(SourcePtr, RunLength);
Inc(TargetPtr, RunLength);
Inc(Result, RunLength + 1)
end;

Inc(Counter, RunLength);
end;

15,
16:
while Counter < Countdo

begin

RunLength := 1 + (SourcePtr^ and $7F);
if SourcePtr^ > $7F then

begin

Inc(SourcePtr);
for I := 0 to RunLength - 1do

begin

TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
TargetPtr^ := SourcePtr^;
Dec(SourcePtr);
Inc(TargetPtr);
end;

Inc(SourcePtr, 2);
Inc(Result, 3);
end
else

begin

Inc(SourcePtr);
Move(SourcePtr^, TargetPtr^, 2 * RunLength);
Inc(SourcePtr, 2 * RunLength);
Inc(TargetPtr, 2 * RunLength);
Inc(Result, RunLength * 2 + 1);
end;

Inc(Counter, 2 * RunLength);
end;

24:
while Counter < Countdo

begin

RunLength := 1 + (SourcePtr^ and $7F);
if SourcePtr^ > $7F then

begin

Inc(SourcePtr);
for I := 0 to RunLength - 1do

begin

TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
TargetPtr^ := SourcePtr^;
Inc(SourcePtr);
Inc(TargetPtr);
TargetPtr^ := SourcePtr^;
Dec(SourcePtr, 2);
Inc(TargetPtr);
end;

Inc(SourcePtr, 3);
Inc(Result, 4);
end
else

begin

Inc(SourcePtr);
Move(SourcePtr^, TargetPtr^, 3 * RunLength);
Inc(SourcePtr, 3 * RunLength);
Inc(TargetPtr, 3 * RunLength);
Inc(Result, RunLength * 3 + 1);
end;

Inc(Counter, 3 * RunLength);
end;

32:
while Counter < Countdo

begin

RunLength := 1 + (SourcePtr^ and $7F);
if SourcePtr^ > $7F then

begin

Inc(SourcePtr);
SourceCardinal := PCardinalArray(SourcePtr)[0];
for I := 0 to RunLength - 1do

PCardinalArray(TargetPtr) := SourceCardinal;

Inc(TargetPtr, 4 * RunLength);
Inc(SourcePtr, 4);
Inc(Result, 5);
end
else

begin

Inc(SourcePtr);
Move(SourcePtr^, TargetPtr^, 4 * RunLength);
Inc(SourcePtr, 4 * RunLength);
Inc(TargetPtr, 4 * RunLength);
Inc(Result,RunLength * 4 + 1);
end;

Inc(Counter, 4 * RunLength);
end;

end;

end;

//------------------------------------------------------------------------------
function CountDiffPixels(P: PByte;
BPP: Byte;
Count: Integer): Integer;
// counts pixels in buffer until two identical adjacent ones found
var
N: Integer;
Pixel,
NextPixel: Cardinal;
begin

N := 0;
NextPixel := 0;
// shut up compiler
if Count = 1 then
Result := Count
else

begin

Pixel := GetPixel(P, BPP);
while Count > 1do

begin

Inc(P, BPP);
NextPixel := GetPixel(P, BPP);
if NextPixel = Pixel then
Break;
Pixel := NextPixel;
Inc(N);
//===================================================================================================
IF N=128 then
Break;
// 既然行程最大只有 128 何必继续向下搜索
// 在大片无像素重复时会造成大量的多余循环
//====================================================================================================
Dec(Count);
end;

if NextPixel = Pixel then
Result := N
else
Result := N + 1;
end;

end;

//------------------------------------------------------------------------------
function CountSamePixels(P: PByte;
BPP: Byte;
Count: Integer): Integer;
var
Pixel,
NextPixel: Cardinal;
begin

Result := 1;
Pixel := GetPixel(P, BPP);
Dec(Count);
while Count > 0do

begin

Inc(P, BPP);
NextPixel := GetPixel(P, BPP);
if NextPixel <> Pixel then
Break;
Inc(Result);

//===================================================================================================
IF Result=128 then
Break;
// 既然行程最大只有 128 何必继续向下搜索
// 在大片的像素重复时会造成大量的多余循环
//====================================================================================================

Dec(Count);
end;

end;

//------------------------------------------------------------------------------
function GetPixel(P: PByte;
BPP: Byte): Cardinal;
// Retrieves a pixel value from a buffer. The actual size and order of the bytes is not important
// since we are only using the value for comparisons with other pixels.
begin

Result := P^;
Inc(P);
Dec(BPP);
while BPP > 0do

begin

Result := Result shl 8;
Result := Result or P^;
Inc(P);
Dec(BPP);
end;

end;

end.

xxhsh · 2001-11-13

多谢xwings，正在研究你的程序，可能也看不懂：（　！
我也在学ｄｅｌｐｈｉ的一些图像处理，但是水平很菜，多多指教！
ｑｑ　２３３２９５５

尘莽 · 2001-11-13

7副图象完全够时间的,难道大家不知道 Windows 实际是在往内存写吗?

至于存盘那是感觉不到实际延迟的.

xwings · 2001-11-14

to: 尘莽
你有自己试过么? 你以为像copy文件那么容易啊. 瓶颈是抓屏.而不是写文件或者网络传输.

150分求“每秒抓超过7次的整屏图像到文件中(仅800*600*16M色就可以了)”(50分)

dark_eagle

Unregistered / Unconfirmed

硬木花椒

Unregistered / Unconfirmed

wql

Unregistered / Unconfirmed

wql

Unregistered / Unconfirmed

wanxu

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

caowei

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

LeeChange

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

黄海波

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

xxhsh

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

xxhsh

Unregistered / Unconfirmed

尘莽

Unregistered / Unconfirmed

xwings

Unregistered / Unconfirmed

Similar threads

150分求“每秒抓超过7次的整屏图像到文件中(仅80060016M色就可以了)”(50分)