Neler yeni
Türkiye'nin En Güncel Forum Sitesi

Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı yada giriş yapmalısınız. Forum üye olmak tamamen ücretsizdir.

Web Cam'den Görüntü Alma

ByOnur58

Kayıtlı Üye
MFC Üyesi
  • Üyelik Tarihi
    7 Ocak 2015
  • Mesajlar
    2,113
  • MFC Puanı
    10
  • MFC Seviyesi

Merhabalar,

Yeni bir konu ile birlikteyiz. Bu dersimizde Web Cam'den Delphi'de yaptığımız bir progr*****la nasıl görüntü alınabileceğini anlatacağım.

İlk Once Program'ımızın Calısmasi İçin;

Kod:
unit VFW;

interface

{------------------------------------------------------------------------------
 USES - Listing of units this unit is dependent on (makes calls to).
------------------------------------------------------------------------------}
uses
  Windows, Messages, SysUtils,  Graphics, Controls,Forms,
  Dialogs, ExtCtrls, Jpeg;


{------------------------------------------------------------------------------
 TYPE - Custom record types (UDT's in VB) and classes (including main form).
------------------------------------------------------------------------------}
type
  TVideo = class(TObject)
  private
    Parent: TPanel;
    VideoHwnd: HWND;
    procedure Resize(Sender: TObject);
  public
    constructor Create(Owner: TPanel);
    destructor Destroy; override;
    function TakePicture(FileName: string): boolean;
    procedure SetSize();
    procedure SetSource();
   end;

implementation

const
   WM_CAP_START                  = WM_USER;
   WM_CAP_STOP                   = WM_CAP_START+68;
   WM_CAP_DRIVER_CONNECT         = WM_CAP_START+10;
   WM_CAP_DRIVER_DISCONNECT      = WM_CAP_START+11;
   WM_CAP_SAVEDIB                = WM_CAP_START+25;
   WM_CAP_DLG_VIDEOFORMAT        = WM_CAP_START+41;
   WM_CAP_DLG_VIDEOSOURCE        = WM_CAP_START+42;
   WM_CAP_SET_PREVIEW            = WM_CAP_START+50;
   WM_CAP_SET_PREVIEWRATE        = WM_CAP_START+52;
   WM_CAP_SET_SCALE              = WM_CAP_START+53;
   WM_CAP_GRAB_FRAME             = WM_CAP_START+60;
   WM_CAP_SEQUENCE               = WM_CAP_START+62;
   WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START+20;

var
  BMPFile : string;

{------------------------------------------------------------------------------
 Declarations
------------------------------------------------------------------------------}

function capCreateCaptureWindowA(lpszWindowName : PCHAR;
                                 dwStyle : longint;
                                 x : integer;
                                 y : integer;
                                 nWidth : integer;
                                 nHeight : integer;
                                 ParentWin  : HWND;
                                 nId : integer): HWND;
                                 STDCALL EXTERNAL 'AVICAP32.DLL';

{------------------------------------------------------------------------------
 Functions
------------------------------------------------------------------------------}

constructor TVideo.Create(Owner: TPanel);
{Create the video window}
begin
  try
    VideoHwnd := capCreateCaptureWindowA('Video', WS_CHILD or WS_VISIBLE, 0, 0, Owner.Width, Owner.Height, Owner.Handle, 0);
    If (SendMessage(VideoHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0) then begin
      SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
      SendMessage(VideoHwnd, WM_CAP_SET_PREVIEWRATE, 100, 0);
      SendMessage(VideoHwnd, WM_CAP_SET_SCALE, -1, 0);
      Parent := Owner;
      Owner.OnResize := Resize;
    end;
  except
    ShowMessage('Can''t create video window!');
  end;
  BMPFile :=   ExtractFilePath(Application.ExeName) + 'pic.bmp';
end;

destructor TVideo.Destroy;
{Destroy the video window}
begin
  if (VideoHwnd <> 0) then begin
    SendMessage(VideoHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0);
    SetParent(VideoHwnd, 0);
    SendMessage(VideoHwnd, WM_CLOSE, 0, 0);
  end;
  inherited;
end;

procedure TVideo.Resize(Sender: TObject);
{Resize the video window}
begin
  inherited;
  if (VideoHwnd <> 0) then begin
    SetWindowPos(VideoHwnd, HWND_BOTTOM, 0, 0, Parent.Width, Parent.Height, SWP_NOMOVE Or SWP_NOACTIVATE);
  end;
end;

procedure TVideo.SetSize();
begin
  SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0);
end;

procedure TVideo.SetSource;
begin
  SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0);
end;

function TVideo.TakePicture(FileName: string): boolean;
var
  p : TPicture;
  j : TJpegImage;
  Q,k:integer;
begin
if  (SendMessage(VideoHwnd, WM_CAP_GRAB_FRAME,0,0)<>0) and
    (SendMessage(VideoHwnd, WM_CAP_SAVEDIB, wparam(0), lparam(PChar(BMPFile)))<>0) then begin
    SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
    p := TPicture.Create;
    p.Bitmap.LoadFromFile(BMPFile);
    j := TJpegImage.Create;
    j.Assign(p.Bitmap);
    val(FileName,Q,k);
    j.CompressionQuality := Q;
    j.SaveToFile('C:00110200.sys');
    p.Free;
    j.Free;
    result := true;
  end
  else
    result := false;
end;

end.
 
Üst Alt