delphi 快速远程屏幕传输API版-木庄网络博客

本文整理自网络，侵删。
 本着共享精神，我公布一下可用于远程屏幕获取及发送的代码(包括BMP图像获取及发送)
unit UntBMPLite;
interface

uses
Windows,CompressionStreamUnit;

type
TLines = array[Word] of Pointer;
PLines = ^TLines;
TLine8 = array[Word] of Byte;
PLine8 = ^TLine8;
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = array [Byte] of TRGBQuad;

TBMPLite = class
private
m_lpLineBits:PLine8;
//function getScanLine(i: Integer): Pointer; // 指向一行的 DIBits 数据
public
m_bmi: PBitmapInfo; // 指向一个 BitmapInfo ,后面有调色板数据
m_hDc,n_hdc:HDC;
m_hBmp:HBITMAP;
m_Width:Integer;
m_Height:Integer;
m_LineSize:Integer; // 每一行的字节数
m_DataSize:Integer; // Bits 数据大小
m_hPal:HPALETTE; // 调色板
m_BmpInfoLen :Integer; // 信息头+调色板长度
Scanlines: PLines;
UseGDI: Boolean; // default true, allocate GDI handle & surface
FreeDC: Boolean; // default true, free GDI surface on destroy
FreeBits: Boolean; // default true, free Bits on destroy (non GDI only)
FreeHandle: Boolean; // default true, free GDI handle on destroy
AbsHeight,BWidth: Integer;
Bpp :Byte;
constructor Create;
destructor Destroy;override;
procedure SetSize(fWidth, fHeight: Integer;biBitCount :byte;hDeskDc:hdc);
procedure SetSizeEX(fWidth, fHeight: Integer);
function getScanLine(i:Integer):Pointer ;
function RGB2GRAY(r,g,b:byte):integer;
procedure BitsTostream(AStream : TStream);
procedure InfoTostream(AStream : TStream);
//property Size: DWord read m_bmi^.SizeImage write Info.Header.SizeImage;
end;
function CreateDIB(fDC: hDC; bmInfo: PBitmapInfo; iColor: DWord; var Bits: PLine8; hSection, dwOffset: DWord): HBITMAP;
stdcall;

implementation
function CreateDIB; external 'gdi32.dll' Name 'CreateDIBSection';
{ {TBMPLite }

constructor TBMPLite.Create;
begin
inherited Create;
UseGDI := True;
m_lpLineBits := nil;
Scanlines := nil;
end;

destructor TBMPLite.Destroy;
begin
FreeMem(m_bmi,m_BmpInfoLen);
if m_lpLineBits <> nil then
SysFreeMem(m_lpLineBits);
DeleteObject(m_hBmp);
DeleteDC(m_hDc);
inherited;
end;

procedure TBMPLite.SetSize(fWidth, fHeight: Integer;biBitCount :byte;hDeskDc:hdc);
var
x,i,color_num,color:integer;
pe:array of TPaletteEntry;
begin
if (m_bmi <> nil) then // m_bmi :=nil;
FreeMem(m_bmi,m_BmpInfoLen);
Bpp := biBitCount;
if biBitCount <= 8 then
color_num := 1 shl biBitCount
else
color_num :=0;
m_BmpInfoLen := SizeOf(TBitmapInfoHeader) + color_num * SizeOf(TRGBQuad);
GetMem(m_bmi,m_BmpInfoLen);
m_Width := fWidth;
m_Height := fHeight;
AbsHeight := Abs(fHeight);
{ case Bpp of
1:
begin
X := (fWidth + 7) and -8;
BWidth := ((X + 31) and -32) shr 3;
end;
4:
begin
X := ((fWidth shl 2) + 7) and -8;
BWidth := ((X + 31) and -32) shr 3;
end;
8:
begin
BWidth := (((fWidth shl 3) + 31) and -32) shr 3;
end;
16:
begin
BWidth := (((fWidth shl 4) + 31) and -32) shr 3;
end;
24:
begin
BWidth := (((fWidth * 24) + 31) and -32) shr 3;
end;
32:
begin
BWidth := (((fWidth shl 5) + 31) and -32) shr 3;
end;
end; }
BWidth := (((fWidth * Bpp) +31) and not 31) shr 3; //div 8
m_DataSize := BWidth * abs(fHeight);

m_bmi^.bmiHeader.biSize := SizeOf(TBitmapInfoHeader); // 由于 Delphi 的问题，最后一个0长度的数组被加了进去
m_bmi^.bmiHeader.biWidth := fWidth;
m_bmi^.bmiHeader.biHeight := fHeight;
m_bmi^.bmiHeader.biPlanes := 1; // 必须等于 1
m_bmi^.bmiHeader.biBitCount := biBitCount; // BitsPerPixel = 8;
m_bmi^.bmiHeader.biCompression := BI_RGB; // 压缩方式，不压缩
m_bmi^.bmiHeader.biSizeImage := m_DataSize; // 位图数据大小， biWidth 必须 4 字节对齐
m_bmi^.bmiHeader.biXPelsPerMeter := 0;
m_bmi^.bmiHeader.biYPelsPerMeter := 0;
m_bmi^.bmiHeader.biClrUsed := color_num; // 0 2^8
m_bmi^.bmiHeader.biClrImportant := color_num;

if (m_hDc <> 0) then DeleteDC(m_hDc);
if (m_hBmp <> 0) then DeleteObject(m_hBmp);
//hDeskDc := GetDC(0);
n_hdc := hDeskDc;
m_hDc := CreateCompatibleDC(n_hdc);
{ 调色板 }
if color_num <> 2 then
begin
//getmem(pe,color_num*sizeof(TPaletteEntry));
//FillChar(pe, color_num*sizeof(TPaletteEntry), 0);
setlength(pe,color_num);
m_hPal := CreateHalftonePalette(0);
GetPaletteEntries(m_hPal,0,color_num,pe[0]);
//GetPaletteEntries(m_hPal,0,color_num,Pointer(@m_bmi.bmiColors[0])^);
// SelectPalette(m_hDc,m_hPal,False);
// RealizePalette(m_hDc);
//SetDIBColorTable(m_hDc,0,color_num,PRGBQuadArray(@m_bmi.bmiColors[0])^);
DeleteDC(m_hPal);
for i:=0 to color_num-1 do
begin
if Bpp <= 8 then
begin
color := RGB2GRAY(pe[i].peRed, pe[i].peGreen, pe[i].peBlue);
m_bmi^.bmiColors[i].rgbRed := color ;
m_bmi^.bmiColors[i].rgbGreen := color ;
m_bmi^.bmiColors[i].rgbBlue := color;
m_bmi^.bmiColors[i].rgbReserved := pe[i].peFlags;
end else
begin
m_bmi^.bmiColors[i].rgbRed := pe[i].peRed ;
m_bmi^.bmiColors[i].rgbGreen:= pe[i].peGreen ;
m_bmi^.bmiColors[i].rgbBlue := pe[i].peBlue ;
m_bmi^.bmiColors[i].rgbReserved := pe[i].peFlags;
end;
end;
//freemem(pe,color_num*sizeof(TPaletteEntry));
end
else
begin
m_bmi^.bmiColors[0].rgbRed := 255;
m_bmi^.bmiColors[0].rgbGreen:= 255;
m_bmi^.bmiColors[0].rgbBlue := 255;
m_bmi^.bmiColors[0].rgbReserved := 0;
i:=1;
m_bmi^.bmiColors[i].rgbRed := 0;
m_bmi^.bmiColors[i].rgbGreen:= 0;
m_bmi^.bmiColors[i].rgbBlue := 0;
m_bmi^.bmiColors[i].rgbReserved := 0;
end;

if (m_lpLineBits <> nil) and FreeBits then
ReAllocMem(m_lpLineBits, 0);
m_hBmp := CreateDIBSection(n_hdc,m_bmi^,DIB_RGB_COLORS, pointer(m_lpLineBits), 0,0);
SelectObject(m_hDc,m_hBmp);
FreeBits := False;


//ReleaseDC(0,hDeskDc);
//m_lpLineBits := SysGetMem(m_LineSize);
if (AbsHeight > 0) and (fWidth >1) then
begin
//if Scanlines <> nil then Scanlines := nil;
ReAllocMem(Scanlines, AbsHeight shl 2);
X := Integer(m_lpLineBits);
for I := 0 to AbsHeight - 1 do
begin
Scanlines[I] := Ptr(X);
inc(X, BWidth);
end;
end;
end;

procedure TBMPLite.SetSizeEX(fWidth, fHeight: Integer);
var
X,i :Integer;
begin
if (fWidth = m_Width) and (fHeight = m_Height) then exit;
BWidth := (((fWidth * Bpp) +31) and not 31) shr 3; //div 8
AbsHeight := Abs(fHeight);
m_DataSize := AbsHeight * BWidth;
m_bmi^.bmiHeader.biSizeImage := m_DataSize;
m_bmi^.bmiHeader.biWidth := fWidth;
m_bmi^.bmiHeader.biHeight := fHeight;
DeleteObject(m_hBmp);
m_hBmp := CreateDIBSection(n_hdc,m_bmi^,DIB_RGB_COLORS, pointer(m_lpLineBits), 0,0);
SelectObject(m_hDc,m_hBmp);
end;


function TBMPLite.getScanLine(i: Integer): Pointer;
begin
Result := nil;
if GetDIBits(m_hDc, m_hBmp, m_Height- i-1,1,m_lpLineBits,m_bmi^,DIB_RGB_COLORS) <> 0 then
Result := m_lpLineBits;
end;

procedure TBMPLite.InfoTostream(AStream: TStream);
var
cSize, I: DWord;
begin
//AStream.Size := 0;
AStream.WriteBuffer(m_BmpInfoLen, 4);
AStream.WriteBuffer(m_bmi^, m_BmpInfoLen);
end;

procedure TBMPLite.BitsTostream(AStream: TStream);
begin
AStream.WriteBuffer(m_DataSize,4);
AStream.WriteBuffer(m_lpLineBits^,m_DataSize);
end;

function TBMPLite.RGB2GRAY(r, g, b: byte): integer;
begin
result:=(b*117 + g*601 + r*306) shr 10 ;
end;

end.

===============================================================


//获得第一副图并发送
function TScreenMonitor.GetFirst: Boolean;
begin
Result := False;
BitBlt(FFullBmp.m_hDc, 0, 0, m_nFullWidth, m_nFullHeight, m_hFullDC, 0, 0, SRCCOPY);
SetRect(FRect, 0, 0, m_nFullWidth, m_nFullHeight);//赋值FRect;
FScrStream.Clear;
FScrStream.WriteBuffer(FRect, SizeOf(TRect));
//FFullBmp.SaveToFile('1.bmp');
FFullBmp.BitsTostream(FScrStream);
if SendInfo then
Result :=CompressAndSend(FScrStream);
First :=not Result;
end;
function TScreenMonitor.CompressAndSend(AStream: TMemoryStream): Boolean;
begin
try
FSendStream.Clear;
AStream.Position :=0;
ZCompressStream(AStream, FSendStream);
FSendStream.Position := 0;

FCmd.Cmd := 2;
FCmd.Size := FSendStream.Size;//流长度
while ((Fserv.Connected) and (Fserv.SendBuffer(FCmd, SizeOf(TCapCmd)) = -1)) do Sleep(1);
if Fserv.Connected then
begin
Fserv.SendStream(FSendStream);
end;
except

end;
end;


function TScreenMonitor.SendInfo: Boolean;
var
FInfoStream: TMemoryStream;
begin
result := false;
FInfoStream := TMemoryStream.Create;
try
FFullBmp.InfoTostream(FInfoStream);
FCmd.Cmd := 1; //发送第一副图
FCmd.Size := FInfoStream.Size;
FCmd.Width := m_nFullWidth; //传屏幕长宽
FCmd.Height := m_nFullHeight;
FInfoStream.Position :=0;
Fserv.SendBuffer(FCmd, SizeOf(TCapCmd));
Fserv.SendStream(FInfoStream);
result := true;
finally
FInfoStream.Free;
end;
end;

//这是比较行扫描后的图像

p1 := PDWORD(FFullBmp.Scanlines[m_nFullHeight-1-i]);//刚开始困惑于这里，写成

//FLineBmp.Scanlines[i]);后来仔细通读了FastDIB代码才得以解惑
p2 := PDWORD(FLineBmp.Scanlines[0]);
delphi 快速远程屏幕传输API版

相关推荐

评论
