ScreenShot direto para jpg

04/11/2005

0

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

Paulocesar1301

Responder

Posts

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

04/11/2005

Paulocesar1301

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


Responder

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

13/06/2006

Motta

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

Grato


Responder

23/11/2006

Motta

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

grato


Responder

Que tal ter acesso a um e-book gratuito que vai te ajudar muito nesse momento decisivo?

Ver ebook

Recomendado pra quem ainda não iniciou o estudos.

Eu quero
Ver ebook

Recomendado para quem está passando por dificuldades nessa etapa inicial

Eu quero

Utilizamos cookies para fornecer uma melhor experiência para nossos usuários, consulte nossa política de privacidade.

Aceitar