Club Delphi  
    FTP   CCD     Enlaces   Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Principal > API de Windows
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Respuesta
 
Herramientas Desplegado
  #1  
Antiguo 27-01-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
O soy tonto o .... problema al liberar memoria

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.

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

Última edición por Casimiro Notevi fecha: 27-01-2012 a las 22:29:54.
Responder Con Cita
  #2  
Antiguo 27-01-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
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:

Código Delphi [-]
// liberar memoria
c.Free;
// No procede FreeAndNil(r);
LBitmap.Free;
LPngImage.Free;
LBytesStream.Free;
SetLength(LBuffer, 0);


Saludos.
Responder Con Cita
  #3  
Antiguo 30-01-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
Gracias por tu respuesta "escafandra"

Pero sigo igual

he probado a usar
Código Delphi [-]
 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
Código Delphi [-]
    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.
Responder Con Cita
  #4  
Antiguo 30-01-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
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"



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.


¿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.
Responder Con Cita
  #5  
Antiguo 30-01-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
prueba a liberar así:

Código Delphi [-]
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.
Responder Con Cita
  #6  
Antiguo 30-01-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
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?
Responder Con Cita
  #7  
Antiguo 31-01-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
Cita:
Empezado por cesarsoftware Ver Mensaje
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.

Cita:
Empezado por cesarsoftware Ver Mensaje
¿Por que se queda en errores de pagina?
Sin probar no te puedo decir, es posible que exista un bug en algún sitio...

Cita:
Empezado por cesarsoftware Ver Mensaje
¿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.

Cita:
Empezado por cesarsoftware Ver Mensaje
¿que es el GDI plus?
Es una extensión de GDI: GDI+


Saludos.
Responder Con Cita
  #8  
Antiguo 01-02-2012
Avatar de delphi.com.ar
delphi.com.ar delphi.com.ar is offline
Federico Firenze
 
Registrado: may 2003
Ubicación: Buenos Aires, Argentina *
Posts: 5.868
delphi.com.ar Va por buen camino
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!
__________________
delphi.com.ar

Dedique el tiempo suficiente para formular su pregunta si pretende que alguien dedique su tiempo en contestarla.
Responder Con Cita
  #9  
Antiguo 01-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
Solucionado

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

Última edición por cesarsoftware fecha: 01-02-2012 a las 18:18:12.
Responder Con Cita
  #10  
Antiguo 07-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
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.

Última edición por escafandra fecha: 07-02-2012 a las 12:28:31.
Responder Con Cita
  #11  
Antiguo 07-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
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;
Responder Con Cita
  #12  
Antiguo 07-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
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.
Responder Con Cita
  #13  
Antiguo 07-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
Cita:
Empezado por cesarsoftware Ver Mensaje
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.

Cita:
Empezado por cesarsoftware Ver Mensaje
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.

Cita:
Empezado por cesarsoftware Ver Mensaje
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+:

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

Última edición por escafandra fecha: 07-02-2012 a las 14:36:28.
Responder Con Cita
  #14  
Antiguo 07-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
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.


Saludos.

Última edición por escafandra fecha: 07-02-2012 a las 14:50:48.
Responder Con Cita
  #15  
Antiguo 07-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
Cita:
Empezado por escafandra Ver Mensaje
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.


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.
Responder Con Cita
  #16  
Antiguo 07-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
Cita:
Empezado por cesarsoftware Ver Mensaje
...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. 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.


Saludos.
Responder Con Cita
  #17  
Antiguo 07-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
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 ¿ como se escribe eso en delphi ?

Te mando una cervecitas por adelantado.
Responder Con Cita
  #18  
Antiguo 08-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
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. 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). 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.
Responder Con Cita
  #19  
Antiguo 08-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 226
cesarsoftware Va por buen camino
Lightbulb

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, 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?

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

Última edición por cesarsoftware fecha: 08-02-2012 a las 20:57:36.
Responder Con Cita
  #20  
Antiguo 09-02-2012
Avatar de escafandra
[escafandra] escafandra is offline
Miembro Premium
 
Registrado: nov 2007
Posts: 1.367
escafandra Va por buen camino
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:

Código Delphi [-]
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.
Responder Con Cita
Respuesta


Herramientas
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

Temas Similares
Tema Autor Foro Respuestas Último mensaje
liberar memoria Celta Varios 5 12-12-2010 18:07:17
Liberar memoria Sick boy Varios 6 02-07-2005 10:11:29
problema tonto gatsu PHP 2 25-04-2005 21:41:21
Liberar Memoria JoseQ Varios 6 16-07-2004 18:49:21
Liberar Memoria JODELSA Varios 4 13-05-2003 17:39:05


La franja horaria es GMT +2. Ahora son las 05:46:37.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi