webcam capture using DirectX9 issue

Delphi'de kod yazma ile ilgili sorularınızı bu foruma yazabilirsiniz.
Cevapla
Kullanıcı avatarı
mia
Üye
Mesajlar: 239
Kayıt: 17 Nis 2015 02:18

webcam capture using DirectX9 issue

Mesaj gönderen mia »

i have this project that i use it top capture webcam it works normal on EXE i can read the device list and capture the camera .

But when i try to use The same forms with the same files into a dll i only can read the device list and unable to Capture the camera

any idea why ?

Here is the full project code

Kod: Tümünü seç

unit Testcm;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, ufrmCam;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Cam :TfrmCam;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(cam) then
begin
cam := TfrmCam.Create(self);
end;
cam.openWebCam;
cam.Show;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(cam) then
begin
  FreeAndNil(cam);
end;
end;

end. 

Cam form

Kod: Tümünü seç

unit ufrmCam;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Controls, Forms,
  Dialogs, Menus, ExtCtrls, StdCtrls, JvExStdCtrls, Graphics,
  IniFiles, JPEG, VFrames, VSample, Direct3D9, DirectDraw, DirectShow9,
  DirectSound, DXTypes,
  Vcl.ComCtrls;

type
  TfrmCam = class(TForm)
    shp1: TShape;
    img1: TImage;
    lbl_camstatus: TLabel;
    Button1: TButton;
    cbb1: TComboBox;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    formClosed: Boolean;
    fVideoImage: TVideoImage;
    fVideoBitmap: TBitmap;
    fActivated: Boolean;
    procedure OnNewVideoFrame(Sender: TObject; Width, Height: integer;
      DataPtr: pointer);
    procedure OnNewVideoCanvas(Sender: TObject; Width, Height: integer;
      DataPtr: pointer);

  public
    { Public declarations }
    procedure openWebCam;
    procedure closeWebCam;
    procedure AddNick(Nick: String);
    procedure RemoveNick(Nick: String);
  end;

var
  frmCam: TfrmCam;

implementation

{$R *.dfm}

procedure TfrmCam.RemoveNick(Nick: String);
begin

end;

procedure TfrmCam.AddNick(Nick: String);
begin

end;

procedure TfrmCam.Button1Click(Sender: TObject);
begin
  if fActivated then
  begin
    fVideoImage.OnNewVideoFrame := OnNewVideoCanvas;
    img1.Picture.Bitmap.Assign(fVideoBitmap);
  end
  else
  begin
    lbl_camstatus.Caption := 'Disconnected';
  end;
end;

procedure TfrmCam.closeWebCam;
begin

end;

procedure TfrmCam.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  // CanClose := False;
  // f.btnCamClick(nil);
end;

procedure TfrmCam.FormCreate(Sender: TObject);
var
  DeviceList: Tstringlist;
begin
  fVideoBitmap := TBitmap.create;
  fActivated := false;
  fVideoImage := TVideoImage.create;

  DeviceList := Tstringlist.create;

  fVideoImage.GetListOfDevices(DeviceList);
  cbb1.Items := DeviceList;
  DeviceList.Free;

  cbb1.ItemIndex := 0;

end;

procedure TfrmCam.FormDestroy(Sender: TObject);
begin
  try
    fVideoImage.VideoStop;
  except
  end;

  try
    fVideoBitmap.Free;
  except
  end;

  try
    fVideoImage.Free;
  except
  end;
end;

procedure TfrmCam.FormShow(Sender: TObject);
begin
  formClosed := false;

  self.Width := self.Width + 1;
  self.Height := self.Height + 1;

  self.Width := self.Width - 1;
  self.Height := self.Height - 1;
end;

{ TvideoForm }

procedure TfrmCam.OnNewVideoFrame(Sender: TObject; Width, Height: integer;
  DataPtr: pointer);
begin
  fVideoImage.GetBitmap(fVideoBitmap);
end;

procedure TfrmCam.OnNewVideoCanvas(Sender: TObject; Width, Height: integer;
  DataPtr: pointer);
begin
  fVideoImage.GetBitmap(fVideoBitmap);
  // Pega o frame atual, Nمo sei pq mas precisa desta linha para funcionar.
  img1.Picture.Bitmap.Canvas.Draw(0, 0, fVideoBitmap);
  // Envia frame a frame de vيdeo para o componente TImage, tb nمo entendi direito o pq de sَ funcionar com o canvas, mas deu certo.
end;

procedure TfrmCam.openWebCam;
var
  camdevice: string;
begin

  camdevice := Trim(cbb1.Items.Strings[cbb1.ItemIndex]);

  if camdevice <> '' then
  begin
    try

      fVideoImage.VideoStart(camdevice);

      fVideoImage.OnNewVideoFrame := OnNewVideoFrame;

      fActivated := true;

      lbl_camstatus.Caption := 'Connected';
      lbl_camstatus.Font.Color := clGreen;
    except
      fActivated := false;
      lbl_camstatus.Caption := 'Disconnected';
      lbl_camstatus.Font.Color := clRed;
    end;

    lbl_camstatus.Caption := camdevice;

  end;

end;

end.

Vframes

Kod: Tümünü seç

unit VFrames;

(******************************************************************************

  VFrames.pas
  Class TVideoImage

About
  The TVideoImage class provides a simplified access to the class TVideoSample
  from source unit VSample.pas.
  It is used to access WebCams and similar Video-capture devices via DirectShow.
  Its focus is on acquiring single images (frames) from the running video stream
  sent by the cameras. There exist methods to control properties (e.g. size,
  brightness etc.)
  Acquisition is fast enough to simulate running video.
  No audio support.

History
  Version 1.4
    Added support for YUY2 (YUYV, YUNV), MJPG,  I420 (YV12, IYUV)

  Version 1.3
  07.09.2008
    Added Video-Size and Video-property control
    Added check for extreme CPU load

  Version 1.2
  30.08.2008
    Added Pause and Resume
    
  Version 1.1
  26.07.2008

Contact:
  michael@grizzlymotion.com

Copyright
  For copyrights of the DirectX Header ports see the original source files.
  Other code (unless stated otherwise, see comments): Copyright (C) M. Braun

Licence:
  The lion share of this project lies within the ports of the DirectX header
  files (which are under the Mozilla Public License Version 1.1), and the
  original SDK sample files from Microsoft (END-USER LICENSE AGREEMENT FOR
  MICROSOFT SOFTWARE DirectX 9.0 Software Development Kit Update (Summer 2003))

  My own contribution compared to that work is very small (although it cost me
  lots of time), but still is "significant enough" to fulfill Microsofts licence
  agreement ;)
  So I think, the ZLib licence (http://www.zlib.net/zlib_license.html)
  should be sufficient for my code contributions.

Please note:
  There exist much more complete alternatives (incl. sound, AVI etc.):
  - DSPack (http://www.progdigy.com/)
  - TVideoCapture by Egor Averchenkov (can be found at http://www.torry.net)


******************************************************************************)



interface


USES Windows, Messages, Controls, Forms, SysUtils, Graphics, Classes,
     AppEvnts, MMSystem, DirectShow9, JPEG,
     VSample;

CONST
  CBufferCnt = 3;

TYPE
  TNewVideoFrameEvent = procedure(Sender : TObject; Width, Height: integer; DataPtr: pointer) of object;
  TVideoProperty = (VP_Brightness,
                    VP_Contrast,
                    VP_Hue,
                    VP_Saturation,
                    VP_Sharpness,
                    VP_Gamma,
                    VP_ColorEnable,
                    VP_WhiteBalance,
                    VP_BacklightCompensation,
                    VP_Gain);
  TVideoImage = class
                  private
                    VideoSample   : TVideoSample;
                    OnNewFrameBusy: boolean;
                    fVideoRunning : boolean;
                    fBusy         : boolean;
                    fSkipCnt      : integer;
                    fFrameCnt     : integer;
                    f30FrameTick  : cardinal;
                    fFPS          : double;  // "Real" fps, even if not all frames will be displayed.
                    fWidth,
                    fHeight       : integer;
                    fFourCC       : cardinal;
                    fBitmap       : TBitmap;
                    fDisplayCanvas: TCanvas;
                    fImagePtr     : ARRAY[0..CBufferCnt] OF pointer; // Local copy of image data
                    fImagePtrSize : ARRAY[0..CBufferCnt] OF integer;
                    fImagePtrIndex: integer;
                    fMessageHWND  : HWND;
                    fMsgNewFrame  : uint;
                    fOnNewFrame   : TNewVideoFrameEvent;
                    AppEvent      : TApplicationEvents;
                    IdleEventTick : cardinal;
                    ValueY_298,
                    ValueU_100,
                    ValueU_516,
                    ValueV_409,
                    ValueV_208    : ARRAY[byte] OF integer;
                    ValueClip     : ARRAY[-1023..1023] OF byte;
                    fYUY2TablesPrepared : boolean;
                    JPG           : TJPEGImage;
                    MemStream     : TMemoryStream;
                    fImageUnpacked: boolean;
                    procedure     PaintFrame;
                    procedure     UnpackFrame(Size: integer; pData: pointer);
                    procedure     WndProc(var Msg: TMessage);
                    function      VideoSampleIsPaused: boolean;
                    procedure     AppEventsIdle(Sender: TObject; var Done: Boolean);
                    procedure     CallBack(pb : pbytearray; var Size: integer);
                    function      TranslateProperty(const VP: TVideoProperty; VAR VPAP: TVideoProcAmpProperty): HResult;
                    PROCEDURE     PrepareTables;
                    procedure     YUY2_to_RGB(pData: pointer);
                    procedure     I420_to_RGB(pData: pointer);
                  public
                    constructor   Create;
                    destructor    Destroy; override;
                    procedure     Free;
                    property      IsPaused: boolean read VideoSampleIsPaused;
                    property      VideoRunning : boolean read fVideoRunning;
                    property      VideoWidth: integer read fWidth;
                    property      VideoHeight: integer read fHeight;
                    property      OnNewVideoFrame : TNewVideoFrameEvent read fOnNewFrame write fOnNewFrame;
                    property      FramesPerSecond: double read fFPS;
                    property      FramesSkipped: integer read fSkipCnt;
                    procedure     GetListOfDevices(DeviceList: TStringList);
                    procedure     VideoStop;
                    procedure     VideoPause;
                    procedure     VideoResume;
                    function      VideoStart(DeviceName: string): integer;
                    procedure     GetBitmap(BMP: TBitmap);
                    procedure     SetDisplayCanvas(Canvas: TCanvas);
                    procedure     ShowProperty;
                    procedure     ShowProperty_Stream;
                    FUNCTION      ShowVfWCaptureDlg: HResult;
                    procedure     GetBrightnessSettings(VAR Actual: integer);
                    procedure     SetBrightnessSettings(const Actual: integer);
                    PROCEDURE     GetListOfSupportedVideoSizes(VidSize: TStringList);
                    PROCEDURE     SetResolutionByIndex(Index: integer);
                    FUNCTION      GetVideoPropertySettings(    VP                : TVideoProperty;
                                                           VAR MinVal, MaxVal,
                                                               StepSize, Default,
                                                               Actual            : integer;
                                                           VAR AutoMode: boolean): HResult;
                    FUNCTION      SetVideoPropertySettings(VP: TVideoProperty; Actual: integer; AutoMode: boolean): HResult;
                end;



FUNCTION GetVideoPropertyName(VP: TVideoProperty): string;


// http://www.fourcc.org/yuv.php#UYVY

CONST
  FourCC_YUY2 = $32595559;
  FourCC_YUYV = $56595559;
  FourCC_YUNV = $564E5559;

  FourCC_MJPG = $47504A4D;

  FourCC_I420 = $30323449;
  FourCC_YV12 = $32315659;
  FourCC_IYUV = $56555949;




implementation



FUNCTION GetVideoPropertyName(VP: TVideoProperty): string;
BEGIN
  CASE VP OF
    VP_Brightness           : Result := 'Brightness';
    VP_Contrast             : Result := 'Contrast';
    VP_Hue                  : Result := 'Hue';
    VP_Saturation           : Result := 'Saturation';
    VP_Sharpness            : Result := 'Sharpness';
    VP_Gamma                : Result := 'Gamma';
    VP_ColorEnable          : Result := 'ColorEnable';
    VP_WhiteBalance         : Result := 'WhiteBalance';
    VP_BacklightCompensation: Result := 'Backlight';
    VP_Gain                 : Result := 'Gain';
  END; {case}
END;



(* Finally, callback seems to work. Previously it only ran for a few seconds.
   The reason for that seemed to be a deadlock (see http://msdn.microsoft.com/en-us/library/ms786692(VS.85).aspx)
   Now the image data is copied immediatly, and a message is sent to invoke the
   display of the data. *)
procedure TVideoImage.CallBack(pb : pbytearray; var Size: integer);
var
  i  : integer;
  T1 : cardinal;
begin
  Inc(fFrameCnt);

  // Calculate "Frames per second"...
  T1 := TimeGetTime;
  IF fFrameCnt mod 30 = 0 then
    begin
      if f30FrameTick > 0 then
        fFPS := 30000 / (T1-f30FrameTick);
      f30FrameTick := T1;
    end;

  // Does the application run in unhealthy CPU usage?
  // Check, if no idle event has occured for at least 1 sec.
  // If so, skip current frame and give application time to "breathe".
  IF Abs(T1-IdleEventTick) > 1000 then
    begin
      Inc(fSkipCnt);
      exit;
    end;

  // Adjust pointer to image data if necessary
  i := (fImagePtrIndex+1) mod CBufferCnt;
  IF fImagePtrSize[i] <> Size then
    begin
      IF fImagePtrSize[i] > 0 then
        FreeMem(fImagePtr[i], fImagePtrSize[i]);
      fImagePtrSize[i] := Size;
      GetMem(fImagePtr[i], fImagePtrSize[i]);
    end;
  // Save image data to local memory
  move(pb^, fImagePtr[i]^, Size);
  fImagePtrIndex := i;
  fImageUnpacked := false;

  // This routine is called by the video software and therefore runs within their thread.
  // Posting a message to our own HWND will transport the information to the main thread.
  PostMessage(fMessageHWND, fMsgNewFrame, Size, integer(fImagePtr[i]));
  sleep(0);
end;



// Own windows message handler only to get the "New Video Frame has arrived" message.
// Used to get the information out of the Camera-Thread into the application's thread.
// Otherwise we would run into a deadlock.
procedure TVideoImage.WndProc(var Msg: TMessage);
begin
  with Msg do
    if Msg = fMsgNewFrame then
      try
        IF not fBusy then
          begin
            fBusy := true;
            fImageUnpacked := false;
            PaintFrame; // If a Display-Canvas has been set, paint video image on it.
            IF assigned(fOnNewFrame) then
              fOnNewFrame(self, fWidth, fHeight, fImagePtr[fImagePtrIndex]);
            fBusy := false;
          end
          else Inc(fSkipCnt);
      except
        Application.HandleException(Self);
        fBusy := false;
      end
    else Result := DefWindowProc(fMessageHWND, Msg, wParam, lParam);
end;



constructor TVideoImage.Create;
VAR
  i : integer;
begin
  inherited Create;
  fVideoRunning   := false;
  OnNewFrameBusy  := false;
  fBitmap         := TBitmap.Create;
  fDisplayCanvas  := nil;
  fWidth          := 0;
  fHeight         := 0;
  fFourCC         := 0;
  FOR i := 0 TO CBufferCnt-1 DO
    BEGIN
      fImagePtr[i]     := nil; 
      fImagePtrSize[i] := 0;
    END;
  fMsgNewFrame    := wm_user+662;
  fOnNewFrame     := nil;
  fBusy           := false;
  // Create a HWND that can capture some messages for us...
  fMessageHWND    := AllocateHWND(WndProc);
  AppEvent        := TApplicationEvents.Create(Application.MainForm);
  AppEvent.OnIdle := AppEventsIdle;
  JPG             := TJPEGImage.Create;
  MemStream       := TMemoryStream.Create;
end;


// Check, when the last OnIdle message arrived. Save a time stamp.
// Used to check the CPU load. If necessary, we will skip video frames...
procedure TVideoImage.AppEventsIdle(Sender: TObject; var Done: Boolean);
begin
  IdleEventTick := TimeGetTime;
  Done := true;
end;


destructor  TVideoImage.Destroy;
VAR
  i : integer;
begin
  FOR i := CBufferCnt-1 DOWNTO 0 DO
    IF fImagePtrSize[i] <> 0 then
      begin
        FreeMem(fImagePtr[i], fImagePtrSize[i]);
        fImagePtr[i] := nil;
        fImagePtrSize[i] := 0;
      end;
  DeallocateHWnd(fMessageHWND);
  inherited Destroy;
end;



procedure TVideoImage.Free;
begin
  fDisplayCanvas := nil;
  fBitmap.Free;
  AppEvent.OnIdle := nil;
  AppEvent.Free;
  AppEvent := nil;
  inherited Free;
end;


// For Properties see also http://msdn.microsoft.com/en-us/library/ms786938(VS.85).aspx
function TVideoImage.TranslateProperty(const VP: TVideoProperty; VAR VPAP: TVideoProcAmpProperty): HResult;
begin
  Result := S_OK;
  CASE VP OF
    VP_Brightness             : VPAP := VideoProcAmp_Brightness;
    VP_Contrast               : VPAP := VideoProcAmp_Contrast;
    VP_Hue                    : VPAP := VideoProcAmp_Hue;
    VP_Saturation             : VPAP := VideoProcAmp_Saturation;
    VP_Sharpness              : VPAP := VideoProcAmp_Sharpness;
    VP_Gamma                  : VPAP := VideoProcAmp_Gamma;
    VP_ColorEnable            : VPAP := VideoProcAmp_ColorEnable;
    VP_WhiteBalance           : VPAP := VideoProcAmp_WhiteBalance;
    VP_BacklightCompensation  : VPAP := VideoProcAmp_BacklightCompensation;
    VP_Gain                   : VPAP := VideoProcAmp_Gain;
    else Result := S_False;
  END; {case}
end;



FUNCTION TVideoImage.GetVideoPropertySettings(VP: TVideoProperty; VAR MinVal, MaxVal, StepSize, Default, Actual: integer; VAR AutoMode: boolean): HResult;
VAR
  VPAP       : TVideoProcAmpProperty;
  pCapsFlags : TVideoProcAmpFlags;
BEGIN
  Result   := S_FALSE;
  MinVal   := -1;
  MaxVal   := -1;
  StepSize := 0;
  Default  := 0;
  Actual   := 0;
  AutoMode := true;
  IF not(assigned(VideoSample)) or Failed(TranslateProperty(VP, VPAP)) then
    exit;
  Result := TranslateProperty(VP, VPAP);
  IF Failed(Result) then
    exit;

  Result := VideoSample.GetVideoPropAmpEx(VPAP, MinVal, MaxVal, StepSize, Default, pCapsFlags, Actual);
  IF Failed(Result) then
    begin
      MinVal   := -1;
      MaxVal   := -1;
      StepSize := 0;
      Default  := 0;
      Actual   := 0;
      AutoMode := true;
    end
    else begin
      AutoMode := pCapsFlags <> VideoProcAmp_Flags_Manual;
    end;
END;



FUNCTION TVideoImage.SetVideoPropertySettings(VP: TVideoProperty; Actual: integer; AutoMode: boolean): HResult;
VAR
  VPAP       : TVideoProcAmpProperty;
  pCapsFlags : TVideoProcAmpFlags;
BEGIN
  Result := TranslateProperty(VP, VPAP);
  IF not(assigned(VideoSample)) or Failed(Result) then
    exit;
  IF AutoMode
    then pCapsFlags := VideoProcAmp_Flags_Auto
    else pCapsFlags := VideoProcAmp_Flags_Manual;
  Result := VideoSample.SetVideoPropAmpEx(VPAP, pCapsFlags, Actual);
END;


procedure TVideoImage.GetListOfDevices(DeviceList: TStringList);
begin
  GetCaptureDeviceList(DeviceList);
end;


procedure TVideoImage.VideoPause;
begin
  if not assigned(VideoSample) then
    exit;
  VideoSample.PauseVideo;
end;



procedure TVideoImage.VideoResume;
begin
  if not assigned(VideoSample) then
    exit;
  VideoSample.ResumeVideo;
end;



procedure TVideoImage.VideoStop;
begin
  fFPS := 0;
  if not assigned(VideoSample) then
    exit;

  try
    VideoSample.Free;
    VideoSample := nil;
  except
  end;
  fVideoRunning := false;
end;



function TVideoImage.VideoStart(DeviceName: string): integer;
VAR
  hr     : HResult;
  st     : string;
  W, H   : integer;
  FourCC : cardinal;
begin
  fSkipCnt       := 0;
  fFrameCnt      := 0;
  f30FrameTick   := 0;
  fFPS           := 0;
  fImageUnpacked := false;

  Result := 0;
  if assigned(VideoSample) then
    VideoStop;

  VideoSample := TVideoSample.Create(Application.MainForm.Handle, false, 0, HR); // No longer force RGB24
  try
    hr := VideoSample.StartVideo(DeviceName, false, st) // Not visible. Displays itself...
  except
    hr := -1;
  end;

  if Failed(hr)
    then begin
      VideoStop;
     // SpeedButton_RunVideo.Down := false;
     // ShowMessage(DXGetErrorDescription9A(hr));
     Result := 1;
    end
    else begin
      hr := VideoSample.GetStreamInfo(W, H, FourCC);
      IF Failed(HR)
        then begin
          VideoStop;
          Result := 1;
        end
        else BEGIN
          fWidth := W;
          fHeight := H;
          fFourCC := FourCC;
          FBitmap.PixelFormat := pf24bit;
          FBitmap.Width := W;
          FBitmap.Height := H;
          VideoSample.SetCallBack(CallBack);  // Do not call GDI routines in Callback!
        END;
    end;
end;



function TVideoImage.VideoSampleIsPaused: boolean;
begin
  if assigned(VideoSample)
    then Result := VideoSample.PlayState = PS_PAUSED
    else Result := false;
end;


PROCEDURE TVideoImage.PrepareTables;
VAR
  i : integer;
BEGIN
  IF fYUY2TablesPrepared then
    exit;
  FOR i := 0 TO 255 DO
    BEGIN
      { http://msdn.microsoft.com/en-us/library/ms893078.aspx
      ValueY_298[i] := (i- 16) * 298  +  128;      //  -4640 .. 71350
      ValueU_100[i] := (i-128) * 100;              // -12800 .. 12700
      ValueU_516[i] := (i-128) * 516;              // -66048 .. 65532
      ValueV_409[i] := (i-128) * 409;              // -52352 .. 51943
      ValueV_208[i] := (i-128) * 208;              // -26624 .. 26416
      }
      // http://en.wikipedia.org/wiki/YCbCr  (ITU-R BT.601)
      ValueY_298[i] := round(i *  298.082);
      ValueU_100[i] := round(i * -100.291);
      ValueU_516[i] := round(i *  516.412  - 276.836*256);
      ValueV_409[i] := round(i *  408.583  - 222.921*256);
      ValueV_208[i] := round(i * -208.120  + 135.576*256);

    END;
  FillChar(ValueClip, SizeOf(ValueClip), #0);
  FOR i := 0 TO 255 DO
    ValueClip[i] := i;
  FOR i := 256 TO 1023 DO
    ValueClip[i] := 255;
  fYUY2TablesPrepared := true;
END;




procedure TVideoImage.I420_to_RGB(pData: pointer);
// http://en.wikipedia.org/wiki/YCbCr
VAR
  L, X, Y    : integer;
  ps         : pbyte;
  pY, pU, pV : pbyte;
begin
  pY := pData;
  PrepareTables;
  FOR Y := 0 TO fBitmap.Height-1 DO
    BEGIN
      ps := fBitmap.ScanLine[Y];

      pU := pData;
      Inc(pU, fBitmap.Width*(fBitmap.height+ Y div 4));
      pV := PU;
      Inc(pV, fBitmap.Width*fBitmap.height div 4);

      FOR X := 0 TO (fBitmap.Width div 2)-1 DO
        begin
          L := ValueY_298[pY^];
          ps^ := ValueClip[(L + ValueU_516[pU^]                  ) div 256];
          Inc(ps);
          ps^ := ValueClip[(L + ValueU_100[pU^] + ValueV_208[pV^]) div 256];
          Inc(ps);
          ps^ := ValueClip[(L                   + ValueV_409[pV^]) div 256];
          Inc(ps);
          Inc(pY);

          L := ValueY_298[pY^];
          ps^ := ValueClip[(L + ValueU_516[pU^]                     ) div 256];
          Inc(ps);
          ps^ := ValueClip[(L + ValueU_100[pU^] + ValueV_208[pV^]) div 256];
          Inc(ps);
          ps^ := ValueClip[(L                   + ValueV_409[pV^]) div 256];
          Inc(ps);
          Inc(pY);

          Inc(pU);
          Inc(pV);
        end;
    END;
end;



procedure TVideoImage.YUY2_to_RGB(pData: pointer);
// http://msdn.microsoft.com/en-us/library/ms893078.aspx
// http://en.wikipedia.org/wiki/YCbCr
type
  TFour  = ARRAY[0..3] OF byte;
VAR
  L, X, Y : integer;
  ps      : pbyte;
  pf      : ^TFour;
begin
  pf := pData;
  PrepareTables;
  FOR Y := 0 TO fBitmap.Height-1 DO
    BEGIN
      ps := fBitmap.ScanLine[Y];
      FOR X := 0 TO (fBitmap.Width div 2)-1 DO
        begin
          L := ValueY_298[pf^[0]];
          ps^ := ValueClip[(L + ValueU_516[pf^[1]]                     ) div 256];
          Inc(ps);
          ps^ := ValueClip[(L + ValueU_100[pf^[1]] + ValueV_208[pf^[3]]) div 256];
          Inc(ps);
          ps^ := ValueClip[(L                      + ValueV_409[pf^[3]]) div 256];
          Inc(ps);
          L := ValueY_298[pf^[2]];
          ps^ := ValueClip[(L + ValueU_516[pf^[1]]                     ) div 256];
          Inc(ps);
          ps^ := ValueClip[(L + ValueU_100[pf^[1]] + ValueV_208[pf^[3]]) div 256];
          Inc(ps);
          ps^ := ValueClip[(L                      + ValueV_409[pf^[3]]) div 256];
          Inc(ps);

          Inc(pf);
        end;
    END;
end;


procedure TVideoImage.PaintFrame;
BEGIN
  // Paint FBitmap to fDisplayCanvas, if available
  if assigned(fDisplayCanvas) then
    begin
      IF not fImageUnpacked then
        UnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);
      IF fDisplayCanvas.LockCount < 1 then
        begin
          fDisplayCanvas.lock;
          try
            fDisplayCanvas.Draw(0, 0, fBitmap);
          finally
            fDisplayCanvas.unlock;
          end;
        end;
    end;
END;


procedure TVideoImage.UnpackFrame(Size: integer; pData: pointer);
var
  {f       : file;}
  Unknown : boolean;
  FourCCSt: string[4];
begin
  IF pData = nil
    then exit;
  Unknown := false;
  try
    Case fFourCC OF
      0           :  BEGIN
                       IF (Size = fWidth*fHeight*3)
                         then move(pData^, FBitmap.scanline[fHeight-1]^, Size)
                         else Unknown := true;
                     END;
      FourCC_YUY2,
      FourCC_YUYV,
      FourCC_YUNV :  BEGIN
                       IF (Size = fWidth*fHeight*2)
                         then YUY2_to_RGB(pData)
                         else Unknown := true;
                     END;
      FourCC_MJPG :  BEGIN
                       try
                         MemStream.Clear;
                         MemStream.SetSize(Size);
                         MemStream.Position := 0;
                         MemStream.WriteBuffer(pData^, Size);
                         MemStream.Position := 0;
                         JPG.LoadFromStream(MemStream);
                         FBitmap.Canvas.Draw(0, 0, JPG);
                       except
                         Unknown := true;
                       end;
                     END;
      FourCC_I420,
      FourCC_YV12,
      FourCC_IYUV : BEGIN
                      IF (Size = (fWidth*fHeight*3) div 2)
                        then I420_to_RGB(pData)
                        else Unknown := true;
                    END;
      else          BEGIN
                      {
                      assignfile(f, 'Unknown_Frame.dat');
                      rewrite(f, 1);
                      Blockwrite(f, pData^, Size);
                      closefile(f);
                      }
                      Unknown := true;
                    END;
    end; {case}

    IF Unknown then
      begin
        IF fFourCC = 0
          then FourCCSt := 'RGB'
          else begin
            FourCCSt := '    ';
            move(fFourCC, FourCCSt[1], 4);
          end;
        FBitmap.Canvas.TextOut(0,  0, 'Unknown compression');
        FBitmap.Canvas.TextOut(0, FBitmap.Canvas.TextHeight('X'), 'DataSize: '+INtToStr(Size)+'  FourCC: '+FourCCSt);
      end;

    fImageUnpacked := true;
  except
  end;
end;



procedure TVideoImage.GetBitmap(BMP: TBitmap);
begin
  IF not fImageUnpacked then
    UnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);
  BMP.Assign(fBitmap);
  (*
  BMP.PixelFormat := pf24bit;
  BMP.Width := fBitmap.Width;
  BMP.Height := fBitmap.Height;
  move(fBitmap.ScanLine[fBitmap.Height-1]^, BMP.ScanLine[BMP.height-1]^, BMP.Height*BMP.Width*3);
  //BMP.Canvas.Draw(0, 0, fBitmap);
  *)
end;



procedure TVideoImage.SetDisplayCanvas(Canvas: TCanvas);
begin
  fDisplayCanvas := Canvas;
end;



procedure TVideoImage.ShowProperty;
begin
  VideoSample.ShowPropertyDialog;
end;



procedure TVideoImage.ShowProperty_Stream;
var
  hr     : HResult;
  W, H   : integer;
  FourCC : cardinal;
begin
  VideoSample.ShowPropertyDialog_CaptureStream;
  hr := VideoSample.GetStreamInfo(W, H, FourCC);
  IF Failed(HR)
    then begin
      VideoStop;
    end
    else BEGIN
      fWidth := W;
      fHeight := H;
      fFourCC := FourCC;
      FBitmap.PixelFormat := pf24bit;
      FBitmap.Width := W;
      FBitmap.Height := H;
      VideoSample.SetCallBack(CallBack);
    END;
end;



FUNCTION  TVideoImage.ShowVfWCaptureDlg: HResult;
begin
  Result := VideoSample.ShowVfWCaptureDlg;
end;



procedure TVideoImage.GetBrightnessSettings(VAR Actual: integer);
begin
//  VideoSample.GetVideoPropAmp(VideoProcAmp_Brightness, Actual)
end;



procedure TVideoImage.SetBrightnessSettings(const Actual: integer);
begin
//  VideoSample.SetVideoPropAmp(VideoProcAmp_Brightness, Actual);
end;


PROCEDURE TVideoImage.GetListOfSupportedVideoSizes(VidSize: TStringList);
BEGIN
  VideoSample.GetListOfVideoSizes(VidSize);
END;


PROCEDURE TVideoImage.SetResolutionByIndex(Index: integer);
VAR
  hr     : HResult;
  W, H   : integer;
  FourCC : cardinal;
BEGIN
  VideoSample.SetVideoSizeByListIndex(Index);
  hr := VideoSample.GetStreamInfo(W, H, FourCC);
  IF Succeeded(HR)
    then begin
      fWidth := W;
      fHeight := H;
      fFourCC := FourCC;
      FBitmap.PixelFormat := pf24bit;
      FBitmap.Width := W;
      FBitmap.Height := H;
    END;
END;


end.
بِسْمِ اللهِ الرَّحْمنِ الرَّحِيمِ
in god i trust with every movement i do
graduated student and looking for knowledge
Kullanıcı avatarı
G.Arkas
Üye
Mesajlar: 829
Kayıt: 01 Eki 2007 07:16
Konum: İstanbul
İletişim:

Re: webcam capture using DirectX9 issue

Mesaj gönderen G.Arkas »

Hey @mia,

I think your library is missing. And you have a Handle problem. I was work with directx capture on my old projects. You should have a application handle. For example, your unit is using

Kod: Tümünü seç

Application.Create;
But this is not from windows unit, you should use from fform.pas (this is external unit for virtual form creating). I am not at my office now, but i will send you tomorrow IncAllah. You can fix it with this unit.
Resim
Kullanıcı avatarı
mia
Üye
Mesajlar: 239
Kayıt: 17 Nis 2015 02:18

Re: webcam capture using DirectX9 issue

Mesaj gönderen mia »

Thank you G.Arkas i will be waiting inchallah .
بِسْمِ اللهِ الرَّحْمنِ الرَّحِيمِ
in god i trust with every movement i do
graduated student and looking for knowledge
Kullanıcı avatarı
G.Arkas
Üye
Mesajlar: 829
Kayıt: 01 Eki 2007 07:16
Konum: İstanbul
İletişim:

Re: webcam capture using DirectX9 issue

Mesaj gönderen G.Arkas »

hey @mia

You can use this unit.

Kod: Tümünü seç

unit fForms;

interface
uses Windows,  Messages;

type
  TWndMethod = procedure(var Message: TMessage) of object;
type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
  end;
type
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: PInstanceBlock;
    Code: array[1..2] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..313] of TObjectInstance;
  end;

type
  TApplication = class
  private
    FHandle: HWND;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property Handle: HWND read FHandle;
    procedure Initialize;
    procedure Run;
    procedure Terminate;
    procedure HandleException(Sender: TObject);
  end;
var
  UtilWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TPUtilWindow');
var
  Application: TApplication;
  InstFreeList: PObjectInstance;
  InstBlockList: PInstanceBlock;
function CoInitializeEx(pvReserved: Pointer; coInit: Longint): HResult; stdcall;external 'ole32.dll' name 'CoInitializeEx';
implementation
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;
function StdWndProc(Window: HWND; Message, WParam: Longint;
  LParam: Longint): Longint; stdcall; assembler;
asm
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    LParam
        PUSH    WParam
        PUSH    Message
        MOV     EDX,ESP
        MOV     EAX,[ECX].Longint[4]
        CALL    [ECX].Pointer
        ADD     ESP,12
        POP     EAX
end;
function MakeObjectInstance(Method: TWndMethod): Pointer;
const
  BlockCode: array[1..2] of Byte = (
    $59,       { POP ECX }
    $E9);      { JMP StdWndProc }
  PageSize = 4096;
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
end;
procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
  if ObjectInstance <> nil then
  begin
    PObjectInstance(ObjectInstance)^.Next := InstFreeList;
    InstFreeList := ObjectInstance;
  end;
end;
procedure DeallocateHWnd(Wnd: HWND);
var
  Instance: Pointer;
begin
  Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  DestroyWindow(Wnd);
  if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
end;

function AllocateHWnd(Method: TWndMethod): HWND;
var
  TempClass: TWndClass;
  ClassRegistered: Boolean;
begin
  UtilWindowClass.hInstance := HInstance;
{$IFDEF PIC}
  UtilWindowClass.lpfnWndProc := @DefWindowProc;
{$ENDIF}
  ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
    TempClass);
  if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  begin
    if ClassRegistered then
      Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
    Windows.RegisterClass(UtilWindowClass);
  end;
  Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
    '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
  if Assigned(Method) then
    SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;

procedure TApplication.WndProc(var Msg: TMessage);
begin
  with Msg do
  case Msg of
    WM_DESTROY: PostQuitMessage(0);
    else Result := DefWindowProc(FHandle, Msg, WParam, LParam);
  end;
end;

constructor TApplication.Create;
begin
  inherited Create;
  FHandle := 0;
end;

destructor TApplication.Destroy;
begin
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TApplication.Initialize;
begin
  FHandle := AllocateHWnd(WndProc);
  CoInitializeEx(nil, 0);
end;

procedure TApplication.Run;
var
  Msg: TMSG;
begin
  while GetMessage(Msg, 0, 0, 0) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

procedure TApplication.Terminate;
begin
  SendMessage(FHandle, WM_DESTROY, 0, 0);
end;

procedure TApplication.HandleException(Sender: TObject);
begin
  // do nothing
end;

initialization
  Application := TApplication.Create;

finalization
  Application.Free;

end.

Kod: Tümünü seç

  Application.Initialize;
  Application.Run;
That's enough for you.

Good luck.
Resim
Kullanıcı avatarı
mia
Üye
Mesajlar: 239
Kayıt: 17 Nis 2015 02:18

Re: webcam capture using DirectX9 issue

Mesaj gönderen mia »

G.arkas Thanks for posting . but i need to understand how this will work with Dll ? is this unit makes The Application.mainform.handle works ? and should i add the unit and export those intialize

also this part have an error

Kod: Tümünü seç

type
  TApplication = class // To fix you should add Class(Tobject)
  private
    FHandle: HWND;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property Handle: HWND read FHandle;
    procedure Initialize;
    procedure Run;
    procedure Terminate;
    procedure HandleException(Sender: TObject);
  end;
بِسْمِ اللهِ الرَّحْمنِ الرَّحِيمِ
in god i trust with every movement i do
graduated student and looking for knowledge
Kullanıcı avatarı
G.Arkas
Üye
Mesajlar: 829
Kayıt: 01 Eki 2007 07:16
Konum: İstanbul
İletişim:

Re: webcam capture using DirectX9 issue

Mesaj gönderen G.Arkas »

Hey @mia,

Thanks for comments. If you want use with directx on dll files, you will need a handle. I am working on dll like this;

Kod: Tümünü seç

function ClientWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;

implementation
      
function ClientWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
begin
  if Msg = WM_WEBCAMDIRECTX then
  begin
    CamHelper.GetCams;
    if CamHelper.CamCount > 0 then Result := 1 else Result := 0;
    Exit;
  end
  else

  if Msg = WM_WEBCAMLIST then
  begin
    WebcamList := WideString(CamHelper.GetCams);
    if CamHelper.CamCount <= 0 then WebcamList := WebCamList('|');
  end
  else

  if Msg = WM_WEBCAMSTART then
  begin
    if WebcamType = 0 then CamHelper.StartCam(WebcamId + 1);
    WebcamThread := TWebcamThread.Create;
    WebcamThread.Resume;
  end
  else Result := DefWindowProc(HWND, Msg, wParam, lParam);
end;
for create;

Kod: Tümünü seç

procedure InitClientObject;
begin
  ClientObject := TMyObject.Create('Crew_Motion_Detector', @ClientWindowProc);
  ShowWindow(ClientObject.Handle, SW_HIDE);
end;
Resim
Kullanıcı avatarı
mia
Üye
Mesajlar: 239
Kayıt: 17 Nis 2015 02:18

Re: webcam capture using DirectX9 issue

Mesaj gönderen mia »

here is the project on 2shared as EXE

http://www.2shared.com/file/zH9rxVZ0/TestCam.html

i really get difficulty to make this work on dll if you can show me an example with this project
بِسْمِ اللهِ الرَّحْمنِ الرَّحِيمِ
in god i trust with every movement i do
graduated student and looking for knowledge
Kullanıcı avatarı
G.Arkas
Üye
Mesajlar: 829
Kayıt: 01 Eki 2007 07:16
Konum: İstanbul
İletişim:

Re: webcam capture using DirectX9 issue

Mesaj gönderen G.Arkas »

I don't have XE2 and I did get an error (JvExStdCtrls).

Please try it

Kod: Tümünü seç

function ClientWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
begin
openWebCam;
end;

procedure InitClientObject;
begin
  ClientObject := TMyObject.Create('TEST WEBCAM', @ClientWindowProc);
  ShowWindow(ClientObject.Handle, SW_HIDE);
end;
I didn't try it but should be work.
Resim
Cevapla