گرفتن عکس با WebCam در دلفی7

[mjdeveloper]

سلام به دوستان
امیدوارم به دوستانی که احتیاج به این کد دارن بتونه کمکی بکنه
-------------------------------------

//capture image with WebCam

 //design by mehdi jafari 

 unit CaptureImage;

 

 interface

 uses Windows, MMSystem, Messages, Clipbrd, jpeg, Graphics ,SysUtils, Classes ,adodb;

 //------------------

 const

   AVICAPDLL   = 'AVICAP32.DLL';

 

   WM_CAP_DRIVER_CONNECT     = WM_User + 10;

   WM_CAP_DRIVER_DISCONNECT  = WM_User + 11;

   WM_CAP_SET_PREVIEW        = WM_User + 50;

   WM_CAP_SET_PREVIEWRATE    = WM_User + 52;

   WM_CAP_GRAB_FRAME         = WM_User + 60;

   WM_CAP_FILE_SAVEDIB       = WM_User + 25;

   WM_CAP_EDIT_COPY          = WM_User+  30;

 //------------------

   Function capDriverConnect(hwnd:THandle; I: Word) : Bool;

   Function capDriverDisconnect(hwnd:THandle):Bool;

   Function capPreview(hwnd:THandle; f:Word):Bool;

   Function capGrabFrame(hwnd:THandle):Bool;

   Function capFileSaveDIB(hwnd:THandle; szName:LPCSTR):Bool;

   Function capEditCopy(hwnd:THandle):Bool;

   Function capPreviewRate(hwnd:THandle; wMS:Word):Bool;

 

   Function capCreateCaptureWindow(

     lpszWindowName      : LPCSTR;

     dwStyle             : DWORD;

     x, y                : integer;

     nWidth, nHeight     : integer;

     hwndParent          : HWND;

     nID                 : integer

     ): HWND; stdcall;

   Function GetPictureAndSave(webcam:THandle):TMemoryStream;

 

 implementation

 uses un_dm;

 //------------------------------------------------------------------------------

 function  capCreateCaptureWindow(

     lpszWindowName      : LPCSTR;

     dwStyle             : DWORD;

     x, y                : integer;

     nWidth, nHeight     : integer;

     hwndParent          : HWND;

     nID                 : integer

     ): HWND; stdcall; external AVICAPDLL name 'capCreateCaptureWindowA';

 //------------------------------------------------------------------------------

 Function capDriverConnect(hwnd:THandle; I: Word) : Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_DRIVER_CONNECT,I,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function capDriverDisconnect(hwnd:THandle):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_DRIVER_DISCONNECT,0,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function capPreview(hwnd:THandle; f:Word):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_SET_PREVIEW,f,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function capPreviewRate(hwnd:THandle; wMS:Word):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_SET_PREVIEWRATE,wMS,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function capGrabFrame(hwnd:THandle):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_GRAB_FRAME,0,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function capFileSaveDIB(hwnd:THandle; szName:LPCSTR):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_FILE_SAVEDIB,0,LParam(szNa  me))<>0;

 end;

 //------------------------------------------------------------------------------

 Function capEditCopy(hwnd:THandle):Bool;

 begin

   Result := SendMessage(hwnd,WM_CAP_EDIT_COPY,0,0)<>0;

 end;

 //------------------------------------------------------------------------------

 Function GetPictureAndSave(webcam:THandle):TMemoryStream;

 var

   Bitmap : TBitmap;

   m      : TJPEGImage;

   s      : TMemoryStream; 

 begin

   Clipboard.Clear;

   capGrabFrame(webcam);

   capEditCopy(webcam);

   Bitmap := TBitMap.create;

   try

     if Clipboard.HasFormat(CF_BITMAP) then

     Bitmap.LoadFromClipBoardFormat(cf_BitMap ,ClipBoard.GetAsHandle(cf_Bitmap), 0)

     else

     begin

       Result := nil;

       exit;

     end;

     m := TJPEGImage.Create;

     s := TMemoryStream.Create;

     try

       m.CompressionQuality := 50;

       m.Assign(Bitmap);

       m.SaveToStream(s);

       Result := s;

     finally

       m.Free;

     end;

   finally

     Bitmap.free;

   end;

 end;

 //------------------------------------------------------------------------------

 end.

 

 

این unit کار فرستادن پیغامهای مربوط به WebCam رو به ویندوز انجام میده.

طریقه استفاده :

unit unit1;

 

 interface

 uses

   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

   Dialogs, Grids, DBGrids, jpeg, ExtCtrls, StdCtrls, Db, AdoDb,

   Buttons, DateUtils;

  .

  .

  .

   Protected

     procedure InitCamera;

 .

 .

 .

 var

   webcam :THandle;

 

 implementation

 uses CaptureImage;

 

 procedure botton1onClick(sender:Tobject);

 var

   s:TMemoryStream;

   pic:TJPEGImage;

 begin

 try

    InitCamera;

    s:=TMemoryStream.Create;

    pic:=TJPEGImage.Create;

    try

       s.LoadFromStream(GetPictureAndSave(webcam));

       pic. pic.LoadFromStream(s);

       image1.Picture.graphic:=pic;

    finally

       s.Free;

       pic.free;

    end;

except

end;

 end;

 //-------------------------------------------------------------

 procedure Tform1.InitCamera;

 begin

 try

   webcam:=capCreateCaptureWindow('my webcam',WS_CHILD or WS_VISIBLE,

   0,0,pnlCamera.Width,

   pnlCamera.Height,

   pnlCamera.Handle,0);

   capDriverConnect(webcam,0);

   capPreviewRate(webcam,10);

   capPreview(webcam,1);

 except

 end;

 end;

 //----------------------------------------------------------

 

در پایان که برنامتون بسته میشه از این تابع استفاده کنید ---- در onClose

capDriverDisconnect(WebCam) 

کوچیک شما مهدی جعفری

[DAMAVAND]

سلام
اقا مهدی عزیز ممنون از راهنماییت .
ولی هر پست رو لطفا یک بار تکرار کنید.
قوانین سایت:
https://barnamenevis.org/showthread.php?t=51814
با تشکر

[mjdeveloper]

شرمنده قربان دیگه تکرار نمیشه