Delphi USB摄像头

参考：https://blog.csdn.net/qq_44111597/article/details/112787624

RAD Studio 10.2.3 测试√

声明：

uses
  DirectShow9, untUSBCamera, Winapi.ActiveX

  private
    { Private declarations }
    // 系统开发人员枚举【基本 Filter】
    mBaseFilter           : IBaseFilter;
    // FI图形生成器【图形生成器】
    mGraphBuilder        : IGraphBuilder;
    // FI媒体控制【媒体控制】
    mMediaControl        : IMediaControl;
    // FI视频窗口【视频窗口】
    mVideoWindow         : IVideoWindow;
    // FI捕获图生成器2【捕获图生成器2】
    mCaptureGraphBuilder2: ICaptureGraphBuilder2;
    // FI样品采集器【样品采集器】
    mSampleGrabber       : ISampleGrabber;
    procedure FreeGraph;
    procedure mSnapBmp;
    function ShowFilterPropertyPages(filter: IBaseFilter; hFormHandle: THandle): Boolean;
    function ShowPinPropertyPages(pin: IPin; hFormHandle: THandle): Boolean;

// 视频预览变量初始化
procedure TForm1.FreeGraph;
begin
  mBaseFilter            := nil;
  mGraphBuilder         := nil;
  mMediaControl         := nil;
  mVideoWindow          := nil;
  mCaptureGraphBuilder2 := nil;
  mSampleGrabber        := nil;
end;

// 截图 -- 保存
procedure TForm1.mSnapBmp;
var
  pfs        : TFilterState;
  mt         : TAMMediaType;
  hr         : HResult;
  pBufferSize: Integer;
  pBuffer    : PByte;
  bmp        : TBitmap;
  vi         : PVideoInfoHeader;
begin
  if mMediaControl = nil then
    Exit;

  // FI媒体控制.获取状态（时间，Filter状态）
  mMediaControl.GetState(1000, pfs);
  if pfs = State_Stopped then
    Exit;

  { 获取媒体类型 }
  // = 样品采集器.获取连接的媒体类型（媒体类型）
  hr := mSampleGrabber.GetConnectedMediaType(mt);
  if hr <> S_OK then
    Exit;

  // 如果 媒体类型.格式 = nil
  if mt.pbFormat = nil then
    Exit;

  // = 视频信息标题（媒体类型.格式）
  vi := PVideoInfoHeader(mt.pbFormat);

  { 获取当前帧数据大小 }
  // = 样品采集器.获取当前缓冲区（p缓冲区大小，nil）
  hr := mSampleGrabber.GetCurrentBuffer(pBufferSize, nil);
  if hr <> S_OK then
    Exit;

  { 分配内存大小 }
  pBuffer := AllocMem(pBufferSize);
  try
    { 再一次获取当前帧，获取图像数据 }
    hr := mSampleGrabber.GetCurrentBuffer(pBufferSize, pBuffer);
    if hr <> S_OK then
      Exit;

    { 创建位图 }
    bmp := TBitmap.Create;
    try
      // bmp.像素格式 =
      bmp.PixelFormat := pf24bit;
      bmp.width       := vi^.bmiHeader.biWidth;
      bmp.height      := vi^.bmiHeader.biHeight;
      SetBitmapBits(bmp.Handle, vi^.bmiHeader.biSizeImage, pBuffer);
      bmp.Canvas.CopyRect(bmp.Canvas.ClipRect, bmp.Canvas, Rect(0, bmp.height, bmp.width, 0));
      // 把位图信息放在img控件中
      bmp.SaveToFile(ExtractFilePath(Paramstr(0)) + \'Temp\\' + FormatDateTime(\'YYYYMMDDhhmmss\', Now()) + \'.jpg\');
    finally
      bmp.Free;
    end;
  finally
    FreeMem(pBuffer);
  end;
end;

// 显示 Filter 属性页【调用 Filter 的属性页，窗口的 Windows 本身的】
function TForm1.ShowFilterPropertyPages(filter: IBaseFilter; hFormHandle: THandle): Boolean;
var
  // 指定属性页
  pSpecify: ISpecifyPropertyPages;
  // 全局唯一标识符
  caGUID  : TCAGUID;
begin
  Result   := False;
  pSpecify := nil;
  filter.QueryInterface(ISpecifyPropertyPages, pSpecify);
  if pSpecify <> nil then
  begin
    // 指定属性页.获取页面（全局唯一标识符）
    pSpecify.GetPages(caGUID);
    pSpecify := nil;
    Result   := OleCreatePropertyFrame(hFormHandle, 0, 0, \'\', 1, Pointer(@filter), caGUID.cElems, PGUID(caGUID.pElems), 0, 0, nil) = S_OK;
    CoTaskMemFree(caGUID.pElems);
  end;
end;

function TForm1.ShowPinPropertyPages(pin: IPin; hFormHandle: THandle): Boolean;
var
  // 指定属性页
  pSpecify: ISpecifyPropertyPages;
  // 全局唯一标识符
  caGUID  : TCAGUID;
begin
  Result   := False;
  pSpecify := nil;
  // Filter.查询接口（类型，值【指定属性页】）
  pin.QueryInterface(ISpecifyPropertyPages, pSpecify);
  if pSpecify <> nil then
  begin
    // 指定属性页.获取页面（全局唯一标识符）
    pSpecify.GetPages(caGUID);
    pSpecify := nil;
    Result   := OleCreatePropertyFrame(hFormHandle, 0, 0, \'\', 1, Pointer(@pin), caGUID.cElems, PGUID(caGUID.pElems), 0, 0, nil) = S_OK;
    CoTaskMemFree(caGUID.pElems);
  end;
end;

1.展示设备

begin
  { 视频预览变量初始化 }
  FreeGraph;
  // 获取所有USB摄像头，存入下面控件的列表中
  EnumAllUSBCamera(ListBox3.Items);
end;

2.展示格式

begin
  if ListBox3.ItemIndex = -1 then
  begin
    ShowMessage(\'请选择设备！\');
    exit;
  end;
  { 枚举视频支持格式 }
  if not EnumVideoFormat(String(PVideoInputInfo(ListBox3.Items.Objects[ListBox3.ItemIndex])^.strName), PVideoInputInfo(ListBox3.Items.Objects[ListBox3.ItemIndex])^.index, ListBox4.Items) then
    Exit;

  ListBox4.ItemIndex := 0;
  ListBox4.SetFocus;
end;

3.打开预览

begin
  if mMediaControl = nil then
  begin
    { 视频预览 }
    if USBVideoPreview(mGraphBuilder, mCaptureGraphBuilder2, mBaseFilter, mVideoWindow, mMediaControl, mSampleGrabber, PVideoInputInfo(ListBox3.Items.Objects[ListBox3.ItemIndex]), PVideoFormatInfo(ListBox4.Items.Objects[ListBox4.ItemIndex]), Panel1, True) then
    begin
      Button14.Caption := \'3.停止预览\';
      mMediaControl.Run;
    end;
  end
  else
  begin
    Button14.Caption := \'3.打开预览\';
    mMediaControl.Stop;
    FreeGraph;
  end;
end;

4.保存图片至本地

begin
  mSnapBmp;
end;

5.色彩选择和通道选项

// 色彩选择
begin
  ShowFilterPropertyPages(mBaseFilter, Handle);
end;
// 通道选项
var
  pin: IPin;
begin
  mCaptureGraphBuilder2.FindPin(mBaseFilter, PINDIR_OUTPUT, nil, nil, False, 0, pin);
  ShowPinPropertyPages(pin, Handle);
end;

附件：untUSBCamera单元文件

unit untUSBCamera;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, DirectShow9, ActiveX, Dialogs, StdCtrls, ExtCtrls;

type
  PVideoInputInfo  = ^TVideoInputInfo;
  PVideoFormatInfo = ^TVideoFormatInfo;

  { 视频输入设备 }
  TVideoInputInfo = record
    id: TGUID;
    strName: ShortString;
    index: Integer;
  end;

  { 视频支持格式 }
  TVideoFormatInfo = record
    id: TGUID;
    iWidth, iHeight: Integer;
    iMod: TGUID;
    Frame: Int64;
    format: ShortString;
  end;

type
  IAMStreamConfig = interface(IUnknown)
    [\'{C6E13340-30AC-11d0-A18C-00A0C9118956}\']
    function SetFormat(const pmt: TAMMediaType): HResult; stdcall;
    function GetFormat(out ppmt: PAMMediaType): HResult; stdcall;
    function GetNumberOfCapabilities(out piCount, piSize: Integer): HResult; stdcall;
    { Delphi 声明有误，修改声明 }
    function GetStreamCaps(iIndex: Integer; var ppmt: PAMMediaType; pSCC: PVideoStreamConfigCaps): HResult; stdcall;
  end;

  ISampleGrabber = interface(IUnknown)
    [\'{6B652FFF-11FE-4FCE-92AD-0266B5D7C78F}\']
    function SetOneShot(OneShot: BOOL): HResult; stdcall;
    { Delphi 声明有误，修改声明 }
    function SetMediaType(pType: PAMMediaType): HResult; stdcall;
    function GetConnectedMediaType(out pType: TAMMediaType): HResult; stdcall;
    function SetBufferSamples(BufferThem: BOOL): HResult; stdcall;
    function GetCurrentBuffer(var pBufferSize: longint; pBuffer: Pointer): HResult; stdcall;
    function GetCurrentSample(out ppSample: IMediaSample): HResult; stdcall;
    function SetCallback(pCallback: ISampleGrabberCB; WhichMethodToCallback: longint): HResult; stdcall;
  end;

  { 枚举所有视频输入设备 }
/// <summary>
/// 枚举所有视频输入设备
/// </summary>
/// <param name="strsList">设备名称展示的存放地方</param>
procedure EnumAllUSBCamera(strsList: TStrings);

{ 枚举视频支持格式 }
/// <summary>
/// 枚举视频支持格式【遍历出支持的视频格式】
/// </summary>
/// <param name="strFriendlyName">传进来的设备名称</param>
/// <param name="intIndex">设备的下标序号</param>
/// <param name="strsList">格式展示的box</param>
/// <returns>布尔类型</returns>
function EnumVideoFormat(const strFriendlyName: String; const intIndex: Integer; strsList: TStrings): Boolean;

{ 视频预览 }
/// <summary>
/// 视频预览【USB视频预览】
/// </summary>
/// <param name="FIGraphBuilder">FI图形生成器</param>
/// <param name="FICaptureGraphBuilder2">FI捕获图生成器2</param>
/// <param name="FSysDevEnum">FSys开发枚举【mBaseFilter】</param>
/// <param name="FIVideoWindow">FI视频窗口</param>
/// <param name="FIMediaControl">FI媒体控制</param>
/// <param name="FISampleGrabber">FI样品采集器</param>
/// <param name="pv">P视频输入信息（USB摄像头.列表.对象[pv]）</param>
/// <param name="pf">P视频输入信息（USB摄像头支持格式.列表.对象[pf]）</param>
/// <param name="pnl">pnl视频【放视频的面板】</param>
/// <param name="bSnapBmp">是否需要截屏功能</param>
/// <returns>布尔类型</returns>
function USBVideoPreview(var FIGraphBuilder: IGraphBuilder; var FICaptureGraphBuilder2: ICaptureGraphBuilder2; var FSysDevEnum: IBaseFilter; var FIVideoWindow: IVideoWindow; var FIMediaControl: IMediaControl; var FISampleGrabber: ISampleGrabber; pv: PVideoInputInfo; pf: PVideoFormatInfo; pnl: TPanel; const bSnapBmp: Boolean = True): Boolean;

{ 视频录制 }
/// <summary>
/// 视频录制【USB视频录制】
/// </summary>
/// <param name="FIGraphBuilder">FI图形生成器</param>
/// <param name="FICaptureGraphBuilder2">FI捕获图生成器</param>
/// <param name="FSysDevEnum">FSys开发枚举</param>
/// <param name="FIVideoWindow">FI视频窗口</param>
/// <param name="FIMediaControl">FI媒体控制</param>
/// <param name="FISampleGrabber">FI样品采集器</param>
/// <param name="pv">P视频输入信息（USB摄像头.列表.对象[pv]）</param>
/// <param name="pf">P视频输入信息（USB摄像头支持格式.列表.对象[pf]）</param>
/// <param name="pnl">pnl视频【放视频的面板】</param>
/// <param name="strSaveFileName">视频文件保存的位置</param>
/// <returns>布尔类型</returns>
function USBVideoRecord(var FIGraphBuilder: IGraphBuilder; var FICaptureGraphBuilder2: ICaptureGraphBuilder2; var FSysDevEnum: IBaseFilter; var FIVideoWindow: IVideoWindow; var FIMediaControl: IMediaControl; var FISampleGrabber: ISampleGrabber; pv: PVideoInputInfo; pf: PVideoFormatInfo; pnl: TPanel; const strSaveFileName: String): Boolean;

implementation

const
  IID_IPropertyBag: TGUID = \'{55272A00-42CB-11CE-8135-00AA004BB851}\';

  c_arrVideoFormatGUID: array [0 .. 35] of PGUID = (                                                                                 //
    @MEDIASUBTYPE_CLPL, @MEDIASUBTYPE_YUYV, @MEDIASUBTYPE_IYUV, @MEDIASUBTYPE_YVU9, @MEDIASUBTYPE_Y411, @MEDIASUBTYPE_Y41P,          //
    @MEDIASUBTYPE_YUY2, @MEDIASUBTYPE_YVYU, @MEDIASUBTYPE_UYVY, @MEDIASUBTYPE_Y211, @MEDIASUBTYPE_YV12, @MEDIASUBTYPE_CLJR,          //
    @MEDIASUBTYPE_IF09, @MEDIASUBTYPE_CPLA, @MEDIASUBTYPE_MJPG, @MEDIASUBTYPE_TVMJ, @MEDIASUBTYPE_WAKE, @MEDIASUBTYPE_CFCC,          //
    @MEDIASUBTYPE_IJPG, @MEDIASUBTYPE_Plum, @MEDIASUBTYPE_DVCS, @MEDIASUBTYPE_DVSD, @MEDIASUBTYPE_MDVF, @MEDIASUBTYPE_RGB1,          //
    @MEDIASUBTYPE_RGB4, @MEDIASUBTYPE_RGB8, @MEDIASUBTYPE_RGB565, @MEDIASUBTYPE_RGB555, @MEDIASUBTYPE_RGB24, @MEDIASUBTYPE_RGB32,    //
    @MEDIASUBTYPE_ARGB1555, @MEDIASUBTYPE_ARGB4444, @MEDIASUBTYPE_ARGB32, @MEDIASUBTYPE_AYUV, @MEDIASUBTYPE_AI44, @MEDIASUBTYPE_IA44 //
    );

  c_arrVideoFormatName: array [0 .. 35] of AnsiString = (    //
    \'CLPL\', \'YUYV\', \'IYUV\', \'YVU9\', \'Y411\', \'Y41P\',          //
    \'YUY2\', \'YVYU\', \'UYVY\', \'Y211\', \'YV12\', \'CLJR\',          //
    \'IF09\', \'CPLA\', \'MJPG\', \'TVMJ\', \'WAKE\', \'CFCC\',          //
    \'IJPG\', \'Plum\', \'DVCS\', \'DVSD\', \'MDVF\', \'RGB1\',          //
    \'RGB4\', \'RGB8\', \'RGB565\', \'RGB555\', \'RGB24\', \'RGB32\',    //
    \'ARGB1555\', \'ARGB4444\', \'ARGB32\', \'AYUV\', \'AI44\', \'IA44\' //
    );

function GetMaxIndex(const strsList: TStrings; const strUSBCameraName: string): Integer;
var
  III, Count: Integer;
begin
  Result  := 0;
  Count   := strsList.Count;
  for III := 0 to Count - 1 do
  begin
    if CompareText(String(PVideoInputInfo(strsList.Objects[III])^.strName), strUSBCameraName) = 0 then
    begin
      Result := Result + 1;
    end;
  end;
end;

// 创建 Filter【Filter 实际上它不是物理摄像头，只是模拟摄像头设备可以采集图像】
/// <summary>
/// 创建 Filter【Filter 实际上它不是物理摄像头，只是模拟摄像头设备可以采集图像
/// </summary>
/// <param name="gid">全局唯一标识</param>
/// <param name="FriendlyName">摄像头名字</param>
/// <param name="instanceIndex">摄像头下标序号</param>
/// <returns>基本 Filter</returns>
function CreateFilter(gid: TGUID; FriendlyName: AnsiString; instanceIndex: Integer): IBaseFilter;
var
  pSysDevEnum: ICreateDevEnum;
  pEnumCat   : IEnumMoniker;
  pMoniker   : IMoniker;
  cFetched   : ULONG;
  pPropBag   : IPropertyBag;
  bc         : IBindCtx;
  mo         : IMoniker;
  er         : IErrorLog;
  ov         : OleVariant;
  iIndex     : Integer;
begin
  Result := nil;

  // 系统开发人员枚举
  pSysDevEnum := nil;
  // 枚举猫
  pEnumCat    := nil;
  // 绰号
  pMoniker    := nil;

  // 如果 共同创建实例（） = 0
  if CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, pSysDevEnum) = S_OK then
  begin
    // 系统开发人员枚举.创建类枚举器（gid，枚举猫，0）
    if pSysDevEnum.CreateClassEnumerator(gid, pEnumCat, 0) = S_OK then
    begin
      iIndex := 0;
      while (pEnumCat.Next(1, pMoniker, @cFetched) = S_OK) and (cFetched > 0) and (pMoniker <> nil) do
      begin
        bc := nil;
        mo := nil;
        pMoniker.BindToStorage(bc, mo, IID_IPropertyBag, pPropBag);
        er := nil;
        pPropBag.Read(\'FriendlyName\', ov, er);
        if AnsiString(ov) = FriendlyName then
        begin
          if iIndex = instanceIndex then
          begin
            bc := nil;
            mo := nil;
            pMoniker.BindToObject(bc, mo, IID_IBaseFilter, Result);
          end;
          Inc(iIndex);
        end;
        pPropBag := nil;
        pMoniker := nil;
      end;
    end;
  end;
  pEnumCat    := nil;
  pSysDevEnum := nil;
end;

function VideoMediaSubTypeToStr(mst: TGUID): AnsiString;
var
  I: Integer;
begin
  Result := \'\';
  for I  := 0 to 35 do
    if CompareMem(c_arrVideoFormatGUID[I], @mst, sizeof(TGUID)) then
    begin
      Result := c_arrVideoFormatName[I];
      break;
    end;
end;

procedure FreeMediaType(mt: TAMMediaType);
begin
  if (mt.cbFormat <> 0) then
  begin
    CoTaskMemFree(mt.pbFormat);
    mt.cbFormat := 0;
    mt.pbFormat := nil;
  end;
  if (mt.pUnk <> nil) then
  begin
    mt.pUnk := nil;
  end;
end;

procedure DeleteMediaType(pmt: PAMMediaType);
begin
  if pmt <> nil then
  begin
    FreeMediaType(pmt^);
    CoTaskMemFree(pmt);
  end;
end;

// 获取输出引脚
function GetOutputPin(filter: IBaseFilter): IPin;
var
  penum: IEnumPins;
  f    : Integer;
  d    : PIN_DIRECTION;
begin
  Result := nil;
  filter.EnumPins(penum);
  while (penum.Next(1, Result, @f) = S_OK) and (f > 0) do
  begin
    if (Result.QueryDirection(d) = S_OK) and (d = PINDIR_OUTPUT) then
    begin
      { 找到输出接口，返回 }
      Exit;
    end;
  end;
  Result := nil;
end;

// Str到视频媒体子类型（格式）
function StrToVideoMediaSubType(ss: AnsiString): TGUID;
var
  I: Integer;
begin
  Result := c_arrVideoFormatGUID[0]^;
  for I  := 0 to 35 do
    if ss = c_arrVideoFormatName[I] then
    begin
      Result := c_arrVideoFormatGUID[I]^;
      break;
    end;
end;

function CompareGUID(const g1, g2: TGUID): Boolean;
begin
  Result := CompareMem(@g1, @g2, sizeof(TGUID));
end;

// 设置媒体类型（基本Filter，宽，高，格式）
function SetMediaType(filter: IBaseFilter; Width, Height: Integer; format: AnsiString): Boolean;
var
  pmt            : PAMMediaType;
  piCount, piSize: Integer;
  I              : Integer;
  pSCC           : PVideoStreamConfigCaps;
  streamConfig   : IAMStreamConfig;
  outPin         : IPin;
  formatID       : TGUID;
  selectedIndex  : Integer;
  ih             : PVIDEOINFOHEADER;
  bitRate        : dword;
begin
  Result := False;

  if (Width = 0) or (Height = 0) then
    Exit;

  // 获取输出引脚
  outPin := GetOutputPin(filter);
  // 查询界面（IID_IAM流配置，流配置）
  outPin.QueryInterface(IID_IAMStreamConfig, streamConfig);
  // 如果 已分配（流配置）
  if assigned(streamConfig) then
  begin
    // 选定索引 = -1
    selectedIndex := -1;
    // 比特率 = 0
    bitRate       := 0;
    // 格式ID = Str到视频媒体子类型（格式）
    formatID      := StrToVideoMediaSubType(format);
    // 配置流.获取功能数量（数量，大小）
    streamConfig.GetNumberOfCapabilities(piCount, piSize);
    // getmen（视频流配置上限，大小）
    getmem(pSCC, piSize);
    try
      for I := 0 to piCount - 1 do
      begin
        // 配置流.获取流上限（选定索引，媒体类型，视频流配置上限）
        streamConfig.GetStreamCaps(I, pmt, pSCC);
        // 视频信息头
        ih := Pointer(pmt^.pbFormat);
        // 选择最大比特率的格式
        if (pSCC^.MinOutputSize.cx = Width) and (pSCC^.MinOutputSize.cy = Height) and (ih^.bmiHeader.biWidth = Width) and (ih^.bmiHeader.biheight = Height) and ((format = \'\') or (CompareGUID(formatID, pmt^.subtype))) and (ih^.dwBitRate > bitRate)  
                       
                    
                     
                      



鲜花




握手




雷人




路过




鸡蛋

该文章已有0人参与评论

客服电话

电子邮件

Delphi USB摄像头 - 癫狂编程

Delphi USB摄像头

目录

声明：

1.展示设备

2.展示格式

3.打开预览

4.保存图片至本地

5.色彩选择和通道选项

附件：untUSBCamera单元文件

请发表评论

全部评论

上一篇：

下一篇：

CVE-2022-26481

PacktPublishing/Python-Machine-Learning-

sussillo/hfopt-matlab: A parallel, cpu-b

鲁东大学一米网:Win7系统USB驱动器RAM的操

emersion/go-ostatus: An OStatus library

剪的笔顺,诠释剪的笔画,认识剪的部首

六六分期app的软件客服如何联系？(六六分期

florent37/ViewAnimator: A fluent Android

florent37/Shrine-MaterialDesign2: implem

CVE-2020-36276

SimpleSoftwareIO/simple-sms: Send and re

关于我们

产品与服务

解决方案

139-2527-9053

客服电话

电子邮件

Delphi USB摄像头 - 癫狂编程

Delphi USB摄像头

目录

声明：

1.展示设备

2.展示格式

3.打开预览

4.保存图片至本地

5.色彩选择 和 通道选项

附件：untUSBCamera单元文件

请发表评论

全部评论

上一篇：

下一篇：

CVE-2022-26481

PacktPublishing/Python-Machine-Learning-

sussillo/hfopt-matlab: A parallel, cpu-b

鲁东大学一米网:Win7系统USB驱动器RAM的操

emersion/go-ostatus: An OStatus library

剪的笔顺,诠释剪的笔画,认识剪的部首

六六分期app的软件客服如何联系？(六六分期

florent37/ViewAnimator: A fluent Android

florent37/Shrine-MaterialDesign2: implem

CVE-2020-36276

SimpleSoftwareIO/simple-sms: Send and re

关于我们

产品与服务

解决方案

139-2527-9053

5.色彩选择和通道选项