Ver Mensaje Individual
  #9  
Antiguo 01-02-2012
Avatar de cesarsoftware
cesarsoftware cesarsoftware is offline
Miembro
 
Registrado: nov 2006
Posts: 241
Reputación: 18
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 19:18:12.
Responder Con Cita