Delphi 二維碼產生和掃描

 

Zint用於產生二維碼。

Zxing用讀取二維碼。

VFrames.pas和VSample.pas用於攝像頭。

另附帶攝像頭相關的類庫，也可用開源的dspack也可用於攝像頭的需求。

以上爲開源的信息，請在sourceforge.net上下載。

本例用zint.dll的版本爲2.6.0.

請在項目根目錄下如zxing中的Classes文件夾及裏面全部的文件。

設置此項目引用的文件，因爲zxing中區分vcl和fmx，本例用到VCL,故把USE_VCL_BITMAP的編譯選項加上去：

項目層次：

 

VFrames.pas

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 usually is fast enough to simulate running video.
  No audio support.

History
  Version 1.6
    2012-07-09
    Support for 8-bit Grayscale images. Reduces time for image expansion for some types
    of compressions. (But not for all, e.g. RGB!)
    Some memory leaks fixed.

  Version 1.5
    GDI+ support for MJPG, if GDI+ available
    YUY2 relaxed check of data size to support 1280*720 video size for Microsoft LifeCam Cinema

  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, Math,
     VSample;

CONST
  CBufferCnt = 3;  // Triple-Buffer

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;
                    fGray8Bit    : 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;
                    fBitmapGray   : 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;
                    ValueL_255    : ARRAY[byte] OF byte;
                    ValueClip     : ARRAY[-1023..1023] OF byte;
                    GrayConvR,
                    GrayConvG,
                    GrayConvB     : ARRAY[0..255] OF integer;
                    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     PrepareGrayBMP(VAR BM : TBitmap; W, H: integer);
                    PROCEDURE     PrepareTables;
                    procedure     YUY2_to_RGB(pData: pointer);
                    procedure     YUY2_to_Gray8Bit(pData: pointer);
                    procedure     I420_to_RGB(pData: pointer);
                    procedure     I420_to_Gray8Bit(pData: pointer);
                    procedure     RGB_to_Gray8Bit(pData: pointer);
                  public
                    constructor   Create;
                    destructor    Destroy; override;
                    property      IsPaused: boolean read VideoSampleIsPaused;
                    property      VideoRunning : boolean read fVideoRunning;
                    property      VideoWidth: integer read fWidth;
                    property      VideoHeight: integer read fHeight;
                    property      Gray8Bit: boolean read fGray8Bit write fGray8Bit;
                    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;
                    PROCEDURE     Convert24ToGray(BM24: TBitmap; BMGray: TBitmap);
                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;



  // frt auf Windows 7 zu unendlich kleinen Frameraten! -cm
{
  // 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;
  fBitmapGray     := 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;
//  JPG.Performance := jpBestSpeed;
  MemStream       := TMemoryStream.Create;

  fGray8Bit := false;
  FOR i := 0 TO 255 DO
    BEGIN
      GrayConvR[i] := 100 * i;
      GrayConvG[i] := 128 * i;
      GrayConvB[i] :=  28 * i  +127;
    END;

  PrepareTables;
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);

  fDisplayCanvas := nil;
  fBitmapGray.Free;
  fBitmap.Free;
  JPG.Free;
  AppEvent.OnIdle := nil;
  AppEvent.Free;
  AppEvent := nil;
  MemStream.Free;

  inherited Destroy;
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;
     // 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;
          PrepareGrayBMP(FBitmapGray, W, 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;



// Create an 8bit grayscale palette image with width W and Height H.
PROCEDURE TVideoImage.PrepareGrayBMP(VAR BM : TBitmap; W, H: integer);
TYPE
  TLogPal =  packed record
               palVersion: Word;
               palNumEntries: Word;
               palPalEntry: array[0..255] of TPaletteEntry;  // In contrast to original declaration uses 255 instead of 0
             end;
VAR
  Pal  : TLogPal;
  _Pal : tagLogPalette absolute Pal;  // Trick! ;)
  dw   : LongWord;
BEGIN
   WITH Pal DO
     BEGIN
       palVersion:=$300;
       palNumEntries:=256;
       FOR dw := 0 TO 255 DO
         palPalEntry[dw] := TPaletteEntry(dw * $010101);
     END;
  BM.width := W;
  BM.Height := H;
  BM.Transparent := false;
  BM.pixelformat := pf8bit;
  BM.Palette := CreatePalette(_Pal);
END; {PrepareGrayBMP}



PROCEDURE TVideoImage.Convert24ToGray(BM24: TBitmap; BMGray: TBitmap);
{ - Convert a 24bit RGB bitmap into a 8bit grayscale image }
//type
//  tbytearray = ARRAY[0..16387] OF byte;
//  pbytearray = ^tbytearray;
//VAR
//  p24, p8  : pbytearray;
//  X, Y, X3 : integer;
BEGIN
  IF BM24.PixelFormat = pf8bit then
    begin
      BMGray.assign(BM24);
      exit;
    end;

  if (BM24.Width <> BMGray.Width) or (BM24.Height <> BMGray.Height) or (BMGray.PixelFormat <> pf8bit) then
    PrepareGrayBMP(BMGray, BM24.Width, bm24.Height);
  {  This is the do-it-yourself way of converting RGB to GrayScale:
  FOR Y := BM24.height-1 DOWNTO 0 do
    begin
      p24 := BM24.ScanLine[Y];
      p8  := BMGray.ScanLine[Y];
      X3 := 0;
      FOR X := 0 TO BMGray.Width-1 DO
        begin
          p8^[X] := (GrayConvB[p24^[X3]] + GrayConvG[p24^[X3+1]] + GrayConvR[p24^[X3+2]]) div 256;
          Inc(X3, 3);
        end;
    end;
   }
  BMGray.Canvas.Draw(0, 0, BM24);
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);
      ValueL_255[i] := Min(255, round(i *  298.082 / 255));
    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.I420_to_Gray8Bit(pData: pointer);
// http://en.wikipedia.org/wiki/YCbCr
var
  Y  : integer;
  pY : pbyte;
begin
  pY := pData;
  FOR Y := 0 TO fBitmapGray.Height-1 DO
    begin
      move(pY^, fBitmapGray.ScanLine[Y]^, fBitmapGray.Width);
      Inc(pY, fBitmapGray.Width);
    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.YUY2_to_Gray8Bit(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
  X, Y : integer;
  ps   : pbyte;
  pf   : ^byte;
begin
  pf := pData;
  FOR Y := 0 TO fBitmapGray.Height-1 DO
    BEGIN
      ps := fBitmapGray.ScanLine[Y];
      FOR X := 0 TO (fBitmapGray.Width div 2)-1 DO
        begin
          ps^ := pf^;
          Inc(ps);
          Inc(pf, 2);
          ps^ := pf^;
          Inc(ps);
          Inc(pf, 2);
        end;
    END;
end;



procedure TVideoImage.RGB_to_Gray8Bit(pData: pointer);
type
  TRGB       = ARRAY[0..5] OF byte;
  TPTRGB     = ^TRGB;
  TWordArr   = ARRAY[0..5759] OF word;
  TPTWordArr = ^TWordArr;
VAR
  X, Y : integer;
  p8   : TPTWordArr;
  pf   : TPTRGB;
begin
  pf := pData;

  FOR Y := fBitmapGray.height-1 DOWNTO 0 do
    begin
      p8  := fBitmapGray.ScanLine[Y];
      FOR X := 0 TO fBitmapGray.Width div 2-1 DO
        begin
          p8^[X] := ((GrayConvB[pf^[3]] + GrayConvG[pf^[4]] + GrayConvR[pf^[5]]) and $FF00) +
                     (GrayConvB[pf^[0]] + GrayConvG[pf^[1]] + GrayConvR[pf^[2]]) shr 8;
          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
            IF fGray8Bit
              then fDisplayCanvas.Draw(0, 0, fBitmapGray)
              else 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 begin
                           if fGray8Bit
                             then RGB_to_Gray8Bit(pData) // Okay, this is when Grayscale is much slower than color  :(
                             else move(pData^, FBitmap.scanline[fHeight-1]^, Size);
                         end
                         else Unknown := true;
                     END;
      FourCC_YUY2,
      FourCC_YUYV,
      FourCC_YUNV :  BEGIN
                       Unknown := (Size <> fWidth*fHeight*2);
                       IF Unknown then
                         begin
                           // Special treatment in case too much data is sent.
                           // e.g. Microsoft LifeCam Cinema delivers 1280*1080*2 Bytes
                           //      when 1280*720 was selected. The extra Bytes do not
                           //      contain video data. One third of the data (921600 Bytes)
                           //      is wasted by the driver!
                           if (Size > fWidth * fHeight * 2) then
                             Unknown := (Size div (2 * fWidth)) mod 4 <> 0;  // Width a multiple of 4? Maybe OK.
                         end;
                       IF not(Unknown) then
                         begin
                           IF fGray8Bit
                             then YUY2_to_Gray8Bit(pData)
                             else YUY2_to_RGB(pData);
                         end;
                     END;
      FourCC_MJPG :  BEGIN
                       try
                         MemStream.Clear;
                         MemStream.SetSize(Size);
                         MemStream.Position := 0;
                         MemStream.WriteBuffer(pData^, Size);
                         MemStream.Position := 0;
                         JPG.Grayscale := fGray8Bit;
                         JPG.LoadFromStream(MemStream);
                         if fGray8Bit
                           then FBitmapGray.Canvas.Draw(0, 0, JPG)
                           else FBitmap.Canvas.Draw(0, 0, JPG);
                       except
                         Unknown := true;
                       end;
                     END;
      FourCC_I420,
      FourCC_YV12,
      FourCC_IYUV : BEGIN
                      Unknown := (Size <> (fWidth*fHeight*3) div 2);
                      IF not Unknown then
                        IF fGray8Bit
                          then I420_to_Gray8Bit(pData)
                          else I420_to_RGB(pData);
                    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]);
  if fGray8Bit
    then BMP.Assign(fBitmapGray)
    else 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;
      PrepareGrayBMP(FBitmapGray, W, 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;
      PrepareGrayBMP(FBitmapGray, W, H);
    END;
END;


end.

VSample.pas

unit VSample;

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

  VSample.pas
  Class TVideoSample

About
  The TVideoSample class provides access to WebCams and similar Video-capture
  devices via DirectShow.
  It is based mainly on C++ examples from the Microsoft DirectX 9.0 SDK Update
  (Summer 2003): PlayCap and PlayCapMoniker. Comments found in those samples
  are copied into this Delphi code.

  Depends on the DirectX Header conversion files which could be found here:
  - http://www.progdigy.com
  - http://www.clootie.ru/delphi

History
  Version 1.22
  2012-07-08 (Fixed some memory leaks. List of supported video sizes/compressions corrected)
  Version 1.21
  06.05.2012  (ansichar instead of char)
  Version 1.2
  23.08.2009
  Version 1.1
  07.09.2008
  Version 1.03
  30.08.2008
  Version 1.02
  26.07.2008
  Version 1.01
  03.05.2008
  Version 1.0
  16.01.2006

Contact:
  michael@grizzlymotion.com

Copyright
  Portions created by Microsoft are Copyright (C) Microsoft Corporation.
  Original file names: PlayCap.cpp, PlayCapMoniker.cpp.
  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, SysUtils, Classes, ActiveX, Forms,
     {$ifdef DXErr} DXErr9, {$endif}
     DirectShow9;


{ $ define REGISTER_FILTERGRAPH}


CONST
  WM_GRAPHNOTIFY = WM_APP+1;
  WM_NewFrame    = WM_User+2;   // Used to inform application that a new video
                                // frame has arrived. Necessary only, if
                                // application hasn't defined a callback
                                // routine via TVideoSample.SetCallBack(...).


CONST  { Copied from OLE2.pas }
  {$EXTERNALSYM IID_IUnknown}
  IID_IUnknown: TGUID = (
    D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));



TYPE
  TPLAYSTATE      = (PS_Stopped,
                     {PS_Init,}
                     PS_Paused,
                     PS_Running);




// ---= Pseudo-Interface for Frame Grabber Callback Routines =-------------
// c.f. Delphi Help text "Delegating to a class-type property"
//
// ISampleGrabber.SetCallback verlangt als ersten Parameter ein "ISampleGrabberCB"
// Um f ein solches Interface Routinen zu deklarieren ist scheinbar das
// folgende, sonderbare Konstrukt n飆ig.
//
// ISampleGrabber.SetCallback needs an "ISampleGrabberCB" as first parameter.
// This is my attempt to build such a thing with Delphi.

TYPE
  TVideoSampleCallBack= procedure(pb : pbytearray; var Size: integer) of object;
  TSampleGrabberCBInt = interface(ISampleGrabberCB)
                          function  SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;
                          function  BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;
                        end;
  TSampleGrabberCBImpl= class
                          CallBack    : TVideoSampleCallBack;
                          function  SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;
                          function  BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;
                        end;
  TSampleGrabberCB =    class(TInterfacedObject, TSampleGrabberCBInt)
                          FSampleGrabberCB: TSampleGrabberCBImpl;
                          CallBack    : TVideoSampleCallBack;
                          property SampleGrabberCB: TSampleGrabberCBImpl read FSampleGrabberCB implements TSampleGrabberCBInt;
                        end;


  TFormatInfo   = RECORD
                    Width,
                    Height : integer;
                    SSize  : cardinal;
                    OIndex : integer;
                    mt     : TAMMediaType;
                    FourCC : ARRAY[0..3] OF ansichar;  // ansichar, because in Delphi 2009 char is something different ;)
                  END;

  TVideoSample  = class(TObject)
                    private
                      ghApp             : HWND;
                      pIVideoWindow     : IVideoWindow;
                      pIMediaControl    : IMediaControl;
                      pIMediaEventEx    : IMediaEventEx;
                      pIGraphBuilder    : IGraphBuilder;
                      pICapGraphBuild2  : ICaptureGraphBuilder2;
                      g_psCurrent       : TPLAYSTATE;

                      pIAMStreamConfig  : IAMStreamConfig;
                      piBFSampleGrabber : IBaseFilter;
                      pIAMVideoProcAmp  : IAMVideoProcAmp;
                      pIBFNullRenderer  : IBaseFilter;

                      pIKsPropertySet   : IKsPropertySet;
                      pISampleGrabber   : ISampleGrabber;
                      pIBFVideoSource   : IBaseFilter;

                      {$ifdef REGISTER_FILTERGRAPH}
                        g_dwGraphRegister :DWORD;
                      {$endif}

                      SGrabberCB  : TSampleGrabberCB;
                      _SGrabberCB : TSampleGrabberCBInt;
                      fVisible    : boolean;
                      CallBack    : TVideoSampleCallBack;
                      FormatArr   : ARRAY OF TFormatInfo;
                      FUNCTION    GetInterfaces(ForceRGB: boolean; WhichMethodToCallback: integer): HRESULT;
                      FUNCTION    SetupVideoWindow(): HRESULT;
                      FUNCTION    ConnectToCaptureDevice(DeviceName: string; VAR DeviceSelected: string; VAR ppIBFVideoSource: IBaseFilter): HRESULT;
                      FUNCTION    RestartVideoEx(Visible: boolean):HRESULT;
                      FUNCTION    ShowPropertyDialogEx(const IBF: IUnknown; FilterName:  PWideChar): HResult;
                      FUNCTION    LoadListOfResolution: HResult;
                      procedure   DeleteBelow(const IBF: IBaseFilter);
                      procedure   CloseInterfaces;
                    public
                      {$ifdef DXErr}
                        DXErrString: string;  // for debugging
                      {$endif}
                      constructor Create(VideoCanvasHandle: THandle; ForceRGB: boolean; WhichMethodToCallback: integer; VAR HR: HResult);
                      destructor  Destroy; override;
                      property    PlayState: TPLAYSTATE read g_psCurrent;
                      procedure   ResizeVideoWindow();
                      FUNCTION    RestartVideo:HRESULT;
                      FUNCTION    StartVideo(CaptureDeviceName: string; Visible: boolean; VAR DeviceSelected: string):HRESULT;
                      FUNCTION    PauseVideo: HResult;  // Pause running video
                      FUNCTION    ResumeVideo: HResult; // Re-start paused video
                      FUNCTION    StopVideo: HResult;
                      function    GetImageBuffer(VAR pb : pbytearray; var Size: integer): HResult;
                      FUNCTION    SetPreviewState(nShow: boolean): HRESULT;
                      FUNCTION    ShowPropertyDialog: HResult;
                      FUNCTION    ShowPropertyDialog_CaptureStream: HResult;
                      FUNCTION    GetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;
                                                    VAR pMin, pMax,
                                                        pSteppingDelta,
                                                        pDefault       : longint;
                                                    VAR pCapsFlags     : TVideoProcAmpFlags;
                                                    VAR pActual        : longint): HResult;
                      FUNCTION    SetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;
                                                        pCapsFlags     : TVideoProcAmpFlags;
                                                        pActual        : longint): HResult;
                      PROCEDURE   GetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; VAR AcPerCent: integer);
                      PROCEDURE   SetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; AcPerCent: integer);
                      PROCEDURE   GetVideoSize(VAR Width, height: integer);
                      FUNCTION    ShowVfWCaptureDlg: HResult;
                      FUNCTION    GetStreamInfo(VAR Width, Height: integer; VAR FourCC: dword): HResult;
                      FUNCTION    GetExProp(    guidPropSet   : TGuiD;
                                                dwPropID      : TAMPropertyPin;
                                                pInstanceData : pointer;
                                                cbInstanceData: DWORD;
                                            out pPropData;
                                                cbPropData    : DWORD;
                                            out pcbReturned   : DWORD): HResult;
                      FUNCTION    SetExProp(   guidPropSet : TGuiD;
                                                  dwPropID : TAMPropertyPin;
                                            pInstanceData  : pointer;
                                            cbInstanceData : DWORD;
                                                 pPropData : pointer;
                                                cbPropData : DWORD): HResult;
                      FUNCTION    GetCaptureIAMStreamConfig(VAR pSC: IAMStreamConfig): HResult;
                      PROCEDURE   DeleteCaptureGraph;
                      PROCEDURE   SetCallBack(CB: TVideoSampleCallBack);
                      FUNCTION    GetPlayState: TPlayState;  // Deprecated
                      PROCEDURE   GetListOfVideoSizes(VidSize: TStringList);
                      FUNCTION    SetVideoSizeByListIndex(ListIndex: integer): HResult;
                      {$ifdef REGISTER_FILTERGRAPH}
                        FUNCTION AddGraphToRot(pUnkGraph: IUnknown; VAR pdwRegister: DWORD):HRESULT;
                        procedure RemoveGraphFromRot(pdwRegister: dword);
                      {$endif}
                  END;



FUNCTION TGUIDEqual(const TG1, TG2 : TGUID): boolean;

FUNCTION GetCaptureDeviceList(VAR SL: TStringList): HResult;



implementation



FUNCTION TGUIDEqual(const TG1, TG2 : TGUID): boolean;
BEGIN
  Result := CompareMem(@TG1, @TG2, SizeOf(TGUID));
END; {TGUIDEqual}


{ Get a list of all capture devices installed }
FUNCTION GetCaptureDeviceList(VAR SL: TStringList): HResult;
VAR
  pDevEnum     : ICreateDevEnum;
  pClassEnum   : IEnumMoniker;
  st           : string;

          // Okay, in the original C code from the microsoft samples this
          // is not a subroutine.
          // I decided to use it as a subroutine, because Delphi won't let
          // me free pMoniker or pPropertyBag myself. ( ":= nil" )
          // Hopefully ending the subroutine will clean up all instances of
          // these interfaces automatically...
          FUNCTION GetNextDeviceName(VAR Name: string): boolean;
          VAR
            pMoniker     : IMoniker;
            pPropertyBag : IPropertyBag;
            v            : OLEvariant;
            cFetched     : ulong;
          BEGIN
            Result := false;
            Name   := '';
            pMoniker := nil;
            IF (S_OK = (pClassEnum.Next (1, pMoniker, @cFetched))) THEN
              BEGIN
                pPropertyBag := nil;
                if S_OK = pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag) then
                  begin
                    if S_OK = pPropertyBag.Read('FriendlyName', v, nil) then
                      begin
                        Name := v;
                        Result := true;
                      end;
                  end;
              END;
          END; {GetNextDeviceName}

begin
  Result := S_FALSE;
  if not(assigned(SL)) then
    SL := TStringlist.Create;
  try
    SL.Clear;
  except
    exit;
  end;

  // Create the system device enumerator
  Result := CoCreateInstance (CLSID_SystemDeviceEnum,
                              nil,
                              CLSCTX_INPROC_SERVER,
                              IID_ICreateDevEnum,
                              pDevEnum);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      // Couldn't create system enumerator!
      exit;
    end;

  // Create an enumerator for the video capture devices
  pClassEnum := nil;

  Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      // Couldn't create class enumerator!
      exit;
    end;

  // If there are no enumerators for the requested type, then
  // CreateClassEnumerator will succeed, but pClassEnum will be nil.
  if (pClassEnum = nil) then
    begin
       // No video capture device was detected.
       exit;
    end;

  WHILE GetNextDeviceName(st) DO
    SL.Add(st);
end; {GetCaptureDeviceList}





// ---= Sample Grabber callback routines =------------------------------------


// In routine TVideoSample.GetInterfaces(..) the callback routine is defined
// with pISampleGrabber.SetCallback(..,..). If the second parameter in that
// call is 1, then the routine below is called during a callback.
// Otherwise, if the parameter is 0, callback routine BufferCB would be called.
function TSampleGrabberCBImpl.SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;
var
  BufferLen: integer;
  ppBuffer : pbyte;
begin
  BufferLen := pSample.GetSize;
  if BufferLen > 0 then
    begin
      pSample.GetPointer(ppBuffer); {*}
      if @CallBack = nil
        then SendMessage(Application.Mainform.handle, WM_NewFrame, BufferLen, integer(ppBuffer))
        else Callback(pbytearray(ppBuffer), BufferLen);
    end;
  Result := 0;
end;

{*}
// Nebenbei bemerkt: Beim Debuggen fiel mir auf, da?die von mir verwendete
// WebCam scheinbar einen Triple-Buffer f die Bilddaten verwendet. Die oben
// von pSample.GetPointer(ppBuffer) zurkgelieferte Adresse wiederholt sich
// in einem 3-er Zyklus. Wenn das ein Feature von DirectShow ist und nicht
// von der Kamera-Steuersoftware, dann k霵nte man selbst auf Double- oder
// Triplebuffering verzichten. 


// In routine TVideoSample.GetInterfaces(..) the callback routine is defined
// with pISampleGrabber.SetCallback(..,..). If the second parameter in that
// call is 0, then the routine below is called during a callback.
// Otherwise, if the parameter is 1, callback routine SampleCB would be called.
function TSampleGrabberCBImpl.BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;
begin
  if BufferLen > 0 then
    begin
      if @CallBack = nil
        then SendMessage(Application.Mainform.handle, WM_NewFrame, BufferLen, integer(pBuffer))
        else Callback(pbytearray(pBuffer), BufferLen);
    end;
  Result := 0;
end;


// ---= End of Sample Grabber callback routines =---------------------------






constructor TVideoSample.Create(VideoCanvasHandle: THandle; ForceRGB: boolean; WhichMethodToCallback: integer; VAR HR: HResult);
begin
  ghApp             := 0;

  pIVideoWindow     := nil;
  pIMediaControl    := nil;
  pIMediaEventEx    := nil;
  pIGraphBuilder    := nil;
  pICapGraphBuild2  := nil;
  g_pSCurrent       := PS_Stopped;

  pIAMStreamConfig  := nil;
  piBFSampleGrabber := nil;
  pIAMVideoProcAmp  := nil;

  pIKsPropertySet   := nil;

  {$ifdef REGISTER_FILTERGRAPH}
  g_dwGraphRegister:=0;
  {$endif}

  pISampleGrabber   := nil;
  pIBFVideoSource   := nil;
  SGrabberCB        := nil;
  _SGrabberCB       := nil;
  pIBFNullRenderer  := nil;

  CallBack          := nil;

  inherited create;

  ghApp             := VideoCanvasHandle;

  HR                := GetInterfaces(ForceRGB, WhichMethodToCallback);
end;




FUNCTION TVideoSample.GetInterfaces(ForceRGB: boolean; WhichMethodToCallback: integer): HRESULT;
VAR
  MT: _AMMediaType;
BEGIN
  //--- Create the filter graph
  Result := CoCreateInstance(CLSID_FilterGraph,
                             nil,
                             CLSCTX_INPROC,
                             IID_IGraphBuilder,
                             pIGraphBuilder);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
   exit;

  //--- Create Sample grabber
  Result := CoCreateInstance(CLSID_SampleGrabber,
                             nil,
                             CLSCTX_INPROC_SERVER,
                             IBaseFilter,
                             piBFSampleGrabber);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  Result := CoCreateInstance(CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER,
                             IID_IBaseFilter, pIBFNullRenderer);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  Result := piBFSampleGrabber.QueryInterface(IID_ISampleGrabber, pISampleGrabber);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  pISampleGrabber.SetBufferSamples(false);  // No buffering required in this demo

  //--- Force 24bit color depth. (RGB24 erzwingen)
  IF ForceRGB then
    begin
      FillChar(MT, sizeOf(MT), #0);
      MT.majortype := MediaType_Video;
      MT.subtype := MediaSubType_RGB24;
      Result := pISampleGrabber.SetMediaType(MT);
      {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
      if (FAILED(Result)) then
        exit;
    end;

  //--- Prepare Sample-Grabber Callback Object----
  if not assigned(SGrabberCB) then
    begin
      SGrabberCB := TSampleGrabberCB.Create;
      TSampleGrabberCB(SGrabberCB).FSampleGrabberCB := TSampleGrabberCBImpl.Create;
      _SGrabberCB := TSampleGrabberCB(SGrabberCB);
         // Should this be _SGrabberCB := SGrabberCB as TSampleGrabberCB ?????!!!!!
         // Compare discussion on
         // http://delphi.newswhat.com/geoxml/forumgetthread?groupname=borland.public.delphi.oodesign&messageid=44f84705@newsgroups.borland.com&displaymode=all
         // However, link has been lost in the web  :(
    end;

  pISampleGrabber.SetCallback(ISampleGrabberCB(_SGrabberCB), WhichMethodToCallback);
         // WhichMethodToCallback=0: SampleGrabber calls SampleCB with the original media sample
         // WhichMethodToCallback=1: SampleGrabber calls BufferCB with a copy of the media sample

  //--- Create the capture graph builder
  Result := CoCreateInstance(CLSID_CaptureGraphBuilder2,
                             nil,
                             CLSCTX_INPROC,
                             IID_ICaptureGraphBuilder2,
                             pICapGraphBuild2);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  // Obtain interfaces for media control and Video Window
  Result := pIGraphBuilder.QueryInterface(IID_IMediaControl, pIMediaControl);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  Result := pIGraphBuilder.QueryInterface(IID_IVideoWindow, pIVideoWindow);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  Result := pIGraphBuilder.QueryInterface(IID_IMediaEvent, pIMediaEventEx);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    exit;

  //--- Set the window handle used to process graph events
  Result := pIMediaEventEx.SetNotifyWindow(OAHWND(ghApp), WM_GRAPHNOTIFY, 0);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
end;




FUNCTION TVideoSample.ConnectToCaptureDevice(DeviceName: string; VAR DeviceSelected: string; VAR ppIBFVideoSource: IBaseFilter): HRESULT;
VAR
  pDevEnum   : ICreateDevEnum;
  pClassEnum : IEnumMoniker;
  Index      : integer;
  Found      : boolean;


          // see also: http://msdn.microsoft.com/en-us/library/ms787619.aspx
          FUNCTION CheckNextDeviceName(Name: string; VAR Found: boolean): HResult;
          VAR
            pMoniker     : IMoniker;
            pPropertyBag : IPropertyBag;
            v            : OLEvariant;
            cFetched     : ulong;
            MonName      : string;
          BEGIN
            Found  := false;
            pMoniker := nil;
            // Note that if the Next() call succeeds but there are no monikers,
            // it will return S_FALSE (which is not a failure).  Therefore, we
            // check that the return code is S_OK instead of using SUCCEEDED() macro.
            Result := pClassEnum.Next(1, pMoniker, @cFetched);
            IF (S_OK = Result) THEN
              BEGIN
                Inc(Index);
                pPropertyBag := nil;
                Result := pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag);
                if S_OK = Result then
                  begin
                    Result := pPropertyBag.Read('FriendlyName', v, nil);   // BTW: Other useful parameter: 'DevicePath'
                    if S_OK = Result then
                      begin
                        MonName := v;
                        if (Uppercase(Trim(MonName)) = UpperCase(Trim(Name))) or
                          ((Length(Name)=2) and (Name[1]='#') and (ord(Name[2])-48=Index)) then
                          begin
                            DeviceSelected := Trim(MonName);
                            Result := pMoniker.BindToObject(nil, nil, IID_IBaseFilter, ppIBFVideoSource);
                            Found := Result = S_OK;
                          end;
                      end;
                  end;
              END;
          END; {CheckNextDeviceName}



BEGIN
  DeviceSelected := '';
  Index := 0;
  DeviceName := Trim(DeviceName);
  IF DeviceName = '' then
    DeviceName := '#1'; // Default: First device (Erstes Ger酹)

  if @ppIBFVideoSource = nil then
    begin
      result := E_POINTER;
      exit;
    end;

  // Create the system device enumerator
  Result := CoCreateInstance(CLSID_SystemDeviceEnum,
                             nil,
                             CLSCTX_INPROC,
                             IID_ICreateDevEnum,
                             pDevEnum);
  if (FAILED(Result)) then
    begin
      // Couldn't create system enumerator!
      exit;
    end;

  // Create an enumerator for the video capture devices
  pClassEnum := nil;

  Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      // Couldn't create class enumerator!
      exit;
    end;

  // If there are no enumerators for the requested type, then
  // CreateClassEnumerator will succeed, but pClassEnum will be nil.
  if (pClassEnum = nil) then
    begin
      // No video capture device was detected.
      result := E_FAIL;
      exit;
    end;

  Found := false;
  REPEAT
    try
      Result := CheckNextDeviceName(DeviceName, Found)
    except
      IF Result = 0 then
        result := E_FAIL;
    end;
  UNTIL Found or (Result <> S_OK);
end; {ConnectToCaptureDevice}





procedure TVideoSample.ResizeVideoWindow();
var
  rc : TRect;
begin
  // Resize the video preview window to match owner window size
  if (pIVideoWindow) <> nil then
    begin
        // Make the preview video fill our window
      GetClientRect(ghApp, rc);
      pIVideoWindow.SetWindowPosition(0, 0, rc.right, rc.bottom);
    end;
end; {ResizeVideoWindow}




FUNCTION TVideoSample.SetupVideoWindow(): HRESULT;
BEGIN
  // Set the video window to be a child of the main window
  Result := pIVideoWindow.put_Owner(OAHWND(ghApp));
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      exit;
    end;

  // Set video window style
  Result := pIVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPCHILDREN);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      exit;
    end;

  // Use helper function to position video window in client rect
  // of main application window
  ResizeVideoWindow();

  // Make the video window visible, now that it is properly positioned
  Result := pIVideoWindow.put_Visible(TRUE);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if (FAILED(Result)) then
    begin
      exit;
    end;

end; {SetupVideoWindow}




FUNCTION TVideoSample.RestartVideoEx(Visible: boolean):HRESULT;
VAR
  pCut, pTyp : pGuiD;
  {
  pAMVidControl: IAMVideoControl;
  pPin         : IPin;
  }
BEGIN
  if (pIAMVideoProcAmp = nil) then
    if not(S_OK = pIBFVideoSource.QueryInterface(IID_IAMVideoProcAmp, pIAMVideoProcAmp)) then
      pIAMVideoProcAmp := nil;

   if (pIKsPropertySet = nil) then
    if not(S_OK = pIBFVideoSource.QueryInterface(IID_IKsPropertySet, pIKsPropertySet)) then
      pIKsPropertySet := nil;


    // Add Capture filter to our graph.
    Result := pIGraphBuilder.AddFilter(pIBFVideoSource, Widestring('Video Capture'));
    if (FAILED(Result)) then
      begin
        // Couldn''t add the capture filter to the graph!
        exit;
      end;

    Result := pIGraphBuilder.AddFilter(piBFSampleGrabber, Widestring('Sample Grabber'));
    if (FAILED(Result)) then
      EXIT;

    if not(Visible) then
      begin
        Result := pIGraphBuilder.AddFilter(pIBFNullRenderer, WideString('Null Renderer'));
        if (FAILED(Result)) then
          EXIT;
      end;

    // Render the preview pin on the video capture filter
    // Use this instead of pIGraphBuilder->RenderFile
    New(pCut);
    New(pTyp);
    //pCut^ := PIN_CATEGORY_PREVIEW;
    pCut^ := PIN_CATEGORY_CAPTURE;
    pTyp^ := MEDIATYPE_Video;
    try
      if Visible
        then Result := pICapGraphBuild2.RenderStream (pCut, pTyp,
                                    //Addr(PIN_CATEGORY_PREVIEW), Addr(MEDIATYPE_Video),
                                    pIBFVideoSource, piBFSampleGrabber, nil)

        else Result := pICapGraphBuild2.RenderStream (pCut, pTyp,
                                    //Addr(PIN_CATEGORY_PREVIEW), Addr(MEDIATYPE_Video),
                                    pIBFVideoSource, piBFSampleGrabber, pIBFNullRenderer);
    except
      Result := -1;
    end;
    if (FAILED(Result)) then
      begin
        // Couldn''t render the video capture stream.
        // The capture device may already be in use by another application.
        Dispose(pTyp);
        Dispose(pCut);
        exit;
      end;


    // Set video window style and position
    if Visible then
      begin
        Result := SetupVideoWindow();
        if (FAILED(Result)) then
          begin
            // Couldn't initialize video window!
            Dispose(pTyp);
            Dispose(pCut);
            exit;
          end;
      end;

{$ifdef REGISTER_FILTERGRAPH}
    // Add our graph to the running object table, which will allow
    // the GraphEdit application to "spy" on our graph
    try
      hr := AddGraphToRot(IUnknown(pIGraphBuilder), g_dwGraphRegister);
    except
      // Failed to register filter graph with ROT!
    end;
    if (FAILED(Result)) then
      begin
        // Failed to register filter graph with ROT!
        g_dwGraphRegister := 0;
      end;
{$endif}

  //  if Visible then
      begin
        // Start previewing video data
        Result := pIMediaControl.Run();
        if (FAILED(Result)) then
          begin
            // Couldn't run the graph!
          end;
      end;

    // Remember current state
    g_psCurrent := PS_Running;

    (*
    // !!!!!!!!!
    // Prepare getting images in higher resolution than video stream
    // See DirectX9 Help "Capturing an Image From a Still Image Pin"
    // Not working yet.....
    pAMVidControl := nil;
    Result := pIBFVideoSource.QueryInterface(IID_IAMVideoControl, pAMVidControl);
    IF succeeded(Result) then
      begin
        pTyp := 0;
        pPin := nil;
        Result := pICapGraphBuild2.FindPin(pIBFVideoSource, PINDIR_OUTPUT, PIN_CATEGORY_STILL, pTyp^, false, 0, pPin);
        if (SUCCEEDED(Result)) then
          Result := pAMVidControl.SetMode(pPin, VideoControlFlag_Trigger);
      end;
    *)
  Dispose(pTyp);
  Dispose(pCut);
end; {RestartVideoEx}


FUNCTION TVideoSample.RestartVideo: HRESULT;
BEGIN
  Result := RestartVideoEx(FVisible);
END; {RestartVideo}


FUNCTION TVideoSample.StartVideo(CaptureDeviceName: string; Visible: boolean; VAR DeviceSelected: string):HRESULT;
BEGIN
  pIBFVideoSource := nil;
  FVisible   := Visible;

   // Attach the filter graph to the capture graph
  Result := pICapGraphBuild2.SetFiltergraph(pIGraphBuilder);
  if (FAILED(Result)) then
    begin
      // Failed to set capture filter graph!
      exit;
    end;

  // Use the system device enumerator and class enumerator to find
  // a video capture/preview device, such as a desktop USB video camera.
  Result := ConnectToCaptureDevice(CaptureDeviceName, DeviceSelected, pIBFVideoSource);
  if (FAILED(Result)) then
    begin
      exit;
    end;

  LoadListOfResolution;
  Result := RestartVideo;
end;



FUNCTION TVideoSample.PauseVideo: HResult;
BEGIN
  IF g_psCurrent = PS_Paused
    then begin
      Result := S_OK;
      EXIT;
    end;
  IF g_psCurrent = PS_Running then
    begin
      Result := pIMediaControl.Pause;
      if Succeeded(Result) then
        g_psCurrent := PS_Paused;
    end
    else Result := S_FALSE;
END;


FUNCTION TVideoSample.ResumeVideo: HResult;
BEGIN
  IF g_psCurrent = PS_Running then
    begin
      Result := S_OK;
      EXIT;
    end;
  IF g_psCurrent = PS_Paused then
    begin
      Result := pIMediaControl.Run;
      if Succeeded(Result) then
        g_psCurrent := PS_Running;
    end
    else Result := S_FALSE;
END;



FUNCTION TVideoSample.StopVideo: HResult;
BEGIN
  // Stop previewing video data
  Result := pIMediaControl.StopWhenReady();
  g_psCurrent := PS_Stopped;
  SetLength(FormatArr, 0);
END;



// Delete filter and pins bottom-up...
PROCEDURE TVideoSample.DeleteBelow(const IBF: IBaseFilter);
VAR
  hr         : HResult;
  pins       : IEnumPins;
  pIPinFrom,
  pIPinTo    : IPin;
  fetched    : ulong;
  pInfo      : _PinInfo;
BEGIN
  pIPinFrom := nil;
  pIPinTo   := nil;
  hr := IBF.EnumPins(pins);
  WHILE (hr = NoError) DO
    BEGIN
      hr := pins.Next(1, pIPinFrom, @fetched);
      if (hr = S_OK) and (pIPinFrom <> nil) then
        BEGIN
          hr := pIPinFrom.ConnectedTo(pIPinTo);
          if (hr = S_OK) and (pIPinTo <> nil) then
            BEGIN
              hr := pIPinTo.QueryPinInfo(pInfo);
              if (hr = NoError) then
                BEGIN
                  if pinfo.dir = PINDIR_INPUT then
                    BEGIN
                      DeleteBelow(pInfo.pFilter);
                      pIGraphBuilder.Disconnect(pIPinTo);
                      pIGraphBuilder.Disconnect(pIPinFrom);
                      pIGraphBuilder.RemoveFilter(pInfo.pFilter);
                    ENd;
                END;
            END;
        END;
    END;
END; {DeleteBelow}



PROCEDURE TVideoSample.DeleteCaptureGraph;
BEGIN
  pIBFVideoSource.Stop;
  DeleteBelow(pIBFVideoSource);
END;



procedure TVideoSample.CloseInterfaces;
begin
  if (pISampleGrabber <> nil) then
    pISampleGrabber.SetCallback(nil, 1);

  // Stop previewing data
  if (pIMediaControl <> nil) then
    pIMediaControl.StopWhenReady();

  g_psCurrent := PS_Stopped;

  // Stop receiving events
  if (pIMediaEventEx <> nil) then
    pIMediaEventEx.SetNotifyWindow(OAHWND(nil), WM_GRAPHNOTIFY, 0);

  // Relinquish ownership (IMPORTANT!) of the video window.
  // Failing to call put_Owner can lead to assert failures within
  // the video renderer, as it still assumes that it has a valid
  // parent window.
  if (pIVideoWindow<>nil) then
    begin
      pIVideoWindow.put_Visible(FALSE);
      pIVideoWindow.put_Owner(OAHWND(nil));
    end;

  {$ifdef REGISTER_FILTERGRAPH}
    // Remove filter graph from the running object table
    if (g_dwGraphRegister<>nil) then
      RemoveGraphFromRot(g_dwGraphRegister);
  {$endif}
end;



function TVideoSample.GetImageBuffer(VAR pb : pbytearray; var Size: integer): HResult;
VAR
  NewSize : integer;
begin
  Result := pISampleGrabber.GetCurrentBuffer(NewSize, nil);
  if (Result <> S_OK) then
    EXIT;
  if (pb <> nil) then
    begin
      if Size <> NewSize then
        begin
          try
            FreeMem(pb, Size);
          except
          end;
          pb := nil;
          Size := 0;
        end;
    end;
  Size := NewSize;
  IF Result = S_OK THEN
    BEGIN
      if pb = nil then
        GetMem(pb, NewSize);
      Result := pISampleGrabber.GetCurrentBuffer(NewSize, pb);
    END;
end;



FUNCTION TVideoSample.SetPreviewState(nShow: boolean): HRESULT;
BEGIN
  Result := S_OK;

  // If the media control interface isn't ready, don't call it
  if (pIMediaControl = nil) then
    exit;

  if (nShow) then
    begin
      if (g_psCurrent <> PS_Running) then
        begin
          // Start previewing video data
          Result := pIMediaControl.Run();
          g_psCurrent := PS_Running;
        end;
    end
    else begin
        // Stop previewing video data
        // Result := pIMediaControl.StopWhenReady(); // Program may get stucked here!
        Result := pIMediaControl.Stop;
        g_psCurrent := PS_Stopped;
    end;
end;




FUNCTION TVideoSample.ShowPropertyDialogEx(const IBF: IUnknown; FilterName: PWideChar): HResult;
VAR
  pProp      : ISpecifyPropertyPages;
  c          : tagCAUUID;
begin
 pProp  := nil;
 Result := IBF.QueryInterface(ISpecifyPropertyPages, pProp);
 if Result = S_OK then
   begin
     Result := pProp.GetPages(c);
     if (Result = S_OK) and (c.cElems > 0) then
       begin
         Result := OleCreatePropertyFrame(ghApp, 0, 0, FilterName, 1, @IBF, c.cElems, c.pElems, 0, 0, nil);
         CoTaskMemFree(c.pElems);
       end;
   end;
end;





FUNCTION TVideoSample.ShowPropertyDialog: HResult;
VAR
  FilterInfo : FILTER_INFO;
begin
  Result := pIBFVideoSource.QueryFilterInfo(FilterInfo);
  if not(Failed(Result)) then
    Result := ShowPropertyDialogEx(pIBFVideoSource, FilterInfo.achName);
end;



FUNCTION TVideoSample.GetCaptureIAMStreamConfig(VAR pSC: IAMStreamConfig): HResult;
BEGIN
  pSC := nil;
  Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture,
                                           @MEDIATYPE_Video,
                                           pIBFVideoSource,
                                           IID_IAMStreamConfig, pSC);

END;



FUNCTION TVideoSample.ShowPropertyDialog_CaptureStream: HResult;
VAR
  pSC       : IAMStreamConfig;
BEGIN
  pIMediaControl.Stop;
  Result := GetCaptureIAMStreamConfig(pSC);
  if Result = S_OK then
    Result := ShowPropertyDialogEx(pSC, '');
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  pIMediaControl.Run;
END;


(*
PROCEDURE DumpMediaType(const mt: TAMMediaType; VAR Dump: TStringList);
begin
  Dump.Add('================');
  Dump.Add('MajorType=' + GuidToString(mt.majortype));
  Dump.Add('SubType=' +   GuidToString(mt.subtype));
  Dump.Add('FixedSizeSamples=' + BoolToStr(mt.bFixedSizeSamples));
  Dump.Add('TemporalCompression=' + BoolToStr(mt.bTemporalCompression));
  Dump.Add('lSampleSize=' + IntToStr(mt.lSampleSize));
  Dump.Add('FormatType='  + GuidToString(mt.formattype));
  //Dump.Add('pUnk='  +   GuidToString(mt.pUnk));
  Dump.Add('cbFormat=' + IntToHex(mt.cbFormat, 8));
  Dump.Add('pbFormat=' + IntToHex(integer(mt.pbFormat), 4));
end;
*)

// Fills "FormatArr" with list of all supported video formats (resolution, compression etc...)
FUNCTION TVideoSample.LoadListOfResolution: HResult;
VAR
  pSC                   : IAMStreamConfig;
  VideoStreamConfigCaps : TVideoStreamConfigCaps;
  p                     : ^TVideoStreamConfigCaps;
  ppmt                  : PAMMediaType;
  i, j,
  piCount,
  piSize                : integer;
  Swap                  : boolean;
  FM                    : TFormatInfo;
BEGIN
  SetLength(FormatArr, 0);
  Result := GetCaptureIAMStreamConfig(pSC);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  IF Result = S_OK then
    Result := pSC.GetNumberOfCapabilities(piCount, piSize);
  j := 0;
  if Result = S_OK then
    begin
      FOR i := 0 TO piCount-1 DO
        begin
          p := @VideoStreamConfigCaps;
          Result := pSC.GetStreamCaps(i, ppmt, p^);
          IF Succeeded(Result) then
            IF not(IsEqualGUID(ppmt^.formattype, KSDATAFORMAT_SPECIFIER_VIDEOINFO2)) then // Only first part of info is relevant
              begin
                SetLength(FormatArr, j+1);
                FormatArr[j].OIndex := i;
                FormatArr[j].Width  := p^.InputSize.cx;
                FormatArr[j].Height := p^.InputSize.cy;
                FormatArr[j].mt     := ppmt^;
                FormatArr[j].SSize  := ppmt^.lSampleSize;
                IF TGuIDEqual(MEDIASUBTYPE_RGB24, ppmt^.Subtype)
                  then FormatArr[j].FourCC := 'RGB '
                  else move(ppmt^.Subtype.D1, FormatArr[j].FourCC, 4);
                Inc(j);
              end;
        end;
    end;

  // Simple sort by width and height
  IF j > 1 then
    begin
      REPEAT
        Swap := false;
        FOR i := 0 TO j-2 DO
          IF (FormatArr[i].Width > FormatArr[i+1].Width) or
             (((FormatArr[i].Width = FormatArr[i+1].Width)) and ((FormatArr[i].Height > FormatArr[i+1].Height)))
          then
            begin
              Swap := true;
              FM := FormatArr[i];
              FormatArr[i] := FormatArr[i+1];
              FormatArr[i+1] := FM;
            end;
      UNTIL not(Swap);
    end;
END;



FUNCTION TVideoSample.SetVideoSizeByListIndex(ListIndex: integer): HResult;
// Sets one of the supported video stream sizes listed in "FormatArr".
// ListIndex is the index to one of the sizes from the stringlist received
// from "GetListOfVideoSizes".
VAR
  pSC                   : IAMStreamConfig;
BEGIN
  IF (ListIndex < 0) or (ListIndex >= Length(FormatArr)) then
    begin
      Result := S_FALSE;
      exit;
    end;

  pIMediaControl.Stop;

  Result := GetCaptureIAMStreamConfig(pSC);

  IF Succeeded(Result) then
    //Result := pSC.SetFormat(FormatArr[ListIndex].mt);
    // Sometimes delivers VFW_E_INVALIDMEDIATYPE, even for formats returned by GetStreamCaps

  pIMediaControl.Run;
END;



FUNCTION TVideoSample.GetStreamInfo(VAR Width, Height: integer; VAR FourCC: dword): HResult;
VAR
  pSC   : IAMStreamConfig;
  ppmt  : PAMMediaType;
  pmt   : _AMMediaType;

  VI    : VideoInfo;
  VIH   : VideoInfoHeader;
BEGIN
  Width := 0;
  Height := 0;
  //pIMediaControl.Stop; // Crash with FakeWebCam. Thanks to "Zacherl" from Delphi-Praxis http://www.delphipraxis.net/1165063-post16.html
  pIBFVideoSource.Stop;  // nicht zwingend n飆ig

  Result := GetCaptureIAMStreamConfig(pSC);
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if Result = S_OK then
    begin
      Result := pSC.GetFormat(ppmt);
      pmt := ppmt^;
      if  TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) then
        begin
          FillChar(VI, SizeOf(VI), #0);
          VIH := VideoInfoHeader(ppmt^.pbFormat^);
          move(VIH, VI, SizeOf(VIH));
          Width := VI.bmiHeader.biWidth;
          Height := Abs(VI.bmiHeader.biHeight);
          FourCC := VI.bmiHeader.biCompression;
        end;
    end;
  pIBFVideoSource.Run(0);// nicht zwingend n飆ig
  //pIMediaControl.Run;  // If we don't stop it, we don't need to start it...
END;






// See also: http://msdn.microsoft.com/en-us/library/ms784400(VS.85).aspx
FUNCTION TVideoSample.GetVideoPropAmpEx(    Prop                     : TVideoProcAmpProperty;
                                        VAR pMin, pMax,
                                            pSteppingDelta, pDefault : longint;
                                        VAR pCapsFlags               : TVideoProcAmpFlags;
                                        VAR pActual                  : longint): HResult;
BEGIN
  Result := S_False;
  if pIAMVideoProcAmp = nil then
    exit;
  Result := pIAMVideoProcAmp.GetRange(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags);
  pActual := pDefault;
  IF Result = S_OK then
    Result := pIAMVideoProcAmp.Get(Prop, pActual, pCapsFlags)
END;



FUNCTION TVideoSample.SetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;
                                            pCapsFlags     : TVideoProcAmpFlags;
                                            pActual        : longint): HResult;
BEGIN
  Result := S_False;
  if pIAMVideoProcAmp = nil then
    exit;
  Result := pIAMVideoProcAmp.Set_(Prop, pActual, pCapsFlags)
END;



PROCEDURE TVideoSample.GetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; VAR AcPerCent: integer);
VAR
  pMin, pMax,
  pSteppingDelta,
  pDefault       : longint;
  pCapsFlags     : TVideoProcAmpFlags;
  pActual        : longint;
BEGIN
  IF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OK
    THEN BEGIN
      AcPerCent := round(100 * (pActual-pMin)/(pMax-pMin));
    END
    ELSE AcPerCent := -1;
END;



PROCEDURE TVideoSample.SetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; AcPerCent: integer);
VAR
  pMin, pMax,
  pSteppingDelta,
  pDefault        : longint;
  pCapsFlags      : TVideoProcAmpFlags;
  pActual         : longint;
  d               : double;
BEGIN
  IF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OK
    THEN BEGIN
      IF (AcPercent < 0) or (AcPercent > 100) then
        begin
          pActual := pDefault;
        end
        else begin
          d := (pMax-pMin)/100*AcPercent;
          pActual := round(d);
          pActual := (pActual div pSteppingDelta) * pSteppingDelta;
          pActual := pActual + pMin;
        end;
      pIAMVideoProcAmp.Set_(Prop, pActual, pCapsFlags);
    END
END;



PROCEDURE TVideoSample.GetVideoSize(VAR Width, height: integer);
VAR
  pBV : IBasicVideo;
BEGIN
  Width := 0;
  Height := 0;
  pBV := nil;
  if pIGraphBuilder.QueryInterface(IID_IBasicVideo, pBV)=S_OK then
//  if pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture, @MEDIATYPE_Video, pIBFVideoSource, IID_IBasicVideo, pBV) = S_OK then
    pBV.GetVideoSize(Width, height);
END; {GetVideoSize}



FUNCTION TVideoSample.ShowVfWCaptureDlg: HResult;
VAR
  pVfw : IAMVfwCaptureDialogs;
BEGIN
  pVfw := nil;
  pIMediaControl.Stop;
  Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_CAPTURE,
                                     @MEDIATYPE_Video,
                                     pIBFVideoSource,
                                     IID_IAMVfwCaptureDialogs, pVfW);

  if not(Succeeded(Result)) then // Retry
    Result := pICapGraphBuild2.queryinterface(IID_IAMVfwCaptureDialogs, pVfw);
  if not(Succeeded(Result)) then // Retry
    Result := pIGraphBuilder.queryinterface(IID_IAMVfwCaptureDialogs, pVfw);

  if (SUCCEEDED(Result)) THEN
    BEGIN
      // Check if the device supports this dialog box.
      if (S_OK = pVfw.HasDialog(VfwCaptureDialog_Source)) then
        // Show the dialog box.
        Result := pVfw.ShowDialog(VfwCaptureDialog_Source, ghApp);
    END;
  pIMediaControl.Run;
END;



FUNCTION TVideoSample.GetExProp(   guidPropSet : TGuiD;
                                      dwPropID : TAMPropertyPin;
                                pInstanceData  : pointer;
                                cbInstanceData : DWORD;
                                 out pPropData;
                                    cbPropData : DWORD;
                                out pcbReturned: DWORD): HResult;
BEGIN
  Result := pIKsPropertySet.Get(guidPropSet, dwPropID, pInstanceData, cbInstanceData, pPropData, cbPropData, pcbReturned);
END;



FUNCTION TVideoSample.SetExProp(   guidPropSet : TGuiD;
                                      dwPropID : TAMPropertyPin;
                                pInstanceData  : pointer;
                                cbInstanceData : DWORD;
                                     pPropData : pointer;
                                    cbPropData : DWORD): HResult;
BEGIN
  Result := pIKsPropertySet.Set_(guidPropSet, dwPropID, pInstanceData, cbInstanceData, pPropData, cbPropData);
END;


// Does work, if no GDI functions are called within callback!
// See remark on http://msdn.microsoft.com/en-us/library/ms786692(VS.85).aspx
PROCEDURE TVideoSample.SetCallBack(CB: TVideoSampleCallBack);
BEGIN
  CallBack := CB;
  SGrabberCB.FSampleGrabberCB.CallBack := CB;
END;


FUNCTION TVideoSample.GetPlayState: TPlayState;
BEGIN
  Result := g_psCurrent;
END;



PROCEDURE TVideoSample.GetListOfVideoSizes(VidSize: TStringList);
VAR
  i : integer;
BEGIN
  try
    IF not(assigned(VidSize)) then
      VidSize := TStringList.Create;
    VidSize.Clear;
  except
    exit;
  end;
  IF g_psCurrent < PS_Paused then
    exit;
  FOR i := 0 TO Length(FormatArr)-1 DO
    VidSize.Add(IntToStr(FormatArr[i].Width)+'*'+IntToStr(FormatArr[i].Height) + '  (' + FormatArr[i].FourCC+')');
END;




{$ifdef REGISTER_FILTERGRAPH}

FUNCTION TVideoSample.AddGraphToRot(pUnkGraph: IUnknown; VAR pdwRegister: DWORD):HRESULT;
VAR
  pMoniker   : IMoniker;
  pRot       : IRunningObjectTable;
  sz         : string;
  wsz        : ARRAY[0..128] OF wchar;
  hr         : HResult;
  dwRegister : integer absolute pdwregister;
  i : integer;
BEGIN
    {
    if (!pUnkGraph || !pdwRegister)
        return E_POINTER;
    }
    if (FAILED(GetRunningObjectTable(0, pROT))) then
      begin
        result := E_FAIL;
        exit;
      end;
    {
    wsprintfW(wsz, 'FilterGraph %08x pid %08x\0', DWORD_PTR(pUnkGraph),
              GetCurrentProcessId());
    }
    sz := 'FilterGraph ' + lowercase(IntToHex(integer((pUnkGraph)), 8))+' pid '+
                           lowercase(IntToHex(GetCurrentProcessID,8))+#0;
    fillchar(wsz, sizeof(wsz), #0);
    for i := 1 to length(sz) DO
      wsz[i-1] := widechar(sz[i]);
    hr := CreateItemMoniker('!', wsz, pMoniker);
    if (SUCCEEDED(hr)) then
      begin
        // Use the ROTFLAGS_REGISTRATIONKEEPSALIVE to ensure a strong reference
        // to the object.  Using this flag will cause the object to remain
        // registered until it is explicitly revoked with the Revoke() method.
        //
        // Not using this flag means that if GraphEdit remotely connects
        // to this graph and then GraphEdit exits, this object registration
        // will be deleted, causing future attempts by GraphEdit to fail until
        // this application is restarted or until the graph is registered again.
        hr := pROT.Register(ROTFLAGS_REGISTRATIONKEEPSALIVE, pUnkGraph,
                            pMoniker, dwRegister);
//        i := pMoniker._Release;  // <- Delphi wont let me do this myself!
      end;

//    pROT._Release(); // <- Delphi wont let me do this myself!
    result := hr;
end;



// Removes a filter graph from the Running Object Table
procedure TVideoSample.RemoveGraphFromRot(pdwRegister: dword);
VAR
  pROT :  IRunningObjectTable;
begin
  if (SUCCEEDED(GetRunningObjectTable(0, pROT))) then
    begin
      pROT.Revoke(pdwRegister);
//      pROT._Release();
    end;
end;

{$endif}




(*
FUNCTION TVideoSample.GetStreamInfoTest(VAR Width, Height: integer; VAR FourCC: dword): HResult;
VAR
  pSC   : IAMStreamConfig;
  ppmt  : PAMMediaType;
  pmt   : _AMMediaType;

  VI    : VideoInfo;
  VIH   : VideoInfoHeader;
BEGIN
  Width := 0;
  Height := 0;
  pIMediaControl.Stop;
  pIBFVideoSource.Stop;  // nicht zwingend n飆ig

  pSC := nil;
  Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture,
                                           @MEDIATYPE_Video,
                                           pIBFVideoSource,
                                           IID_IAMStreamConfig, pSC);
  pSC.GetNumberOfCapabilities(piCount, piSize)
  {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
  if Result = S_OK then
    begin
      pSC.GetFormat(ppmt);
      pmt := ppmt^;
      if  TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) then
        begin
          FillChar(VI, SizeOf(VI), #0);
          VIH := VideoInfoHeader(ppmt^.pbFormat^);
          move(VIH, VI, SizeOf(VIH));
          Width := VI.bmiHeader.biWidth;
          Height := Abs(VI.bmiHeader.biHeight);
          FourCC := VI.bmiHeader.biCompression;
        end;
    end;
  pIBFVideoSource.Run(0);// nicht zwingend n飆ig
  pIMediaControl.Run;
END;
*)








destructor TVideoSample.Destroy;
begin
  try
    SetPreviewState(false);
    pIMediaControl.Stop;
    pIBFVideoSource.Stop;
    DeleteCaptureGraph;
    closeInterfaces;
    if assigned(SGrabberCB) and assigned(TSampleGrabberCB(SGrabberCB).FSampleGrabberCB) then
      begin
        TSampleGrabberCB(SGrabberCB).FSampleGrabberCB.Free;
        TSampleGrabberCB(SGrabberCB).FSampleGrabberCB := nil;
      end;



  finally
    try
      inherited destroy;
    except
    end;
  end;
end;











end.

uBarcode.pas 產生二維碼類

unit uBarcode;

interface
uses Winapi.Windows, Vcl.Graphics,System.Types,System.SysUtils,Vcl.ExtCtrls;

{
生成QRCODE時會用到的幾個參數：

一、TZintSymbol.symbology 條碼類型，本例中使用BARCODE_QRCODE，對應的值爲58，更多條碼類型參考zint.h頭文件中的定義

二、TZintSymbol.option_1 容錯級別，本例中沒有設置。對應的值爲一、二、三、4 ，也就是LEVEL_L、LEVEL_M、LEVEL_Q、LEVEL_H

三、TZintSymbol.option_2 圖像大小，取值範圍爲1 - 40，數值越大生成的圖像越大。

三、TZintSymbol.input_mode 輸入類型，取值範圍0、一、二、三、4，分別表示DATA_MODE、UNICODE_MODE、GS1_MODE、KANJI_MODE、SJIS_MODE；默認值爲0，即DATA_MODE。

建議處理中文時使用DATA_MODE，並將輸入內容編碼爲UTF8。
}
type
  TZintLevel=(LEVEL_L=1,LEVEL_M,LEVEL_Q,LEVEL_H);
  TZintSymbol = packed record
    symbology: Integer;
    height: Integer;
    whitespace_width: Integer;
    border_width: Integer;
    output_options: Integer;
    fgcolour: array[0..9] of AnsiChar;
    bgcolour: array[0..9] of AnsiChar;
    outfile: array[0..255] of AnsiChar;
    scale: Single;
    option_1: Integer; //容錯級別
    option_2: Integer;
    option_3: Integer;
    show_hrt: Integer;
    input_mode: Integer;
    eci: Integer;
    text: array[0..127] of AnsiChar;
    rows: Integer;
    width: Integer;
    primary: array[0..127] of AnsiChar;
    encoded_data: array[0..199, 0..142] of AnsiChar;
    row_height: array[0..199] of Integer; // Largest symbol is 189 x 189
    errtxt: array[0..99] of AnsiChar;
    bitmap: PAnsiChar;
    bitmap_width: Integer;
    bitmap_height: Integer;
    bitmap_byte_length: Cardinal;
    dot_size: Single;
    rendered: Pointer;
    debug: Integer;
  end;
  PZintSymbol = ^TZintSymbol;
 Type TZint=class(Tobject)
  private
    FSymbol : PZintSymbol;
    FData : UTF8String;
    FImage : TImage;
    FBitmap: TBitmap;
    FType : Integer; //條碼類型
    FLevel : TZintLevel;
    function ZBarcodeCreate: PZintSymbol;
    procedure ZBarcodeDelete;
    function ZBarcodeEncodeAndOutput(out AErr:string):Integer;
    procedure ZBarcode_To_Bitmap;
  public
    procedure ShowBarCode;
  public
    constructor Create(AData:string; AImage: TImage; ALevel:TZintLevel=LEVEL_L;AType:Integer=58);
    destructor Destroy;override;
end;


  // create bitmap 這個函數是使用編碼後的條碼圖像數據生成Bitmap文件，不屬於zint，所以不在zint.h頭文件中，上面的三個在zint.h頭文件中。
 // procedure ZBarcode_To_Bitmap(symbol: PZintSymbol;var ABitmap: TBitmap);
implementation
const
  // Tbarcode 7 codes
  BARCODE_QRCODE        = 58;
  LibName = 'zint.dll';

  //struct zint_symbol *ZBarcode_Create(void);
  function ZBarcode_Create(): PZintSymbol; cdecl; external LibName;

  //void ZBarcode_Delete(struct zint_symbol *symbol);
  procedure ZBarcode_Delete(symbol: PZintSymbol); cdecl; external LibName;

  //int ZBarcode_Encode_and_Buffer(struct zint_symbol *symbol, unsigned char *input, int length, int rotate_angle);
  function ZBarcode_Encode_and_Buffer(symbol: PZintSymbol; input: PAnsiChar; length, rotate_angle: Integer): Integer; cdecl; external LibName;



{ TZint }

constructor TZint.Create(AData: string; AImage: TImage;ALevel:TZintLevel;AType:Integer);
begin
  if not Assigned(AImage) then
    raise Exception.Create('not assigned(Bitmap)');
  FData := UTF8String(AData);
  FImage := AImage;
  FSymbol := ZBarcodeCreate;
  FType := AType; //條碼類型
  FLevel := ALevel;
  FSymbol.option_1 := Ord(FLevel);
  FBitmap := TBitmap.Create;
  if not Assigned(FSymbol) then
    raise Exception.Create('Generate BarCode Failed!');
  FSymbol.symbology := FType;
end;

destructor TZint.Destroy;
begin
  FBitmap.Free;
  FBitmap := nil;
  ZBarcodeDelete;
  inherited;
end;

procedure TZint.ShowBarCode;
var
  AErrNumber : integer;
  AErrMsg : string;
begin
  AErrNumber := ZBarcodeEncodeAndOutput(AErrMsg);
  FImage.Picture.Bitmap.Width := FImage.Width;
  FImage.Picture.Bitmap.Height := FImage.Height;
  FImage.Picture.Bitmap.Canvas.Brush.Color := clWhite;
  FImage.Picture.Bitmap.Canvas.FillRect(Rect(0, 0, FImage.Width, FImage.Height));
  if AErrNumber=0 then
  begin
    ZBarcode_To_Bitmap;
    FImage.Picture.Bitmap.Canvas.StretchDraw(Rect(10, 10, FImage.Width - 10, FImage.Height - 10), FBitmap);
  end
  else
   raise Exception.Create('編碼時發生錯誤：' + AErrMsg);

end;

function TZint.ZBarcodeCreate:PZintSymbol;
begin
  Result := ZBarcode_Create;
end;

procedure TZint.ZBarcodeDelete;
begin
  ZBarcode_Delete(FSymbol);
end;

function TZint.ZBarcodeEncodeAndOutput(out AErr:string): Integer;
begin
 Result := ZBarcode_Encode_and_Buffer(FSymbol,PAnsiChar(FData),Length(FData),0);
 AErr := string(AnsiString(FSymbol.errtxt));
end;

procedure TZint.ZBarcode_To_Bitmap;
var
  SrcRGB: PRGBTriple;
  Row, RowWidth: Integer;
begin
  FBitmap.PixelFormat := pf24bit;
  FBitmap.SetSize(Fsymbol.bitmap_width, Fsymbol.bitmap_height);

  SrcRGB := Pointer(Fsymbol.bitmap);
  RowWidth := Fsymbol.bitmap_width * 3;

  for Row := 0 to Fsymbol.bitmap_height - 1 do
  begin
    CopyMemory(FBitmap.ScanLine[Row], SrcRGB, RowWidth);
    Inc(SrcRGB, Fsymbol.bitmap_width);
  end;

  SetBitmapBits(FBitmap.Handle, Fsymbol.bitmap_width * Fsymbol.bitmap_height * 3, Fsymbol.bitmap);

end;

end.

uScanBarCode.pas 掃描的類

unit uScanBarCode;

interface
uses
  Winapi.Windows,Vcl.Forms,vcl.Graphics,Vcl.ExtCtrls, System.SysUtils,
  VFrames,VSample,System.Classes,Vcl.StdCtrls,
  ZXing.ReadResult,
  ZXing.BarCodeFormat,
  ZXing.ScanManager;

type
  TZXingBarCode=class  //Scan By Video
  private
    FTimer : TTimer;
    FImage : TImage;
    FOffset : Integer;
    FBitmap : TBitmap; //臨時獲取圖片
    FVideoImage : TVideoImage;
    FDeviceName : string;
    FDevices : TStringlist;
    FScaning : Boolean;
    FData : string;
    FDefineDevice:Boolean; //是否指定攝像頭
    FMemo:TMemo;
  public
    procedure Start;
    procedure Stop;
  protected
    procedure NewVideoFrame(Sender : TObject; Width, Height: integer; DataPtr: pointer);virtual;
    procedure CustomTimer(Sender:TObject);virtual;
    procedure DrawLine(ASrcPoint,ADesPoint:TPoint);virtual;
  public
    property Status:Boolean read FScaning write FScaning;
    property Data : string read FData write FData;
    property Offset:Integer read FOffset write FOffset;
    constructor Create(AImage:TImage;ADisplay:TMemo;ADeviceName:string); overload;
    constructor Create(AImage:TImage;ADisplay:TMemo); overload;
    destructor Destroy; override;
  end;
type
  TZXingReadImage=class //scan by picture
  private
    FImage : TImage;
  public
    function GetValue:string;
    constructor Create(AImage:TImage);
    destructor Destroy; override;
  end;
implementation

{ TZXingBarCode }

constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo;ADeviceName:string);
begin
  if ADeviceName='' then
    raise Exception.Create('請指定攝像頭!');
  FDeviceName := ADeviceName;
  Create(AImage,ADisplay);
  FDefineDevice := True;
end;

constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo);
begin
  if not Assigned(AImage) then
    raise Exception.Create('Image is null.');

  FImage := AImage;
  FDefineDevice := False;
  FMemo := ADisplay;
  FTimer := TTimer.Create(nil);
  FTimer.Interval :=500;
  FTimer.Enabled := False;
  FTimer.OnTimer := CustomTimer;
  FBitmap := TBitmap.Create;
  FBitmap.PixelFormat := pf24bit;
  FVideoImage := TVideoImage.Create;
  FVideoImage.OnNewVideoFrame := NewVideoFrame;
  FOffset := 20;
end;

procedure TZXingBarCode.CustomTimer(Sender: TObject);
var
  pOri,pDesH,pDesV:TPoint;
begin
 with FImage do
  begin
    Canvas.Pen.Color := clWebGreen;
    Canvas.Pen.Width := 3;
  //  Canvas.pen.Mode := pmXor;

    pOri := Point(10,10);
    pDesH := Point(pOri.X+FOffset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y+FOffset);
    DrawLine(pOri,pDesH);
    DrawLine(pOri,pDesV);


    pOri := Point(width-10,10);
    pDesH := Point(pOri.X-FOffset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y+FOffset);
    DrawLine(pOri,pDesH);
    DrawLine(pOri,pDesV);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);

    pOri := Point(width-10,Height-10);
    pDesH := Point(pOri.X-FOffset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y-FOffset);
    DrawLine(pOri,pDesH);
    DrawLine(pOri,pDesV);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);

    pOri := Point(10,Height-10);
    pDesH := Point(pOri.X+FOffset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y-FOffset);
    DrawLine(pOri,pDesH);
    DrawLine(pOri,pDesV);

    DrawLine(pOri,pDesH);
    DrawLine(pOri,pDesV);
   // Canvas.Pen.Mode := pmCopy;
  end;

end;

destructor TZXingBarCode.Destroy;
begin
  FTimer.Enabled := False;
  FreeAndNil(FVideoImage);
  FBitmap.Free;
  FTimer.Free;
  inherited;
end;

procedure TZXingBarCode.DrawLine(ASrcPoint, ADesPoint: TPoint);
begin
  FImage.Canvas.MoveTo(ASrcPoint.X,ASrcPoint.Y);
  FImage.Canvas.LineTo(ADesPoint.X,ADesPoint.Y);
end;

procedure TZXingBarCode.NewVideoFrame(Sender: TObject; Width, Height: integer;
  DataPtr: pointer);
var
  AScanManager : TScanManager;
  AReadResult : TReadResult;
begin
  AScanManager := nil;
  AReadResult := nil;
  try
    FVideoImage.GetBitmap(FBitmap);
    FImage.Picture.Assign(FBitmap);

    //scan code ,若是爲 TBarcodeFormat.Auto會報錯
    try
      AScanManager := TScanManager.Create(TBarcodeFormat.QR_CODE,nil);
      AReadResult := AScanManager.Scan(FBitmap);
      if Assigned(AReadResult) then
      begin
        Data := AReadResult.text;
        if (Data<>'') and  Assigned(FMemo) then
          FMemo.Lines.Add(Data);
      end;
    finally
       FreeAndNil(AScanManager);
       FreeAndNil(AReadResult);
    end;
  finally

  end;
  Application.ProcessMessages;
end;



procedure TZXingBarCode.Start;
begin
  if FScaning then Exit;
  FDevices := TStringList.Create;
  try
    FVideoImage.GetListOfDevices(FDevices);
    if FDevices.Count=0 then
      raise Exception.Create('沒有可用的攝像頭.');
    if FDefineDevice then
    begin
       if FDevices.IndexOf(FDeviceName)=-1 then
          raise Exception.Create('傳入的攝像頭不存在!');
    end else
    begin
      FDeviceName := FDevices[0];//第一個攝像頭
    end;
  finally
    FDevices.Free;
  end;
  FScaning := FVideoImage.VideoStart(FDeviceName)=0;//返回0表示成功
  FTimer.Enabled := True;
end;

procedure TZXingBarCode.Stop;
begin
  FVideoImage.VideoStop;
  FScaning := False;
  FTimer.Enabled := False;
end;

{ TZXingReadImage }

constructor TZXingReadImage.Create(AImage: TImage);
begin
  if not Assigned(AImage) then
    raise Exception.Create('not define image.');
  FImage := AImage;
end;

destructor TZXingReadImage.Destroy;
begin

  inherited;
end;

function TZXingReadImage.GetValue: string;
var
   AReadResult: TReadResult;
   AScanManager: TScanManager;
   Abmp:VCL.Graphics.TBitmap; // just to be sure we are really using VCL bitmaps
begin
  AReadResult := nil;
  AScanManager := nil;
  Abmp := nil;
  try
    Abmp:= TBitmap.Create;
    Abmp.assign (FImage.Picture.Graphic);
    AScanManager := TScanManager.Create(TBarcodeFormat.Auto, nil);
    AReadResult := AScanManager.Scan(Abmp);
    if AReadResult<>nil then
      Result := AReadResult.text
    else
      Result := 'Unreadable!';
  finally
    AScanManager.Free;
    AReadResult.Free;
  end;

end;

end.

uMain.pas 主單元文件

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls,
  Vcl.Imaging.jpeg,uScanBarCode,vcl.imaging.pngImage;

type
  TForm1 = class(TForm)
    Image1: TImage;
    btnGenerateBar: TSpeedButton;
    Edit1: TEdit;
    Label1: TLabel;
    cmbLevel: TComboBox;
    Label2: TLabel;
    BitBtn1: TBitBtn;
    btnStart: TBitBtn;
    btnStop: TBitBtn;
    Memo1: TMemo;
    btnScanFile: TBitBtn;
    Timer1: TTimer;
    procedure btnGenerateBarClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure btnScanFileClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FScan:TZXingBarCode;
  public
    { Public declarations }
    procedure CreateBarCode();
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses uBarcode;
var
 offset:Integer=20;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
  pOri,pDesH,pDesV:TPoint;
begin
 with image1 do
  begin
    Canvas.Pen.Color := clGreen;
    Canvas.Pen.Width := 2;
    Canvas.pen.Mode := pmXor;

    pOri := Point(10,10);
    pDesH := Point(pOri.X+offset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y+offset);
    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesH.X,pDesH.Y);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);

    pOri := Point(width-10,10);
    pDesH := Point(pOri.X-offset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y+offset);
    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesH.X,pDesH.Y);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);

    pOri := Point(width-10,Height-10);
    pDesH := Point(pOri.X-offset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y-offset);
    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesH.X,pDesH.Y);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);

    pOri := Point(10,Height-10);
    pDesH := Point(pOri.X+offset,pOri.Y);
    pDesV := Point(pOri.X,pOri.Y-offset);
    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesH.X,pDesH.Y);

    Canvas.MoveTo(pOri.X,pOri.Y);
    Canvas.LineTo(pDesV.X,pDesV.Y);
    //Canvas.Pen.Mode := pmCopy;
  end;
end;

procedure TForm1.btnScanFileClick(Sender: TObject);
var
  ADlg:TOpenDialog;
  AReader:TZXingReadImage;
begin
  ADlg := TOpenDialog.Create(self);
  try
    ADlg.Filter :='png圖片|*.png|jpg圖片|*.jpg|jpeg圖片|*.jpeg|bitmap|*.bmp';
    ADlg.DefaultExt :='.bmp';
    if not ADlg.Execute then exit;
    if ADlg.FileName='' then Exit;
    try
      Image1.Picture.LoadFromFile(ADlg.FileName);
    except on E: Exception do
      raise Exception.Create(e.Message);
    end;
    try
      AReader:= TZXingReadImage.Create(Image1);
      Memo1.Lines.Text := AReader.GetValue;
    finally
      AReader.Free;
    end;
  finally
    ADlg.Free;
  end;
end;

procedure TForm1.btnStartClick(Sender: TObject);
begin

  if not Assigned(FScan) then
    FScan := TZXingBarCode.Create(Image1,Memo1);
  FScan.Start;
  Timer1.Enabled := true;
  btnStart.Enabled :=not FScan.Status;
  btnStop.Enabled := FScan.Status;

end;

procedure TForm1.btnStopClick(Sender: TObject);
begin

   if Assigned(FScan) then
   begin
     FScan.Stop;
     Timer1.Enabled := false;
     btnStart.Enabled :=True;
     btnStop.Enabled := False;
     FreeAndNil(FScan);
     Image1.Picture := nil;
   end;
end;

procedure TForm1.CreateBarCode;
var
  zint:TZint;
begin
  zint := TZint.Create(Edit1.Text,Image1,TZintLevel(cmbLevel.ItemIndex+1));
  try
    zint.ShowBarCode;
  finally
    zint.Free;
  end;

end;

procedure TForm1.btnGenerateBarClick(Sender: TObject);
begin
  CreateBarCode();
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := False;
  try
    if Assigned(FScan) and (FScan.Data<>'') then
    begin
    ShowMessage('process data:'+FScan.Data);
    FScan.Data:='';
    end;
  finally
    Timer1.Enabled := True;
  end;
end;

end.

 

 最終執行界面：

（根據內容產生條碼）

 

 

打開攝像頭掃描：

圖片識別：

 

注意：在打開攝像頭掃描時，若是TBarcodeFormat爲AUTO時會莫名的報錯。