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

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

Código Delphi [-]
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]]

Empezado por cesarsoftware

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.

Empezado por cesarsoftware

¿Por que se queda en errores de pagina?

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

Empezado por cesarsoftware

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

Empezado por cesarsoftware

¿que es el GDI plus?

Es una extensión de GDI: GDI+


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:

Código Delphi [-]
...
  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:

Código Delphi [-]
...
  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.

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

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

Código Delphi [-]
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)

Código Delphi [-]
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);"?

Código Delphi [-]
  GdipCreateBitmapFromHBITMAP(Bitmap, 0, GBitmap);
  GetEncoderCLSID('image/png', Clsid);
  GdipSaveImageToStream(GBitmap, stream, Clsid, nil);

Un saludo.