04/11/2005

ScreenShot direto para jpg

Carissimos,
Usei o código do imageserver dos exemplos Indy do delphi 6 para carregar imagens de uma determinada máquina (IP), porém ele salva em um ´.bmp´ de quase 3Mb o que está deixando o tempo entre um screenshot e outro muito grande.
Tentei transformar este mesmo ´.bmp´ em ´.jpg´, mas só o tempo de geração do arquivo já está tornando complicada a visualização pelo cliente.
Existe uma maneira de gerar um screenshot direto para um arquivo jpg ?

Extou usando o seguinte código:
---------------------------------------
procedure TfrmServer.ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
var
dc: HDC; lpPal : PLOGPALETTE;
begin
{test width and height}
if ((Width = 0) OR (Height = 0)) then exit;
bm.Width := Width;
bm.Height := Height;
{get the screen dc}
dc := GetDc(0);
if (dc = 0) then exit;
{do we have a palette device?}
if (GetDeviceCaps(dc, RASTERCAPS) AND
RC_PALETTE = RC_PALETTE) then
begin
{allocate memory for a logical palette}
GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
{fill in the palette version}
lpPal^.palVersion := $300;
{grab the system palette entries}
lpPal^.palNumEntries :=
GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
begin
{create the palette}
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
{copy from the screen to the bitmap}
BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;
------------------------------------------------

Desde já obrigado.


Paulocesar1301

Respostas

04/11/2005

Motta

Este código captura a tela e joga para um .jpg , copiei daqui mesmo creio, funciona mas em algumas máquinas não carrega a área de trabalho às vezes.

program Captura;

uses
  Windows, Messages, SysUtils, Graphics,clipbrd, jpeg,
  StdCtrls, ExtCtrls, Forms ,Dialogs,  FileCtrl;

{$R *.RES}

var
  tela: tBitmap;
  jpg: TJpegImage;
  dia,mes,ano,hora,min,seg,mseg : word;
  function fillstrL (s: string; l: byte; c:char): string;
  begin
    while length(s) < l do
      s:= c+s;
    result:= s;
  end;
begin
  Application.Initialize;
  Application.Run;
  //
  clipboard.Clear;
  //keybd_event(VK_SNAPSHOT,0,0,0); //tela toda
  keybd_event(VK_SNAPSHOT,1,0,0);  //form ativo
  Application.ProcessMessages;
  tela := TBitmap.Create;
  try
    tela.LoadFromClipboardFormat(CF_BITMAP,clipboard.GetAsHandle(CF_BITMAP),0);
    jpg := TJPEGImage.Create;
    jpg.Assign(tela);
    ForceDirectories(´c:\captura´);
    DecodeDate(Now,ano,mes,dia);
    DecodeTime(Now,hora,min,seg,mseg);
    jpg.SaveToFile(´c:\captura\´ +
                   IntToStr(ano) +
                   fillstrl(IntToStr(mes),2,´0´) +
                   fillstrl(IntToStr(dia),2,´0´) +
                   fillstrl(IntToStr(hora),2,´0´) +
                   fillstrl(IntToStr(min),2,´0´) +
                   fillstrl(IntToStr(seg),2,´0´) +
                   fillstrl(IntToStr(mseg),3,´0´) + ´.jpg´);
  except
    on e:exception do
    begin
      ShowMessage(e.message);
    end;
  end;
  Application.Terminate;
end.



Responder Citar

04/11/2005

Paulocesar1301

Brigadão.... funcionou beleza... até melhor que o sistema que já existia por aqui... 10... valew


Responder Citar

24/02/2006

Motta

Estou resgatando este tópico a lógica postada não funciona para w98 mas funciona para 2000, não testei com xp, alguém sabe porque ?

Desculpem o ´resgate´.

-----------------------------------------------------------


Responder Citar

13/06/2006

Motta

Este é um segundo resgate deste tópico , alguém sabe pq isto não funciona no w98 ??

Grato


Responder Citar

23/11/2006

Motta

3º resgate (desculpem) , não funciona tb em xp , alguem sabe pq ?

grato


Responder Citar