delphi Dspack 分辨率 USB摄像头 保存

[linzhen6790]

delphi Dspack 分辨率

procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
  // 读取系统中的视频输入设备
  SysDev:= TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
  if SysDev.CountFilters > 0 then
  for i := 0 to SysDev.CountFilters - 1 do
  begin
    Listbox1.Items.Add(SysDev.Filters[i].FriendlyName)
   end;
end;

procedure TForm1.ListBox1Click(Sender: TObject); //选择摄像头
begin
  FilterGraph1.ClearGraph;
  FilterGraph1.Active := false;
  //设filter为所选视频输入设备
  Filter1.BaseFilter.Moniker := SysDev.GetMoniker(Listbox1.ItemIndex);
  FilterGraph1.Active := true;
  // 打开所选的视频输入设备
  with FilterGraph1 as ICaptureGraphBuilder2 do
   // RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter1 as IBaseFilter, nil, VideoWindow1 as IbaseFilter);
     RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter1 as IBaseFilter, SampleGrabber1 as IBaseFilter, VideoWindow1 as IbaseFilter);
   // 显示出来
  FilterGraph1.Play;
end;

procedure TForm1.suiButton1Click(Sender: TObject);  //拍照保存
var
  ABitmap: TBitmap;
  AJpgmap: TJPEGImage;
  photo: string;
begin
  photo :=label3.Caption+'-'+FormatDateTime('hh', Now)+FormatDateTime('nn', Now)+FormatDateTime('ss', Now);
  photo :=label4.Caption+photo+'.jpg';
  label5.Caption:=photo;
 // photo:=ExtractFilePath(Application.ExeName)+'photo\'+photo+'.jpg';
  ABitmap := TBitmap.Create;
  AJpgmap := TJPEGImage.Create;
  try
   // SampleGrabber1.GetBitmap(ABitmap);
    SampleGrabber1.GetBitmap(Image1.Picture.Bitmap);
   // AJpgmap.Assign(ABitmap);
   AJpgmap.Assign(Image1.Picture.Bitmap);
    AJpgmap.SaveToFile(photo);
   Image1.Picture.LoadFromFile(photo);
  finally
    ABitmap.Free;
    AJpgmap.Free;
  end;
end;

上面为程序的为部分代码，摄像头为2个，一个30W最高分辨率为640X480，一个是100W HD最高分辨率为1920X1080



不管我选择哪一个摄像头，拍照保存了图片全部都是640X480


怎么设置为，拍照了时候为摄像头的最高分辨率 ，代码要怎么写，或者，可以自己选择拍照分辨率

[lyhoo163]

将Image中的图像，按新的分辨率复制到别一个Image中，即可。我的代码仅代参考。

procedure TSeleteImageFrm.Button2Click(Sender: TObject);
var MyRect, NewRect: TRect;
    Bmp,NewBmp: TBitmap;
    s1,s2:string;
    W,H,WW,WH:integer;
    k,k1:double;
begin
  TempName:=Edit1.text;
  if (XX2=0) or (YY2=0) then
  begin
    XX1:=0;
    YY1:=0;
    XX2:=Image1.Picture.Graphic.Width;
    YY2:=Image1.Picture.Graphic.Height;
  end;
  Bmp:=TBitmap.Create;
  NewBmp:=TBitmap.Create;
  MyRect := Rect(XX1,YY1,XX2,YY2);
  NewRect := Rect(0,0,XX2-XX1, YY2-YY1);
  Bmp.Width:=XX2-XX1;
  Bmp.Height:=YY2-YY1;
  Bmp.Canvas.CopyRect(NewRect,Image2.Canvas, MyRect);
  case ComboBox1.ItemIndex of
    0: ChangeAnyPixels(Bmp,NewBmp,100,133);
    1: ChangeAnyPixels(Bmp,NewBmp,150,200);
    2: ChangeAnyPixels(Bmp,NewBmp,200,266);
    3: ChangeAnyPixels(Bmp,NewBmp,225,300);
    4: ChangeAnyPixels(Bmp,NewBmp,300,400);
  end;
  NewBMP.SaveToFile(ImagePath+TempName+'.bmp');
  Image1.Picture.Assign(BMP);
  Image2.Picture.Assign(BMP);
  ChangeImageSize;
  XX2:=0;
  YY2:=0;
  Bmp.Free;
  NewBmp.Free;
end;

仅供参考。

[lyhoo163]

这是程序界面。选择分辨率，保存即可。

[linzhen6790]

过来看一看，看有没有大神帮看一下

[linzhen6790]

过来看一看，看有没有大神帮看一下

[npkaida]

引用

视频 总有 www.pegasusimaging.com 怎么去掉

下载含全部源码的控件重新安装DSPACK： DSPACK v2.34 for Delphi7 http://download.csdn.net/detail/npkaida/9647422 DSPack for D10.1 Berlin http://download.csdn.net/detail/npkaida/9647418

[爱凯特的威廉]

视频 总有 www.pegasusimaging.com 怎么去掉

[爱凯特的威廉]

谢谢你的回复，找到原因了，是CAPPRO.EXE 控件导致的，安装时有几个选项不选中就可以了。

[gogusoft]

@lyhoo163 请问你发的那个界面的DEMO在哪里下载啊

[gogusoft]

请问大家图像旋转90度咋实现啊，谢谢