عکس گرفتن از صفحه مانیتور. چگونه؟

[nasr]

سلام

چطور میشه از صفحه مانیتور عکس گرفت.
به غیر از کامپوننت ImageEN

ممنون

[nasr]

پیدا کردم


procedure ScreenShot(Bild: TBitMap);
var
c: TCanvas;
r: TRect;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
try
r := Rect(0, 0, Screen.Width, Screen.Height);
Bild.Width := Screen.Width;
Bild.Height := Screen.Height;
Bild.Canvas.CopyRect(r, c, r);

finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Visible := False;
Sleep(300); // some delay, ein wenig Zeit geben
ScreenShot(Image1.Picture.BitMap);
Form1.Visible := True;

end;

[nasr]

مشکل اینه که سرعتش خیلی پایینه و اگه یه تایمر بگذاری که هر یک ثانیه یک عکس بگیره خیلی کند عمل میکنه

[Valadi]

با سلام این هم چند تا راه برای Captuer کردن

uses
Graphics;

// Capture the entire screen
// Screenshot des gesamten Bildschirms
procedure ScreenShot(Bild: TBitMap);
var
c: TCanvas;
r: TRect;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
try
r := Rect(0, 0, Screen.Width, Screen.Height);
Bild.Width := Screen.Width;
Bild.Height := Screen.Height;
Bild.Canvas.CopyRect(r, c, r);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Visible := False;
Sleep(750); // some delay, ein wenig Zeit geben
ScreenShot(Image1.Picture.BitMap);
Form1.Visible := True;
end;


// Only active window
// Screenshot des aktiven Fensters
procedure ScreenShotActiveWindow(Bild: TBitMap);
var
c: TCanvas;
r, t: TRect;
h: THandle;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
h := GetForeGroundWindow;
if h <> 0 then
GetWindowRect(h, t);
try
r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
Bild.Width := t.Right - t.Left;
Bild.Height := t.Bottom - t.Top;
Bild.Canvas.CopyRect(r, c, t);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Form1.Visible := False;
Sleep(750); //some delay,ein wenig Zeit geben
ScreenShotActiveWindow(Image1.Picture.BitMap);
Form1.Visible := True;
end;

{**********************************************}
// Another print screen function by Xavier P:
// Capture the entire screen
procedure ScreenShot(x: Integer;
y: Integer; //(x, y) = Left-top coordinate
Width: Integer;
Height: Integer; //(Width-Height) = Bottom-Right coordinate
bm: TBitMap); //Destination
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
{create the palette}
bm.Palette := CreatePalette(lpPal^);
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;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
end;


{**********************************************}
// Capture a window
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
var
Left, Top, Width, Height: Word;
R: TRect;
dc: HDC;
lpPal: PLOGPALETTE;
begin
{Check if valid window handle}
if not IsWindow(hWindow) then Exit;
{Retrieves the rectangular coordinates of the specified window}
GetWindowRect(hWindow, R);
Left := R.Left;
Top := R.Top;
Width := R.Right - R.Left;
Height := R.Bottom - R.Top;
bm.Width := Width;
bm.Height := Height;
{get the screen dc}
dc := GetDc(0);
if (dc = 0) then
begin
Exit;
end;
{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,
Left,
Top,
SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;
// Example: Capture the foreground window:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
end;


{**********************************************}
const
cTileSize = 50;
function TForm1.GetSCREENSHOT: TBitmap;
var
Locked: Boolean;
X, Y, XS, YS: Integer;
Canvas: TCanvas;
R: TRect;
begin
Result := TBitmap.Create;
Result.Width := Screen.Width;
Result.Height := Screen.Height;
Canvas := TCanvas.Create;
Canvas.Handle := GetDC(0);
Locked := Canvas.TryLock;
try
XS := Pred(Screen.Width div cTileSize);
if Screen.Width mod cTileSize > 0 then
Inc(XS);
YS := Pred(Screen.Height div cTileSize);
if Screen.Height mod cTileSize > 0 then
Inc(YS);
for X := 0 to XS do
for Y := 0 to YS do
begin
R := Rect(
X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
Succ(Y) * cTileSize);
Result.Canvas.CopyRect(R, Canvas, R);
end;
finally
if Locked then
Canvas.Unlock;
ReleaseDC(0, Canvas.Handle);
Canvas.Free;
end;
end;

[nasr]

مشکل من در سرعت پایین ذخیره اونها در دیتابیسه که اینجا مطرح کردم
http://barnamenevis.org/forum/showthread.php?p=519834#post519834
ممنون

[Touska]

چون اینا رو Bitmap ذخیره میکنی .

تبدیل به jpeg و با Compression بالا فکر کنم مشکلتو حل کنه.

[nasr]

چون اینا رو Bitmap ذخیره میکنی .

تبدیل به jpeg و با Compression بالا فکر کنم مشکلتو حل کنه.


چطور باید این کار را بکنم؟

البته به غیر از استفاده از ImageEn

[Touska]

تبدیلش به این شکله : http://www.swissdelphicenter.ch/en/showcode.php?id=20

البته بر عکسش :)

و ذخیره کردنش هم در سایت هست و هم فکر کنم خودتون با MemoryStream بتونید ذخیرش کنید.

موفق باشید :)

[amir1360]

با سلام
چطوري ميشه وقتي فيلمي در حال پخش و ميخواي از صفحه مانيتور عكس بگيري از صحنه فيلم عكس نميگيره؟
آيا راه حلي براي اين موضوع هست؟؟

[Felony]

با سلام
چطوري ميشه وقتي فيلمي در حال پخش و ميخواي از صفحه مانيتور عكس بگيري از صحنه فيلم عكس نميگيره؟
آيا راه حلي براي اين موضوع هست؟؟

این رویه رو قبلا نوشته بودم ، از فیلم هم عکس میگیره ...

Procedure GetSnapshot(Address: String);
var
DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;
Bitmap: TBitmap;
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
Bitmap := TBitmap.Create;
with Bitmap do
begin
Width := Screen.Width;
Height:= Screen.Height;
PixelFormat := pfDevice;
Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopR ect);
SaveToFile (Address);
Free;
end;
DesktopCanvas.Free;
ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;

[mossaferin]

سلام


این رویه رو قبلا نوشته بودم ، از فیلم هم عکس میگیره ...


من تستش کردم ، از فیلم عکس نمیگیره ، راه کاره دیگه ای وجود داره که بشه از فیلم هم عکس گرفت ؟

[Felony]

من تستش کردم ، از فیلم عکس نمیگیره ، راه کاره دیگه ای وجود داره که بشه از فیلم هم عکس گرفت ؟
من خودم چند ده بار تست کردم و از فیلم هم عکس گرفت ، حتی یه تایمر گزاشتم و یک فیلم رو Full Screen کردم و باز هم از کل صفحه فیلم بدون هیچ مشکلی عکس گرفت .