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.
Código Delphi
[-]
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
Código Delphi
[-]
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);
Mask.Mask(Color);
Mask.Canvas.RequiredState([csHandleValid]);
MaskDC := Mask.Canvas.FHandle;
MaskHandle := 0;
end;
try
Bitmap.Canvas.RequiredState([csHandleValid]);
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.
Código Delphi
[-]
procedure TscrServer.SendScreen(AContext: TIdContext; cliente: word);
var
msg: string;
LBuffer: TBytes;
LBitmap: TBitmap;
LBytesStream: TBytesStream;
LPngImage: TPngImage;
c: TCanvas;
r: TRect;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
LBitmap := TBitmap.Create;
LPngImage := TPngImage.Create;
LBytesStream := TBytesStream.Create;
try
r := Rect(0, 0, ScreenWidth, ScreenHeight);
LBitmap.Canvas.Lock;
LBitmap.Height := ScreenHeight;
LBitmap.Width := ScreenWidth;
LBitmap.Canvas.CopyRect(r, c, r);
LBitmap.Canvas.Unlock;
LPngImage.Canvas.lock;
LPngImage.CompressionLevel := calidadCompresion;
LPngImage.Assign(LBitmap);
LPngImage.Canvas.Unlock;
LPngImage.SaveToStream(LBytesStream);
SetLength(LBuffer, LBytesStream.Size + 1);
Move(LBytesStream.Bytes[0], LBuffer[0], LBytesStream.Size);
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
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
Código Delphi
[-]
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)
Código Delphi
[-]
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); 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.
Tengo que probrar esas GDIplus.
Por cierto
escafandra uso Delphi 10