O soy tonto o .... problema al liberar memoria

[cesarsoftware]

Hola compis, a ver si me podeis ayudar.
El caso es que tengo una procedure que captura la pantalla (la funcion "printscreen" que uso ultimamente esta sacada de este foro buscando la solucion a mi problema)
y la envia por tcp a un servidor, todo funciona correctamente exepto en un "pequeño" problema, no libera la ram, y mira que se lo digo, pero nada.
Toda la culpa de no liberar la memoria esta en esta funcion "LBitmap.Canvas.CopyRect(r, c, r);" Si no la pongo manda la imagen en blanco, vale, pero la manda y no gasta ni un bit de ram, pero como se la ponga me "come" megas y megas en poco segundos.
Ojo me pasa lo mismo si uso la funcion "vieja" "BitBlt(LBitmap.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, GetWindowDC(GetDesktopWindow), 0, 0, SRCCOPY);"

He aqui el codigo por si quereis probar. Gracias por anticipado.

procedure TscrServer.SendScreen(AContext: TIdContext; cliente: word);
var
msg: string;
LBuffer: TBytes;
LBitmap: TBitmap;
LBytesStream: TBytesStream;
LPngImage: TPngImage;
c: TCanvas;
r: TRect;
begin
// crear objetos
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
LBitmap := TBitmap.Create;
LPngImage := TPngImage.Create;
LBytesStream := TBytesStream.Create;
try
// copiar la pantalla en la imagen bitmap
r := Rect(0, 0, ScreenWidth, ScreenHeight);
LBitmap.Height := ScreenHeight;
LBitmap.Width := ScreenWidth;
LBitmap.Canvas.CopyRect(r, c, r);
// convertir bitmap en PNG
LPngImage.CompressionLevel := calidadCompresion;
LPngImage.Assign(LBitmap);
// pasa el PNG a Stream
LPngImage.SaveToStream(LBytesStream);
SetLength(LBuffer, LBytesStream.Size + 1);
Move(LBytesStream.Bytes[0], LBuffer[0], LBytesStream.Size);
// enviar pantalla al cliente
msg := '[SCR-' + IntToStr(LBytesStream.Size) + ']';
IdTCPServerSCRresponse(msg, AContext);
ActualizaEstado('>SCR-SERVIDOR-' + AContext.Connection.Socket.Binding.PeerIP +
':' + IntToStr(AContext.Connection.Socket.Binding.PeerPort) +
' ' + msg);
clientes[cliente].IOHandler.Write(LBuffer);
finally
// liberar memoria
ReleaseDC(0, c.Handle);
FreeAndNil(r);
FreeAndNil(LBitmap);
FreeAndNil(LPngImage);
FreeAndNil(LBytesStream);
SetLength(LBuffer, 0);
end;
EsperaSegundos(0.001);
end;

[escafandra]

Recuerda poner las etiquetas de código para poderlo leer cómodamente.

Respecto a tu problema, no estas liberando los objetos creados, sólo parte de ellos. Prueba de esta manera:


// liberar memoria
c.Free;
// No procede FreeAndNil(r);
LBitmap.Free;
LPngImage.Free;
LBytesStream.Free;
SetLength(LBuffer, 0);



Saludos.

[cesarsoftware]

Gracias por tu respuesta "escafandra"

Pero sigo igual

he probado a usar

if Win32Platform = VER_PLATFORM_WIN32_NT then
SetProcessWorkingSetSize(GetCurrentProcess, $FFFFFFFF, $FFFFFFFF);


y nada, lo que parece que la memoria se llena la del sistema operativo no de la aplicación.
Quizas, si pudiera leer la pantalla de otra forma, por ejemplo leyendo los pixeles del canvas de la pantalla y pasandolos al bitmap no consuma ram, pero he probado

for x := 1 to ScreenWidth do
for y := 1 to ScreenHeight do
LBitmap.Canvas.Pixels[x, y] := clLime;//c.Pixels[x, y];
// LBitmap.Canvas.CopyRect(r, c, r);

y me sigue gastado toda la ram

Con esto llego a la conclusion de que no se libera la ram por parte del sistema operativo y es siempre que lleno el bitmap, osea se libera el bitmap pero el "buufer" intermedio no.
¿Como podria pasar la imagen directamente al stream?

Gracias.

[cesarsoftware]

Hola de nuevo.

Lo que he podido comprobar, es que donde "se queda" la memoria es en "errores de pagina" de la aplicación.
Esta es la vista inicial de la aplicacion "cpcomcontrol.exe"
http://fotos.miarroba.es/fo/8cf5/224F5F4DE0284F2671A1274F2670E3.jpg


y esta tras un medio minuto de ejecucion (manda la pantalla cada 500 ms mas o menos) ha gastado 130 mb de ram. Cuando salgo de la aplicacion se libera toda la ram.
http://fotos.miarroba.es/fo/c7b8/284F5F5107264F2674C9244F26740A.jpg

¿Como puedo liberar los "errores de pagina"?

Gracias y perdonar por insistir pero si lo solucionamos pongo todo el codigo para que quien quiera pueda hacerse un pequeño (o grande) vnc o escritorio remoto.

[escafandra]

prueba a liberar así:

ReleaseDC(0, c.Handle);
c.Handle:= 0;
c.Free;
LBitmap.Free;
LPngImage.Free;
LBytesStream.Free;
SetLength(LBuffer, 0);


¿El Componente TPngImage es de terceros?, ¿no será esa la causa?. Prueba a mandar la imagen sin comprimir o en Jpg.

También puedes tener fugas en otro punto que no sea ese procedimiento.

Valora resolver esa tarea con la API de GDI plus.


Saludos.

[cesarsoftware]

Gracias escafandra por seguir el tema.

voy a probar como dices, pero me da que no.

El componente TPngImage es de delphi igual que el jpeg o bitmap, el problema como explicaba antes no es del formato de la imagen ni de mandarlo, es cuando lleno bitmap. Ya he probado en jpeg, sin comprimir, llenarlo y no mandarlo, etc.


interface
uses
Classes, Windows, SysUtils, Graphics, PngImage,
Funciones, UnitGlobal,
IdContext, IdBaseComponent, IdComponent, IdCustomTCPServer, IdThread, IdSync,
IdTCPServer, IdTCPClient;


¿Por que se queda en errores de pagina?
¿Se te ocurre como mandar el LBitmap.Canvas.CopyRect(r, c, r); directamente al stream sin pasar por el bitmap o png?
La verdad es que como mejor funciona es con png, si uso jpeg se "frie" (sin recursos) en un momento, no va bien en jpeg.

y por ultimo ¿que es el GDI plus?

[escafandra]

El componente TPngImage es de delphi igual que el jpeg o bitmap...
Mi delphi 7 no tiene ese componente pero si he visto publicado código para él.


¿Por que se queda en errores de pagina?

Sin probar no te puedo decir, es posible que exista un bug en algún sitio...


¿Se te ocurre como mandar el LBitmap.Canvas.CopyRect(r, c, r); directamente al stream sin pasar por el bitmap o png?


Si, usando directamente la API GDI plus de ese modo no dependes de componentes y es mas eficiente.


¿que es el GDI plus?

Es una extensión de GDI: GDI+ (http://msdn.microsoft.com/en-us/library/ms533798%28v=vs.85%29.aspx)


Saludos.

[delphi.com.ar]

Agregando a lo que dijeron anteriormente, hay un tema un poco oscuro en esta forma de tratar el manejo de errores al crear objetos:


...
Obj1 := TClase.Create;
Obj2 := TClase.Create;
Obj3 := TClase.Create;
Try
{...}
finally
Obj1.Free;
Obj2.Free;
Obj3.Free;
end;


Es algo muy fuera de lo común, pero imaginemos que estos constructores producen errores: si el constructor del primer objeto falla, este no se ha creado, suponemos que la clase gestiona bien la memoria y no es necesario liberarlo pues no se ha creado, pero si falla el segundo o el tercero, los objetos anteriores han sido creados y nunca se ejecutará el código donde liberamos la memoria de los mismos. Por eso tengo la costumbre, de que cada constructor tiene asociado un bloque de control de errores para poder liberar el espacio utilizado, ejemplo:


...
Obj1 := TClase.Create;
Try
{...}
Obj2 := TClase.Create;
Try
{...}
Obj3 := TClase.Create;
Try

{...}

finally
Obj3.Free;
end;
finally
Obj2.Free;
end;
finally
Obj1.Free;
end;


Saludos!

[cesarsoftware]

SOLUCIONADO.

A ver, por partes.

La solucion, aunque me humille a mi mismo, es que digamoslo asi, no sabia usar el objeto tbitmap.
Buscando en la unidad graphics, me encuentro el siguiente codigo.


procedure TCanvas.CopyRect(const Dest: TRect; Canvas: TCanvas;
const Source: TRect);
begin
Changing;
RequiredState([csHandleValid, csFontValid, csBrushValid]);
Canvas.RequiredState([csHandleValid, csBrushValid]);
StretchBlt(FHandle, Dest.Left, Dest.Top, Dest.Right - Dest.Left,
Dest.Bottom - Dest.Top, Canvas.FHandle, Source.Left, Source.Top,
Source.Right - Source.Left, Source.Bottom - Source.Top, CopyMode);
Changed;
end;


Ya habia probrado BitBlt (hermana de stretchblt) y viendo el fuente de brushcopy

procedure TCanvas.BrushCopy(const Dest: TRect; Bitmap: TBitmap;
const Source: TRect; Color: TColor);
const
ROP_DSPDxax = $00E20746;
var
SrcW, SrcH, DstW, DstH: Integer;
crBack, crText: TColorRef;
MaskDC: HDC;
Mask: TBitmap;
MaskHandle: HBITMAP;
begin
if Bitmap = nil then Exit;
Lock;
try
Changing;
RequiredState([csHandleValid, csBrushValid]);
Bitmap.Canvas.Lock;
try
DstW := Dest.Right - Dest.Left;
DstH := Dest.Bottom - Dest.Top;
SrcW := Source.Right - Source.Left;
SrcH := Source.Bottom - Source.Top;

if Bitmap.TransparentColor = Color then
begin
Mask := nil;
MaskHandle := Bitmap.MaskHandle;
MaskDC := CreateCompatibleDC(0);
MaskHandle := SelectObject(MaskDC, MaskHandle);
end
else
begin
Mask := TBitmap.Create;
Mask.Assign(Bitmap);
{ Replace Color with black and all other colors with white }
Mask.Mask(Color);
Mask.Canvas.RequiredState([csHandleValid]);
MaskDC := Mask.Canvas.FHandle;
MaskHandle := 0;
end;

try
Bitmap.Canvas.RequiredState([csHandleValid]);
{ Draw transparently or use brush color to fill background }
if Brush.Style = bsClear then
begin
TransparentStretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH,
MaskDC, Source.Left, Source.Top);
end
else
begin
StretchBlt(FHandle, Dest.Left, Dest.Top, DstW, DstH,
Bitmap.Canvas.FHandle, Source.Left, Source.Top, SrcW, SrcH, SrcCopy);
crText := SetTextColor(Self.FHandle, 0);
crBack := SetBkColor(Self.FHandle, $FFFFFF);
StretchBlt(Self.FHandle, Dest.Left, Dest.Top, DstW, DstH,
MaskDC, Source.Left, Source.Top, SrcW, SrcH, ROP_DSPDxax);
SetTextColor(Self.FHandle, crText);
SetBkColor(Self.FHandle, crBack);
end;
finally
if Assigned(Mask) then Mask.Free
else
begin
if MaskHandle <> 0 then SelectObject(MaskDC, MaskHandle);
DeleteDC(MaskDC);
end;
end;
finally
Bitmap.Canvas.Unlock;
end;
Changed;
finally
Unlock;
end;
end;


Me encuetro con las funciones LOCK Y UNLOCK del tbitmap. Hummm ..... pruebo y ... BINGO. YA NO CONSUME RAM.
Como sigue incrementando el numero de errores de pagina, leo y leo y resulta que solo es un contador de cuantas veces el sistema a tirado de disco (aunque no me lo creo) cuando falla la busqueda en ram, osea, una cosa rara del S.O. pero que no afecta a la aplicacion (o eso parece de momento)

El codigo ha quedado asi.

procedure TscrServer.SendScreen(AContext: TIdContext; cliente: word);
var
msg: string;
LBuffer: TBytes;
LBitmap: TBitmap;
LBytesStream: TBytesStream;
LPngImage: TPngImage;
c: TCanvas;
r: TRect;
begin
// crear objetos
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
LBitmap := TBitmap.Create;
LPngImage := TPngImage.Create;
LBytesStream := TBytesStream.Create;
try
// copiar la pantalla en la imagen bitmap
r := Rect(0, 0, ScreenWidth, ScreenHeight);
LBitmap.Canvas.Lock;
LBitmap.Height := ScreenHeight;
LBitmap.Width := ScreenWidth;
LBitmap.Canvas.CopyRect(r, c, r);
LBitmap.Canvas.Unlock;
// convertir bitmap en PNG
LPngImage.Canvas.lock;
LPngImage.CompressionLevel := calidadCompresion;
LPngImage.Assign(LBitmap);
LPngImage.Canvas.Unlock;
// pasa el PNG a Stream
LPngImage.SaveToStream(LBytesStream);
SetLength(LBuffer, LBytesStream.Size + 1);
Move(LBytesStream.Bytes[0], LBuffer[0], LBytesStream.Size);
// enviar pantalla al cliente
msg := '[SCR-' + IntToStr(LBytesStream.Size) + ']';
IdTCPServerSCRresponse(msg, AContext);
ActualizaEstado('>SCR-SERVIDOR-' + AContext.Connection.Socket.Binding.PeerIP +
':' + IntToStr(AContext.Connection.Socket.Binding.PeerPort) +
' ' + msg);
clientes[cliente].IOHandler.Write(LBuffer);
finally
// liberar memoria
ReleaseDC(0, c.Handle);
c.Handle := 0;
c.Free;
LBitmap.Free;
LPngImage.Free;
LBytesStream.Free;
SetLength(LBuffer, 0);
end;
EsperaSegundos(0.001);
end;


y en la parte del cliente (o visualizador de la pantalla)
El evento onexecute del idtcpserver



procedure TFormPantalla.IdTCPServerSCRExecute(AContext: TIdContext);
begin
if SCRSize = 0 then
Exit;
if (GetTickCount() - tOutLoad) > 5000 then
begin
Application.MessageBox('TimeOut > 5000 ms', 'Atención', MB_ICONWARNING + MB_OK);
Imagen.Picture := nil;
Imagen.Refresh;
SCRSize := 0;
Exit;
end;
with AContext.Connection.IOHandler do
begin
CheckForDataOnSource(10);
if not InputBufferIsEmpty then
begin
InputBuffer.ExtractToBytes(SCRBuffer, -1, True);
GaugeLoad.Progress := Length(SCRBuffer);
GaugeLoad.Refresh;
tOutLoad := GetTickCount();
if Length(SCRBuffer) >= SCRSize then
begin
PintaPantalla(SCRBuffer);
SCRSize := 0;
SetLength(SCRBuffer, 0);
GaugeLoad.Progress := 0;
GaugeLoad.Refresh;
tFinLoad := GetTickCount();
STtimeLoad.Caption := IntToStr(tFinLoad - tIniLoad) + ' ms.';
Pidepantalla();
end;
end;
end;
end;


Y el "pintador" (he aprovechado a ponerle lock y unlock al tpngimage tambien que seguro que daño no le hace)

procedure TFormPantalla.ProcesaPantalla(recibido: string);
begin
SCRSize := StrToIntDef(Copy(recibido, 6, Length(recibido) - 6), 0);
GaugeLoad.MaxValue := SCRSize;
GaugeLoad.Refresh;
end;

procedure TFormPantalla.PintaPantalla(recibido: TBytes);
var
LStream: TMemoryStream;
LPngImage: TPngImage;
LBuffer: TBytes;
begin
LStream := TMemoryStream.Create;
LPngImage := TPngImage.Create;
LStream.Write(recibido[0], Length(recibido));
LStream.Position := 0;
LPngImage.Canvas.Lock;
LPngImage.LoadFromStream(LStream);
LPngImage.Canvas.Unlock;
Imagen.Picture.Assign(LPngImage);
Imagen.Refresh;
LStream.Free;
LPngImage.Free;
SetLength(LBuffer, 0);
end;

procedure TFormPantalla.PidePantalla;
begin
GaugeLoad.Progress := 0;
GaugeLoad.Refresh;
if IdTCPClientCMD.IOHandler = nil then
Exit;
tIniLoad := GetTickCount();
tOutLoad := tIniLoad;
EsperaSegundos(0.1); // dar 1 decima de segundo para otros procesos
IdTCPClientCMD.IOHandler.WriteLn('[OKSCR]');
end;


delphi.com.ar, tal y como esta el codigo, los objetos son creados previamente, (como falle la creacion de objetos mal vamos o muy mal este ese PC) pero si falla cualquiera de las operaciones (que fallan cuando se queda sin ram) los objetos son liberados si o si. Con tu ejemplo, que se agradece por supuesto) los objetos solo se crean consecutivamente si todo va bien si no se liberan igual que con mi codigo.

En cuanto a los errores de pagina, mirar esta imagen (es windows 7 pro 64) vereis que firefox (de terceros) y sidebar (propio de windows) tienen muchos errores de pagina, millones de errores, incluso el propio Delphi.
http://fotos.miarroba.es/fo/cf8d/2A4F624E09204F2971CC264F29710C.jpg

Tengo que probrar esas GDIplus.
Por cierto escafandra uso Delphi 10

[escafandra]

He preparado un ejemplo con GDI+ API Flat que va a funcionar en versiones antiguas de delphi como la 6 y 7. Simplemente enviamos a bajo nivel un bloque de memoria contenido en un istream por un soket:


uses
Windows, ActiveX, WinSock;


type
TCLSID = TGUID;
PCLSID = ^TCLSID;

TImageCodecInfo = packed record
Clsid: TCLSID;
FormatID: TGUID;
CodecName: PWCHAR;
DllName: PWCHAR;
FormatDescription: PWCHAR;
FilenameExtension: PWCHAR;
MimeType: PWCHAR;
Flags: DWORD;
Version: DWORD;
SigCount: DWORD;
SigSize: DWORD;
SigPattern: PBYTE;
SigMask: PBYTE;
end;
PImageCodecInfo = ^TImageCodecInfo;

function wcscmp(wstr1, wstr2: PWCHAR): Integer; cdecl external 'crtdll';

// GDI+ Flat API...
function GdiplusStartup(var GdiToken: DWORD; Startup, Output: PBYTE): Cardinal; stdcall external 'gdiplus';
procedure GdiplusShutdown(GdiToken: DWORD); stdcall external 'gdiplus';
function GdipCreateBitmapFromHBITMAP(hbm: HBITMAP; hpal: HPALETTE; var GBitmap: THANDLE): Cardinal; stdcall external 'gdiplus';
function GdipGetImageEncodersSize(var numEncoders: DWORD; var size: DWORD): Cardinal; stdcall external 'gdiplus';
function GdipGetImageEncoders(numEncoders, size: DWORD; encoders: PImageCodecInfo): Cardinal; stdcall external 'gdiplus';
function GdipDisposeImage(image: THANDLE): Cardinal; stdcall external 'gdiplus';
function GdipSaveImageToStream(image: THANDLE; stream: ISTREAM; var clsidEncoder: TCLSID; encoderParams: Pointer): Cardinal; stdcall external 'gdiplus';


implementation

// Obtener el CLSID para la codificación de un formato gráfico
function GetEncoderClsid(Format: PWCHAR; var Clsid: TCLSID): boolean;
var
i, N, Size: Cardinal;
ICInfo: array of TImageCodecInfo;
begin
Result:= false;
i:= 0; N:= 0; Size:= 0;
GdipGetImageEncodersSize(N, Size);
if Size > 0 then
begin
SetLength(ICInfo, Size);
GdipGetImageEncoders(N, Size, @ICInfo[0]);
while ( i< N ) and (wcscmp(ICInfo[i].MimeType, Format)<>0) do inc(i);
if i < N then Clsid:= ICInfo[i].Clsid;
end;
Result:= boolean( i < N );
end;

procedure SendScreen(hSocket: TSOCKET);
var
gdiplusToken: DWORD;
GdiPlusStartupInput: array[0..2] of int64;
CursorInf: TCURSORINFO;
IconInf: ICONINFO;
hScreen, hCanvas: HDC;
Bitmap: HBITMAP;
GBitmap: THANDLE;
Stream: IStream;
stat: STATSTG;
Clsid: TCLSID;
hMem: HGLOBAL;
Memory: Pointer;

begin
// Inicializamos GDI+.
GdiPlusStartupInput[0]:= 1; GdiPlusStartupInput[1]:= 0;
if GdiplusStartup(gdiplusToken, @GdiPlusStartupInput, nil) <> 0 then exit;

// Capturo la pantalla
hScreen:= GetDC(0);
hCanvas:= CreateCompatibleDC(0);
Bitmap:= CreateCompatibleBitmap(hScreen,GetDeviceCaps(hScreen, HORZRES), GetDeviceCaps(hScreen, VERTRES));
SelectObject(hCanvas, Bitmap);
BitBlt(hCanvas, 0, 0, GetDeviceCaps(hScreen, HORZRES), GetDeviceCaps(hScreen, VERTRES), hScreen, 0, 0, SRCCOPY);

// Capturo el cursor
ZeroMemory(@CursorInf, sizeof(TCURSORINFO));
CursorInf.cbSize:= sizeof(TCURSORINFO);
if GetCursorInfo(CursorInf) and (CursorInf.flags = CURSOR_SHOWING) then
begin
GetIconInfo(CursorInf.hCursor, IconInf);
DrawIcon(hCanvas, CursorInf.ptScreenPos.x - IconInf.xHotspot, CursorInf.ptScreenPos.y - IconInf.yHotspot, CursorInf.hCursor);
DeleteObject(IconInf.hbmColor);
DeleteObject(IconInf.hbmMask);
end;

// Procedo a enviar un bloque de memoria con la imagen comprimida en png
CreateStreamOnHGlobal(0, true, stream);
GdipCreateBitmapFromHBITMAP(Bitmap, 0, GBitmap);
GetEncoderCLSID('image/png', Clsid);
GdipSaveImageToStream(GBitmap, stream, Clsid, nil);
// Obtengo el tamaño del bloque de memoria
stream.Stat(stat, STATFLAG_NONAME);
// Obtengo el puntero del bloque de memoria (stat.cbSize)
GetHGlobalFromStream(stream, hMem);
Memory:= GlobalLock(hMem);

// Envío el bloque de memoria
send(hSocket, Memory^, stat.cbSize, 0);

// libero los Objetos usados del GDI+ bloques y Handles
GdipDisposeImage(GBitmap);
GlobalUnlock(hMem);
DeleteObject(Bitmap);
DeleteDC(hCanvas);
ReleaseDC(0, hScreen);

// Shutdown GDI+
GdiplusShutdown(gdiplusToken);
end;



Saludos.

[cesarsoftware]

Entendido escafandrada

Pero al final tienes que crear un stream para pasarle la imagen, es decir solo nos ahorramos el componente TPng pero se "complica" un poco usando las GDI (que tengo que estudiarlas a fondo, gracias por el ejemplo). La funcion "PintaPantalla" con componentes tarda entre 64 y 78 ms en realizar la operacion en casi cualquier PC.
Es las pruebas que he realizado (por cierto que he "cargado" los componentes Indy de la parte del servidor y los e reemplazado por socket, ya sabes bind, linten, accept y thread, luego los sustituyo en el cliente) la eficiencia es similar. Donde mas me preocupa la eficiencia es la copia de zonas de memoria.

Ahora tengo un "RxBuffer: array[0..65535] of ansichar;" en el servidor que lo recoje de "RxLen := recv(nSocket, RxBuffer, 65536, 0);" y veras que tengo un bucle for para copiar el contenido, ahi si creo que estoy fallando en rendimiento. No veo la funcion que permite esa copia de memoria tipo strcopy etc ¿sabes tu cual es?
Bueno en realizad tengo una zona donde recibo del socket que "RxBuffer" y lo copio con "for" al onRecibido y este "ServidorRecibido" incrementa el buffer para generar la imagen. Tambien seria genial saber cual es la funcion que copia, o mejor dicho, incrementa un buffer con el contenido de otro.

Gracias por seguir el tema (curiosa las funciones Lock/UnLock del bitmap, jejeje)


var
SCRBuffer: array of ansichar;

procedure TFormPantalla.ServidorRecibido(Sender: TObject);
var
i, rec, p: integer;
begin
p := SCRrec; // posicion anterior
rec := ServidorSCR.RxLen;
Inc(SCRRec, rec);
SetLength(SCRbuffer, SCRRec);
for i := 0 to rec - 1 do
SCRBuffer[p + i] := ServidorSCR.RxBuffer[i];
if (GetTickCount() - tOutLoad) > 5000 then
begin
Application.MessageBox('TimeOut > 5000 ms', 'Atención', MB_ICONWARNING + MB_OK);
Imagen.Picture := nil;
Imagen.Refresh;
SCRSize := 0;
SCRRec := 0;
SetLength(SCRBuffer, 0);
GaugeLoad.Progress := 0;
GaugeLoad.Refresh;
tOutLoad := GetTickCount();
Exit;
end;
GaugeLoad.Progress := Length(SCRBuffer);
GaugeLoad.Refresh;
tOutLoad := GetTickCount();
if SCRrec = SCRSize then
begin
PintaPantalla();
SCRSize := 0;
SCRRec := 0;
SetLength(SCRBuffer, 0);
tFinLoad := GetTickCount();
STtimeLoad.Caption := IntToStr(tFinLoad - tIniLoad) + ' ms.';
Pidepantalla();
end;
end;

procedure TFormPantalla.ProcesaPantalla(recibido: string);
begin
SCRSize := StrToIntDef(Copy(recibido, 6, Length(recibido) - 6), 0);
GaugeLoad.MaxValue := SCRSize;
GaugeLoad.Refresh;
end;

procedure TFormPantalla.PintaPantalla();
var
LStream: TMemoryStream;
LPngImage: TPngImage;
begin
LStream := TMemoryStream.Create;
LPngImage := TPngImage.Create;
try
LStream.Write(SCRBuffer[0], SCRSize);
LStream.Position := 0;
LPngImage.Canvas.Lock;
LPngImage.LoadFromStream(LStream);
LPngImage.Canvas.Unlock;
Imagen.Picture.Assign(LPngImage);
Imagen.Refresh;
finally
LStream.Free;
LPngImage.Free;
end;
end;

procedure TFormPantalla.PidePantalla;
var
msg: ansistring;
begin
tIniLoad := GetTickCount();
tOutLoad := tIniLoad;
msg := '[OKSCR]' + #13 + #10;
ClienteCMD.Envia(AnsiString(msg));
end;

[cesarsoftware]

Ah escafandra. Un comentario.

La opcion de usar png es que en nivel 1 de compresion (el mas rapido, tienen 9 niveles y 0 es sin comprimir) un "printscreen" solo ocupa unos 300kb para enviar por el socket y una imagen BitMap se va a los 5 Mb, dato muy a tener en cuenta a nivel de rendimiento, aunque supongo que al hacelo en png quedara mas pequeño ¿o no? ¿cuanto ocupara "send(hSocket, Memory^, stat.cbSize, 0);"?


GdipCreateBitmapFromHBITMAP(Bitmap, 0, GBitmap);
GetEncoderCLSID('image/png', Clsid);
GdipSaveImageToStream(GBitmap, stream, Clsid, nil);


Un saludo.

[escafandra]

Pero al final tienes que crear un stream para pasarle la imagen, es decir solo nos ahorramos el componente TPng pero se "complica" un poco usando las GDI


Creas un Stream pero con la API de Windows con lo que ahorras recursos de la VCL aunque su verdadera utilidad sería en un mini servidor que no use VCL y por tanto reduzca su peso consideráblemente.


Donde mas me preocupa la eficiencia es la copia de zonas de memoria.

...tengo un bucle for para copiar el contenido, ahi si creo que estoy fallando en rendimiento. No veo la funcion que permite esa copia de memoria tipo strcopy etc ¿sabes tu cual es?

CopyMemory.


La opcion de usar png es que en nivel 1 de compresion (el mas rapido, tienen 9 niveles y 0 es sin comprimir) un "printscreen" solo ocupa unos 300kb para enviar por el socket y una imagen BitMap se va a los 5 Mb, dato muy a tener en cuenta a nivel de rendimiento, aunque supongo que al hacelo en png quedara mas pequeño ¿o no? ¿cuanto ocupara "send(hSocket, Memory^, stat.cbSize, 0);"?
Tal como está el código cada pantalla pesa unos 92Kb, pero sabes que png es un formato de compresión sin pérdida de calidad, con lo que pantallas con fotografías o vídeo pasarán bastante mas. La relación de compresión también puede manejarse con GDI+:

type
TEncoderParameter = packed record
Guid: TGUID;
NumberOfValues: ULONG;
Type_: ULONG;
Value: Pointer;
end;
PEncoderParameter = ^TEncoderParameter;

TEncoderParameters = packed record
Count : UINT;
Parameter : array[0..0] of TEncoderParameter;
end;
PEncoderParameters = ^TEncoderParameters;


procedure GetEncoderParameters(EP: PEncoderParameters; Quality: PULONG);
const
EncoderQuality: TGUID = '{1d5be4b5-fa4a-452d-9cdd-5db35105e7eb}';
begin
// Calidad de imagen y factor de compresión
// Quality = 100 es la maxima calidad.
EP.Count:= 1;
EP.Parameter[0].Guid:= EncoderQuality;
EP.Parameter[0].Type_:= 4; //Gdiplus::EncoderParameterValueTypeLong;
EP.Parameter[0].NumberOfValues:= 1;
EP.Parameter[0].Value:= Quality;
end;
..........

var
Quality: ULONG;
EP: TEncoderParameters;
begin
........
GetEncoderParameters(@EP, @Quality);
GdipSaveImageToStream(GBitmap, stream, Clsid, @EP);



Saludos.

[escafandra]

Otra cosa, ¿Has pensado en utilizar un sistema para enviar por red sólo lo que varía de una imagen a la siguiente, en lugar de pantallas completas?

Mira este enlace: resta de imágenes (http://www.delphiaccess.com/forum/tutoriales/resta-de-imagenes).


Saludos.

[cesarsoftware]

Otra cosa, ¿Has pensado en utilizar un sistema para enviar por red sólo lo que varía de una imagen a la siguiente, en lugar de pantallas completas?

Mira este enlace: resta de imágenes (http://www.delphiaccess.com/forum/tutoriales/resta-de-imagenes).


Saludos.

Co..ño escafandra. Muchas gracias, se ve que te lo curras bien, voy a poner en practica ahora mismo la resta de imagenes.
Que si, que llevaba tiempo pensando en hacerlo pero mas "a pelo" no usando la fuerza bruta e intelegente como la tuya, jejeje.
Supongo que el tema es buscar en las lineas "lo negro" y enviar la parte de la linea que no sea negro indicando X,Y y Len al socket.
Veremos que tal va de rendimiento.

PD: No conocia ese foro, tendre que visitarlo con calma. Ah "CopyMemory" si es que a veces nos pesa la cabeza....

Thanks.

[escafandra]

...Supongo que el tema es buscar en las lineas "lo negro" y enviar la parte de la linea que no sea negro indicando X,Y y Len al socket.
No, es mas sencillo que eso. La resta de imágenes te da una gran extensión en negro, al comprimir toda esa imagen, el "negro" no ocupa prácticamente nada, así que comprimes toda esa imagen a png. Luego debes encontrar una máscara de bits de la imagen, para saber que tienes que reconstruir en el PC destino. Simplemente envías dos imágenes de poco peso, la máscara (una imagen de un sólo plano de color) y la resta. En el PC destino basta realizar unas operaciones lógicas binarias con la imagen previa, la máscara y la resta... La API mágica que te va a permitir realizar de golpe esas operaciones, con toda la imagen va a ser BitBlt (http://msdn.microsoft.com/en-us/library/dd183370%28v=vs.85%29.aspx). Estudia los raster-operation codes.

En el enlace que te dí sobre el tema de resta de imágenes, encontrarás el uso de la API BitBlt con las operaciones lógicas y el uso de máscaras de bit para imágenes. En este otro tema también trabajo con máscaras: Transparencias (http://www.delphiaccess.com/forum/tutoriales/transparencias/).


Saludos.

[cesarsoftware]

Perdona que te lo pregunte directamente escafandra, basicamente por que no entiendo bien el tema de la mascara, o de graficos mejor dicho.
Creo que lo que entiendo es que enviamos una imagen solida, digamos todo en rojo a la que denominamos mascara. Luego enviamos la resta.
En destino comparamos la mascara (todo en rojo) con la resta (todo negro menos los cambios) y obtenemos la diferencia, creo que con OR o XOR.
Ahora aplicamos la diferencia sobre la imagen presentada con un AND. ¿algo asi?

En realidad ¿:o como se escribe eso en delphi :o ?

Te mando una cervecitas por adelantado.

[escafandra]

Quizás te he liado un poco. Voy a tratar de ser mas claro.

Supón que tenemos un fondo fijo (un campo...) sobre el que se mueve una pelota. Ahora piensa que cada vez que enviemos un fotograma vamos a recordar el previo. A la hora de enviar un nuevo fotograma restamos la nueva imagen y la vieja con el sistema que expliqué en el tema de resta de imágenes (http://www.delphiaccess.com/forum/tutoriales/resta-de-imagenes). El resultado será que donde previamente estaba la pelota ahora no está, con lo que la resta nos da un círculo con el dibujo del fondo que corresponda en esa posición. La nueva posición de la pelota será representada por la imagen misma de la pelota, y el resto del fondo será negro. Entonces en la resta tenemos:

1- Un fondo negro.
2- Un círculo de imagen de fondo (donde estaba previamente la pelota)
3- Una imagen de la pelota.

Lo sencillo sería trasladar esa imagen resta al PC remoto y pintarla sobre la imagen que tenemos previamente considerando que el fondo negro es transparente (transparencias (http://www.delphiaccess.com/forum/tutoriales/transparencias/)). Esto parece que funciona muy bien salvo un detalle. Si en la imagen que trasmitimos tenemos zonas negras que no resultan de la resta, se convertirán en zonas trasparentes desvirtuando el resultado final. Para resolver este inconveniente necesitamos diferenciar ambos negros. Tenemos dos opciones o usamos el canal alpha del png (cuarto color) para guardar en el lo que debe ser trasparente o usamos una máscara de un bit (blanco-negro). Esta opción nos permitirá trabajar con formato jpg u otros sin canal alpha. De modo que la máscara lleva la información de lo que será transparente.

Entonces, ¿para que queremos el negro de la imagen resultante de la resta de imágenes?. Pues para que al comprimirla, en el formato que sea, no ocupe lugar.

Espero que con esta explicación entiendas lo que pretendo trasmitir, a veces no me se explicar lo suficientemente bien. Ahora solo te queda estudiar el código para conseguir transparencias con máscaras y la resta de imágenes para que te quede todo un poco mas claro.

Perdona por el rollo y cambiarte los esquemas. Es bastante tarde, mis neuronas no funcionan al 100% y si sigo, te lio mas.


Saludos.

[cesarsoftware]

Hola escafandra
Gracias por tus aclaraciones, que se entienen muy bien. Solo me falta entender como componer la imagen con la resta enviada. Quiza me lo expliques mejor mas adelante:o, pero ahora otro tema que quiza te interese bastante mas.

Ya he aplicado la resta de imagenes.
Despues de muchas pruebas y comprobar que solo funciona si creo como globales los Bitmap que usa CreateSubtractBitmap en vez de crear (no la anterior oldScreen porque esa tiene que ser global si o si) y destruir los objetos cada vez. Con la funcion que presento abajo (muchas gracias por CreateSubstractBitmap) ya envio solo la diferencia. Me queda "completar" la imagen en destino (ahora solo se ve la diferencia/resta, jejeje). Aunque se envie solo la diferencia en bitmap ocupa un monton, asi que sigo enviando en png.
Peeeerooooo.. Al usar tu funcion consecutivamente, a los pocos segundos..."Out of memory resources", si mando la pantalla completa (es decir sin usar la funcion) se puede tirar horas sin "romperse" y sin consumir ram (que es el principio de este hilo, que nos estamos desviando, jejeje).

¿Se te ocurre que puede ser?


var
oldScreen: TBitMap;
LScreen: TBitmap;

procedure TscrServer.ScreenShot(Image: TBitmap);
var
DC: HDC;
begin
DC := GetDC(GetDesktopWindow);
try
Image.Canvas.Lock;
Image.Width := GetDeviceCaps(DC, HORZRES);
Image.Height := GetDeviceCaps(DC, VERTRES);
BitBlt(Image.Canvas.Handle, 0, 0, Image.Width,
Image.Height, DC, 0, 0, SRCCOPY);
Image.Canvas.UnLock;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
end;

procedure TscrServer.SendScreen(AContext: TIdContext; cliente: word);
var
msg: string;
LBuffer: TBytes;
LBytesStream: TBytesStream;
LBitmap: TBitmap;
LPngImage: TPngImage;
begin
// Crear bitmap
LBitmap := TBitmap.Create;
LPngImage := TPngImage.Create;
// Capturar pantalla
ScreenShot(LScreen);
// Obtener la diferencia si ya a enviado la pantalla completa
if primeravez = True then
LBitmap.Handle := CreateSubstractBitmap(LScreen.Canvas.Handle, oldScreen.Canvas.Handle)
else
begin
LBitmap.Canvas.Lock;
LBitmap.Assign(LScreen);
LBitmap.Canvas.UnLock;
end;
LBytesStream := TBytesStream.Create;
try
// convertir bitmap en PNG
LPngImage.CompressionLevel := calidadCompresion;
LPngImage.Canvas.Lock;
LPngImage.Assign(LBitmap);
LPngImage.Canvas.Unlock;
// pasa el PNG a Stream
LPngImage.SaveToStream(LBytesStream);
// pasar el stream al buffer de TBytes
SetLength(LBuffer, LBytesStream.Size + 1);
Move(LBytesStream.Bytes[0], LBuffer[0], LBytesStream.Size);
// enviar pantalla al cliente
if primeravez = False then
begin
msg := '[SCR-' + IntToStr(LBytesStream.Size) + ']';
primeravez := True;
end
else
msg := '[DIF-' + IntToStr(LBytesStream.Size) + ']';
IdTCPServerSCRresponse(msg, AContext);
ActualizaEstado('>SCR-SERVIDOR-' + AContext.Connection.Socket.Binding.PeerIP +
':' + IntToStr(AContext.Connection.Socket.Binding.PeerPort) +
' ' + msg);
clientes[cliente].IOHandler.Write(LBuffer);
finally
// liberar memoria
LBitmap.Free;
LPngImage.Free;
LBytesStream.Free;
SetLength(LBuffer, 0);
end;
// Guardar pantalla actual para proxima comparacion
oldScreen.Canvas.Lock;
oldScreen.Assign(LScreen);
oldScreen.Canvas.Unlock;
EsperaSegundos(0.001);
end;


¿Voy pididiendo algo para picar?

[escafandra]

Hoy he tenido un día muy liado. No tengo tiempo de analizar despacio tu código. Sólo decirte que CreateSubstractBitmap Crea un HBITMAP que debe ser liberado bien por la API DeleteObject, o bien por un objeto TBitmap al que se le asigna dicho HBITMAP.

Por lo demás decirte que Grandes bucles con repetición de llamadas a CreateSubstractBitmap no crean problemas con la memoria:

var
i: integer;
Bitmap: TBitmap;
begin
for i:= 0 to 3500 do
begin
Bitmap:= TBitmap.Create;
Bitmap.Handle:= CreateSubstractBitmap(Image2.Canvas.Handle, Image1.Canvas.Handle);
Image3.Picture.Bitmap.Assign(Bitmap);
Bitmap.Free;
end;
end;

Saludos.

[escafandra]

Creo que tu código puede simplificarse. No puedo correrlo en mi delphi 7 pero he realizado una prueba estable.
La prueba consiste en guardar la pantalla anterior, capturar una nueva, restar ambas y visualizar los resultados en 3 TImages. Al mismo tiempo Vuelco la resta en un TSream y simulo que lo envío por un socket. El proceso es repetido hasta la saciedad por un Timer a 100 ms.

Te expongo el código usado:


unit Unit1;

interface

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

type
TForm1 = class(TForm)
Image3: TImage;
Image1: TImage;
Image2: TImage;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure SendScreen(hSocket: TSOCKET);
procedure Timer1Timer(Sender: TObject);
private
OldScreen, NewScreen, SubScreen: TBitmap;
primera_vez: boolean;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.SendScreen(hSocket: TSOCKET);
var
ScrDC: HDC;
Stream: TMemoryStream;
begin

// Capturo la pantalla nueva
ScrDC:= GetDc(0);
BitBlt(NewScreen.Canvas.handle, 0, 0, NewScreen.Width, NewScreen.Height, ScrDC, 0, 0, SRCCOPY);
ReleaseDC(0, ScrDC);

if primera_vez then
begin
OldScreen.Assign(NewScreen);
Form1.Image1.Picture.Bitmap.Assign(OldScreen);
primera_vez:= false;
exit;
end;

// Resto las pantallas nueva y antigua
// Los TImages son para ver lo que pasa y de paso cargar un poco la máquina
SubScreen.Handle := CreateSubstractBitmap(NewScreen.Canvas.Handle, OldScreen.Canvas.Handle);
Image1.Picture.Bitmap.Assign(OldScreen); Image1.Update;
Image2.Picture.Bitmap.Assign(NewScreen); Image2.Update;
Image3.Picture.Bitmap.Assign(SubScreen); Image3.Update;
OldScreen.Assign(NewScreen);

// Envio
Stream:= TMemoryStream.Create;
// Aquí debes usar el componente TPngImage...
SubScreen.SaveToStream(Stream);
send(hSocket, Pointer(Stream.Memory)^, Stream.Size, 0);
Stream.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OldScreen := TBitmap.Create;
SubScreen := TBitmap.Create;
NewScreen := TBitmap.Create;
OldScreen.Width := GetSystemMetrics(SM_CXSCREEN);
OldScreen.Height := GetSystemMetrics(SM_CYSCREEN);
NewScreen.Width := GetSystemMetrics(SM_CXSCREEN);
NewScreen.Height := GetSystemMetrics(SM_CYSCREEN);
primera_vez:= true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
SendScreen(0);
end;

end.


Haz tus pruebas, seguro que no tienes fugas de memoria.


Saludos.

[cesarsoftware]

Hola escafandra

Justamente eso es lo que hice, un formulario con las tres imagenes, lo que no implemente fue el bucle, pero como me funciono entonces lo pase directamente al thread y con objetos creados en vez de timages. Supongo que al estar en un thread quizas habria que hacerlo dentro de la funcion sendscreen en vez de pedirselo a otra, pero tras muchas pruebas el "cuello" no lo tengo en la trasmision de la imagen porque es muy rapido comparando con la gestion de la misma.

Para que veas, estos son los tiempos que se toman en varias maquinas (muy aproximadamente y de memoria)

maquina | bitblt(SRCCOPY | pasar png | write stream | send(-recv( | total recepcion de pantalla
AMD x4 potente | 50-60 ms | 15-30 ms | 70-80 ms | 15-30 ms | 200-250 ms
PC cutre | 200-300 ms | 80-100 ms | 100-120 ms | 15-30 ms | 500-600 ms
Servidor W2003 | 400-500 ms | 130-150 ms | 150-200 ms | 15-30 ms | 800-1000 ms

Es decir al capturar casi 5 megas de pantalla a true color en bimap, luego pasar a png para que se queden entre 700 y 1000 kb, luego pasar ese peso a stream y a tbytes y por fin mandarlo.
Las funciones para obtener la resta de imagenes cursioamente no me suman mucho mas tiempo:confused: supongo que por trabajan con HDC en vez de con el Bitmap, pero eso es solo una suposicion. Lo que tengo que conseguir es un "hardcopy" de baja resolucion de tal manera que ya partamos de manejar pesos inferiores y por consiguiente el resto de procesos se aceleren notablemente. Justamente donde no hay diferencia es lo que los pc comparten, la red local, que ademas es la mas rapida. Mandar luego solo la diferecia ya sera muy bueno.

Voy a ver si aislo el codigo y lo pongo en un server y un cliente y podemos compartirlo en la comunidad.

Un saludo.

[escafandra]

Hola escafandra
tras muchas pruebas el "cuello" no lo tengo en la trasmision de la imagen porque es muy rapido comparando con la gestion de la misma...

...Es decir al capturar casi 5 megas de pantalla a true color en bimap, luego pasar a png para que se queden entre 700 y 1000 kb, luego pasar ese peso a stream y a tbytes y por fin mandarlo. Las funciones para obtener la resta de imagenes cursioamente no me suman mucho mas tiempo...


Si te fijas en mi código del anterior mensaje, no es necesario el paso a TBytes, con lo que algo de tiempo ahorras:
send(hSocket, Pointer(Stream.Memory)^, Stream.Size, 0);

La función CreateSubstractBitmap es muy rápida porque trabaja exclusivamente con la API de Windows. Es por eso que te propuse el uso de la API GDI plus de Windows para realizar la compresión a png y porque el código pesa mucho menos. Algunos mensajes mas arriba te expuse un ejemplo con GDI+, puedes tratar de ver si ganas velocidad.

Para bajar la resolución o número de planos de color puedes tratar de usar un HDC adecuado y realizar el bitblt sobre un bitmap de menor resolución cambiando a un StretchBlt (http://msdn.microsoft.com/en-us/library/dd145120(v=vs.85).aspx) pero el resultado puede ser menos vistoso... Bien es verdad que eso puede ajustar a la resolución del monitor donde se tenga que visualizar el resultado, que si es menor estaría desperdiciando información. Una aproximación puede ser enviar la resolución a la función SendScreen para que se ajuste a ella. De todas formas se debe ser cuidadoso con StretchBlt pues la calidad del resultado puede no la esperada.


Saludos.

[cesarsoftware]

Hola escafandra, vuelvo por aqui,

Digamos que ya tengo el sistema/estructura terminado (he usado parte de tu codigo optimizado, gracias por las aportaciones), solo me quedan algunos ajustes en el tema de envio de teclas y doble-click.

Me gustaria dejarte el proyecto completo para que vieras su rendimiento y lo uses a tu antojo, no es grande solo 3 modulos .pas el el ejecutable que hace de cliente y servidor a la vez, asi se puede copiar/pegar a varios equipos. Tambien "funciona" por intenet al usar un solo socket. Me he desecho de las indy pero por ahi no he ganado mucha velocidad.

El tema principal es que generar la imagen y comprimirla se lleva un moton de milisegundos, la mas rapida de todas ha excepcion del "printscreen" que es forzosamente un bitmap, es en formato jpg. El programilla maneja tanto bmp, jpg como png. En red local lo mas rapido es bmp, porque solo captura y aunque mande 5 mg por la red estos van muy rapidos.

Para el uso que esta pensado es suficiente, que un programa "gestor de lineas" pueda observar lo que hacen sus pc "esclavos" y para eso va "sobrao" es como una camara de vigilancia, puesdes hacer click y mandar teclas para operaciones sencillas. Ahora me gustaria afinarlo mas, pero como estrucutura cliente/servidor es un "ensayo razonable" que diria un erudito.

No se si es sufucientemente madura para dejarlo en el ftp de proyectos, ¿lo dejo ahi? o te lo hago llegar por otro medio.

[escafandra]

Me alegra que tu proyecto avance y que mis aportes te sirvan de ayuda.

No es complicado el envío de teclas y pulsaciones del ratón.

Sobre el tema de un mismo ejecutable para el cliente y el servidor, piensa en ello como un arma de doble filo, el vigilado puede convertirse en vigilante... Por otro lado este tema es controvertido por las implicaciones legales que pueda tener.

Tu decides si quieres subirlo al ftp y cuando subirlo. El nivel de madurez es importante al subir un proyecto terminado y las prestaciones que va a realizar serán las que decidas publicar. En ese punto no te puedo aconsejar mucho mas.

Te agradezco el ofrecimiento de tu proyecto. :)



Saludos.

[cesarsoftware]

Hola escafandra.

Te he enviado todo por mail, creo aunque esta escrito en delphi 10 se puede correr sobre cualquier compilador ya que no usa componentes especiales, quiza solo el png, pero con un par de comentarios todo arreglado porque usa tambien bmp y jpg.

La idea/funcion es que el cliente sin vcl este en las maquinas cliente y el visualizador en la de control, en este caso los he juntado para simplificarlo aqui en el foro. En cuanto a las implicaciones legales, bueno, pues ninguna, en principio porque esta destinado a un proyecto industrial y es el cliente el que ha pedido el servicio, pero estoy convencido que lo incluire en proyectos futuros y puede ser un buen argumento de venta "poder ver la pantalla de los clientes en tiempo real" lo mejor seria decir "poder controlar la pantalla de los clientes en tiempo real"

Como aspecto tecnico me queda que funcione bien los click y doble click, el click funciona excepto si se clicka sobre un submenu o botones del sistema como minimizar y cerrar, y el doble-click todavia estoy trabajando en si darle foco a la ventana o no. En cuanto a teclas creo que envio todas ya que no cojo el virtualkey sino la key mismo y la trasmito. aqui muestro la funciones que uso (ya vi un codigo tuyo en delphiacces creo con sendinput pero no me funciona) quiza tenga que analizarlo mejor.

funciones controlador/visualizador

procedure TFormPantalla.ImagenDblClick(Sender: TObject);
var
p: TPoint;
nX, nY: word;
msg: string;
begin
GetCursorPos(p);
// comprobar si esta redimensionada "strech"
if RGventana.ItemIndex = 1 then
begin
if resX >= Imagen.ClientWidth then
begin
nX := (p.X * resX) div Imagen.ClientWidth;
nY := (p.Y * resY) div Imagen.ClientHeight;
end
else
begin
nX := (p.X * Imagen.ClientWidth) div resX;
nY := (p.Y * Imagen.ClientHeight) div resY;
end;
end
else
begin
nX := p.X;
nY := p.Y;
end;
// enviar mensaje
msg := '[DBLCLICK-' + IntToStr(nX) + '-' + IntToStr(nY) + ']' + #13 + #10;
ClienteCMD.Envia(AnsiString(msg));
end;

procedure TFormPantalla.ImagenMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
msg: string;
nX, nY: word;
boton, pulsado: word;
begin
// comprobar si esta redimensionada "strech"
if RGventana.ItemIndex = 1 then
begin
if resX >= Imagen.ClientWidth then
begin
nX := (X * resX) div Imagen.ClientWidth;
nY := (Y * resY) div Imagen.ClientHeight;
end
else
begin
nX := (X * Imagen.ClientWidth) div resX;
nY := (Y * Imagen.ClientHeight) div resY;
end;
end
else
begin
nX := X;
nY := Y;
end;
// comprobar que boton a pulsado
boton := 0;
case Button of
mbLeft: boton := 0;
mbRight: boton := 1;
mbMiddle: boton := 2;
end;
// ver si hay pulsada alguna tecla
pulsado := 0;
if ssShift in Shift then
pulsado := pulsado and 1;
if ssAlt in Shift then
pulsado := pulsado and 2;
if ssCtrl in Shift then
pulsado := pulsado and 4;
if ssDouble in Shift then
pulsado := pulsado and 8;
if ssTouch in Shift then
pulsado := pulsado and 16;
if ssPen in Shift then
pulsado := pulsado and 32;
// enviar mensaje
msg := '[CLICK-' + IntToStr(boton) + '-' + IntToStr(pulsado) + '-' +
IntToStr(nX) + '-' + IntToStr(nY) + ']' + #13 + #10;
ClienteCMD.Envia(AnsiString(msg));
end;

procedure TFormPantalla.ImagenMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
msg: string;
begin
// si no esta activa la opcion
if CBcursor.Checked = False then
Exit;
// enviar el mensaje
msg := '[CURSOR-' + IntToStr(X) + '-' + IntToStr(Y) + ']' + #13 + #10;
ClienteCMD.Envia(AnsiString(msg));
end;

procedure TFormPantalla.FormKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
msg: string;
pulsado: word;
begin
// ver si hay combinacion de teclas
pulsado := 0;
if ssShift in Shift then
pulsado := pulsado and 1;
if ssAlt in Shift then
pulsado := pulsado and 2;
if ssCtrl in Shift then
pulsado := pulsado and 4;
if ssDouble in Shift then
pulsado := pulsado and 8;
if ssTouch in Shift then
pulsado := pulsado and 16;
if ssPen in Shift then
pulsado := pulsado and 32;
// enviar mensaje
msg := '[KEY-' + IntToStr(Key) + '-' + IntToStr(pulsado) + ']' + #13 + #10;
ClienteCMD.Envia(AnsiString(msg));
Key := 0;
// 16 Shift
// 17 Ctrl
// 18 Alt
// 19 Pausa
// 44 Imprimir pantalla
// 46 Supr
// 91 Windows izquierdo
// 92 Windows derecho
// 93 Boton secundario (menu contextual)
// 144 Bloq Num
// 145 Bloq Despl
end;


funciones cliente

procedure TscrServer.ProcesaKey(msg: string; cliente: word);
var
comandos: TStringList;
s: string;
i, key, pulsado: word;
begin
// recibida tecla pulsada
s := Copy(msg, 2, Length(msg) - 2);
s := s + '-';
comandos := TStringlist.Create;
ExtraeComandos(comandos, s, '-');
for i := 0 to comandos.Count - 1 do
comandos[i] := Copy(comandos[i], 1, Length(comandos[i]) - 1);
s := comandos[0];
key := StrToIntDef(comandos[1], 0);
pulsado := StrToIntDef(comandos[2], 0);
comandos.Free;
if (key = 0) and (pulsado = 0) then
begin
// Ctrl + Alt + Del (ahi que probar este codigo)
keybd_event(17, $45, KEYEVENTF_EXTENDEDKEY, 0); // VK_CONTROL
keybd_event(18, $45, KEYEVENTF_EXTENDEDKEY, 0); // 18 = ALT
keybd_event(46, $45, KEYEVENTF_EXTENDEDKEY, 0); // VK_DELETE
keybd_event(17, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); // VK_CONTROL
keybd_event(18, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); // 18 = ALT
keybd_event(46, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0); // VK_DELETE
end
else
begin
keybd_event(key, $45, KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(key, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
// 16 Shift
// 17 Ctrl
// 18 Alt
// 19 Pausa
// 44 Imprimir pantalla
// 46 Supr
// 91 Windows izquierdo
// 92 Windows derecho
// 93 Boton secundario (menu contextual)
// 144 Bloq Num
// 145 Bloq Despl
end;

procedure TscrServer.Clickraton(x, y: word; Foco, PosCursor: boolean; boton, pulsado: word);
var
ClientX, ClientY, ClientBoton, BotonUp, BotonDown: integer;
Window, Parent: HWnd;
WindowRect: TRECT;
begin
// click con cualquier boton del mouse
// ¿Que objeto se encuentra en las coordenadas facilitadas?
// (No funciona para ventanas ocultas o deshabilitadas)
Window := WindowFromPoint(Point(x, y));
// Si el identificador devuelto es distinto de 0 es que
// hay un objeto en las coordenadas facilitadas
if Window = 0 then
Exit;
// Coordenadas del objeto
GetWindowRect(Window, WindowRect);
// Traslado de las coordenadas facilitadas a las coordenadas del objeto
ClientX := x - WindowRect.Left;
ClientY := y - WindowRect.Top;
// Averiguamos si el objeto tiene ancestro
Parent := GetAncestor(Window, GA_ROOT);
// Si el objeto no tiene ancestro, es que es una ventana.
// Si el objeto tiene ancestro (una ventana), lo utilizamos, ya que el
// mensaje debe pasarse a una ventana.
if (Parent = 0) then
Parent := Window;
// Si deseas pasar la ventana a primer plano:
if Foco = True then
if (Parent <> GetForegroundWindow()) then
SetForegroundWindow(Parent);
// Posicionar el cursor si asi se desea
if PosCursor = True then
SetCursorPos(X, Y);
// compronar el boton a pulsar
ClientBoton := MK_LBUTTON;
BotonDown := WM_LBUTTONDOWN;
BotonUp := WM_LBUTTONUP;
case boton of
0: begin
ClientBoton := MK_LBUTTON;
BotonDown := WM_LBUTTONDOWN;
BotonUp := WM_LBUTTONUP;
end;
1: begin
ClientBoton := MK_RBUTTON;
BotonDown := WM_RBUTTONDOWN;
BotonUp := WM_RBUTTONUP;
end;
2: begin
ClientBoton := MK_MBUTTON;
BotonDown := WM_MBUTTONDOWN;
BotonUp := WM_MBUTTONUP;
end;
end;
// Enviamos a la ventana los mensajes correspondientes
PostMessage(Window, BotonDown, ClientBoton, ClientX or (ClientY shl 16));
PostMessage(Window, BotonUp, 0, ClientX or (ClientY shl 16));
end;

procedure TscrServer.DblClickraton(x, y: word);
var
ClientX, ClientY: word;
Window, Parent: HWnd;
WindowRect: TRECT;
begin
// doble-click
// ¿Que objeto se encuentra en las coordenadas facilitadas?
// (No funciona para ventanas ocultas o deshabilitadas)
Window := WindowFromPoint(Point(x, y));
// Si el identificador devuelto es distinto de 0 es que
// hay un objeto en las coordenadas facilitadas
if Window = 0 then
Exit;
// Coordenadas del objeto
GetWindowRect(Window, WindowRect);
// Traslado de las coordenadas facilitadas a las coordenadas del objeto
ClientX := x - WindowRect.Left;
ClientY := y - WindowRect.Top;
// Averiguamos si el objeto tiene ancestro
Parent := GetAncestor(Window, GA_ROOT);
// Si el objeto no tiene ancestro, es que es una ventana.
// Si el objeto tiene ancestro (una ventana), lo utilizamos, ya que el
// mensaje debe pasarse a una ventana.
if (Parent = 0) then
Parent := Window;
// pasar la ventana a primer plano:
if (Parent <> GetForegroundWindow()) then
SetForegroundWindow(Parent);
SetCursorPos(X, Y);
// este codigo hai que revisarlo
// Enviamos a la ventana los mensajes correspondientes
PostMessage(Window, WM_LBUTTONDOWN, MK_LBUTTON, ClientX or (ClientY shl 16));
PostMessage(Window, WM_LBUTTONUP, 0, ClientX or (ClientY shl 16));
Sleep(25);
PostMessage(Window, WM_LBUTTONDOWN, MK_LBUTTON, ClientX or (ClientY shl 16));
PostMessage(Window, WM_LBUTTONUP, 0, ClientX or (ClientY shl 16));
end;



Se te ocurre como mejorarlo.

un saludo.

[escafandra]

Se te ocurre como mejorarlo.

Si. Una vez mas con la API, a bajo nivel.

Has comentado que viste un ejemplo con SendInput (http://msdn.microsoft.com/en-us/library/windows/desktop/ms646310(v=vs.85).aspx). ¿No te funcionó?. Te aseguro que funciona y es el método mejor y mas aconsejable para simular eventos de ratón y teclado. Esa API te permite simular el teclado y el ratón con sólo cambiar el valor de la estructura INPUT. ¿Que te impide enviar un buffer con la estructura?. Simple, con una función en el cliente controlas teclado y ratón.

Saludos.

[Casimiro Notevi]

...
Bienvenido a clubdelphi, ¿ya leiste nuestra guía de estilo (http://www.clubdelphi.com/foros/guiaestilo.php)?, gracias por tu colaboración :)

[escafandra]

...Bienvenido a clubdelphi, ¿ya leiste nuestra guía de estilo (http://www.clubdelphi.com/foros/guiaestilo.php)?, gracias por tu colaboración :):eek:

Saludos.

[Casimiro Notevi]

:eek:Saludos.Es un mensaje borrado :rolleyes:

[escafandra]

Es un mensaje borrado :rolleyes:

Eso pensé... :D


Saludos.

[cesarsoftware]

Me alegra que tu proyecto avance y que mis aportes te sirvan de ayuda.

Buenos días, perdona que te moleste, pero he retomado el proyecto y tengo una duda que no consigo resolver.
Deje el tema de resta de imágenes porque tenia que entregarlo y mandaba la imagen completa, ahora estoy enviando la resta y eso es lo que veo, la resta.
Como creo inicialmente una imagen vacía, la primera vez la resta es la imagen completa, pero luego solo pinto la diferencia al asignar el Stream al bitmap.

Esta es la función


function TFormPantalla.PintaPantalla(): boolean;
var
LStream: TMemoryStream;
LPngImage: TPngImage;
begin
TimerTimeOut.Enabled := False;
Result := True;
if Self.WindowState = wsMinimized then
Exit;
LPngImage := TPngImage.Create;
LStream := TMemoryStream.Create;
try
LStream.Write(SCRBuffer[0], SCRSize);
LStream.Position := 0;
LPngImage.Canvas.Lock;
LPngImage.LoadFromStream(LStream);
LPngImage.Canvas.Unlock;
Imagen.Picture.Assign(LPngImage);
except
LStream.Free;
LPngImage.Free;
Result := False;
end;
LStream.Free;
LPngImage.Free;
end;


¿Como puedo hacer para, en vez de usar Imagen.Picture.Assign(LPngImagen), que es solo la diferencia, para "sumar" la diferencia recibida a la imagen actual?

Gracias y ya sabes que las ||-|| las pongo yo:)