procedure TForm1. FormCreate (Sender: TObject);
Var
I: integer;
The begin
//read the video input devices in the system, the
SysDev:=TSysDevEnum. Create (CLSID_VideoInputDeviceCategory);
If SysDev. CountFilters & gt; 0 then
For I:=0 to SysDev. Do CountFilters - 1
The begin
Listbox1. Items. The Add (SysDev Filters [I] FriendlyName)
end;
end;
procedure TForm1. ListBox1Click (Sender: TObject);//select camera
The begin
FilterGraph1. ClearGraph;
FilterGraph1. Active:=false;
//set the filter for the selected video input device
Filter1. BaseFilter. Moniker:=SysDev GetMoniker (Listbox1. ItemIndex);
FilterGraph1. Active:=true;
//open the selected video input device
With FilterGraph1 as ICaptureGraphBuilder2 do
//the 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);
//display
FilterGraph1. Play;
end;
procedure TForm1. SuiButton1Click (Sender: TObject);//I photograph
Var
ABitmap: TBitmap;
AJpgmap: TJPEGImage;
Photo: the string;
The begin
Photo:=label3 Caption + '-' + FormatDateTime (' hh, Now) + FormatDateTime (' nn, Now) + FormatDateTime (' ss ', Now);
Photo:=label4. Photo Caption + + '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);
The finally
ABitmap. Free;
AJpgmap. Free;
end;
end;
For application for part of the code above, camera for 2, a maximum resolution of 640 x480 30 w, one is 100 w HD a maximum resolution of 1920 x1080
Whatever I choose which a camera, take photos to save the pictures are all 640 x480
how to set to the photo shoot for the highest resolution camera, how to write code, or you can choose your own photo resolution
CodePudding user response:
Come and have a look, look have a great god help have a lookCodePudding user response:
Come and have a look, look have a great god help have a lookCodePudding user response:
Image from the Image, according to the new resolution don't copied to an Image, then, my code is only for reference,procedure TSeleteImageFrm. Button2Click (Sender: TObject);
Var MyRect NewRect: TRect;
Bmp, NewBmp: TBitmap;
S1, s2: string;
W, H, WW, WH: integer;
K, k1: double;
The begin
TempName:=Edit1. Text;
If (XX2=0) or (YY2=0) then
The begin
XX1:=0;
YY1:=0;
XX2:=Image1. Picture. Graphic. Width;
YY2:=Image1. Picture. Graphic. Height;
end;
Bmp:=TBitmap. Create;
NewBmp:=TBitmap. Create;
MyRect:=the Rect (XX1, YY1 XX2, YY2);
NewRect:=the 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, 100133);
1: ChangeAnyPixels (Bmp, NewBmp, 150200);
2: ChangeAnyPixels (Bmp, NewBmp, 200266);
3: ChangeAnyPixels (Bmp, NewBmp, 225300);
4: ChangeAnyPixels (Bmp, NewBmp, 300400);
end;
NewBMP. SaveToFile (ImagePath + TempName + '. BMP ');
Image1. Picture. Assign (BMP);
Image2. Picture. Assign (BMP);
ChangeImageSize;
XX2:=0;
YY2:=0;
Bmp. Free;
NewBmp. Free;
end;
For reference only,
CodePudding user response:
Is this program interface, select the resolution, can be saved,
CodePudding user response:
Video is always www.pegasusimaging.com how take outCodePudding user response: