Array
(
)

ScreenShot direto para jpg

Paulocesar1301
   - 04 nov 2005

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.


Motta
   - 04 nov 2005

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.

#Código


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.



Paulocesar1301
   - 04 nov 2005

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


Motta
   - 24 fev 2006

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

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


Motta
   - 13 jun 2006

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

Grato


Motta
   - 23 nov 2006

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

grato