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

[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.

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);
        { 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.

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
  // 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

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); // 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.


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