This question already has answers here:
How to get a snapshot from a webcam with Delphi7 using VFrames(TVideoImage)
(2 answers)
Closed 8 years ago.
I need to find a foolproof way with Delphi XE to take a snapshot using a webcam and save it as a picture file. There are many posts about this but none of them work for me. Either the code won't compile or the image is not created. The best one so far is this one using VFrames. It shows the web cam video perfectly but when I try to save a snapshot to a bmp using the code below the image is blank white. I tried assigning it to a TImage with the same result. Does anyone know why this happens or have a better way to do this?
procedure TForm1.Button2Click(Sender: TObject);
var
cam:TVideoImage;
strlst:TStringList;
BMP:TBitmap;
begin
strlst := TStringList.Create ;
cam :=TVideoImage.Create;
cam.GetListOfDevices(strlst);
cam.VideoStart(strlst.Strings[0]); //specify a cam by number
//get snapshot
BMP := TBitmap.Create;
cam.GetBitmap(BMP);
BMP.SaveToFile('C:\test.bmp');
cam.VideoStop;
BMP.Free;
end;
I Think you should have a look a DirectX and I think you should have a look at this site :
http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample
This page offers a great way to use webcams under windows, its very reliable and allows you to set any cam property. Its all opensource, easy to use and based on native windows DirectX libraries.
Use this sample:
http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample/DirectXDelphiWebcamCapture.rar
This is a directX conversion to pascal made by michael#grizzlymotion.com
add VSample.pas and VFrames.pas to your project
uses VFrames;
procedure TForm6.Button1Click(Sender: TObject);
var
cam:TVideoImage;
strlst:TStringList;
begin
strlst := TStringList.Create ;
cam := TVideoImage.Create;
cam.GetListOfDevices(strlst);
cam.SetDisplayCanvas(PaintBox1.Canvas);
cam.VideoStart(strlst.Strings[0]) ;//specify your cam by number
end;
Or you can have a look at this : http://sourceforge.net/projects/webcam-cap/ it uses pure API calls to AVICAP32.DLL
Related
I have projects developed in Delphi 10 on a laptop with a screen resolution of 96. I am now using Delphi 10.4 Community Edition on a Microsoft Surface with a screen resolution of 201. Is there a function or a settings that automatically converts numerically defined coordinates when scaling an application? To show what I mean I add this code snippet.
procedure TForm1.Button1Click(Sender: TObject);
begin
with Canvas do
begin
MoveTo(0,0);
LineTo(400,250);
MoveTo(0,0);
LineTo(ClientWidth,ClientHeight);
end;
end;
The first line drawn does not scale, the second one obviously does.
May I add:
If I compile the same code on my old laptop with a screen resolution of 96 and then run the exe file on my Surface Laptop with a screen resolution of 201 it scales ok, I was hoping there was a facility somewhere to compile my old programmes on my new computer without having to manually change all the code referring to coordinates x and y.
There's no built-in scaling of coordinates in a TCanvas. You can use this CLASS HELPER:
TYPE
TFormHelper = CLASS HELPER FOR TForm
FUNCTION Scale(Value : INTEGER) : INTEGER;
END;
FUNCTION TFormHelper.Scale(Value : INTEGER) : INTEGER;
BEGIN
Result:=MulDiv(Value,CurrentPPI,Screen.DefaultPixelsPerInch)
END;
Use it as in:
procedure TForm1.Button1Click(Sender: TObject);
begin
with Canvas do
begin
MoveTo(Scale(0),Scale(0)); // Not needed, as 0 scaled is always 0, but... //
LineTo(Scale(400),Scale(250));
MoveTo(0,0);
LineTo(ClientWidth,ClientHeight);
end;
end;
To run my projects developed with Delphi 10 on my new computer with a higher screen resolution, using Delphi 10.4 Community Edition I change the setting
Project Options -> Application -> Manifest -> DPI Awareness to GDI Scaling and it all works like a charm.
I have been asked to correct an issue (not related to this question) in a legacy Delphi program. After fixing some issues with missing components, I am now stuck with some GDI Plus functionality, which stops me from compiling the program. One of the functions where this is used is:
function TDownLoadItem.LoadRawBitmapFromStream(var bm: TBitmap): Boolean;
var
image: TGPBitmap;
begin
Result := False;
if Content.Size = 0 then
exit;
// NOTE: Content is a TMemoryStream, declared globally.
image := GDIPlusHelper.LoadBitmapFromStream(Content); // <== This is where the problem is....
try
bm.Width := image.GetWidth;
bm.Height := image.GetHeight;
with TGPGraphics.Create(bm.Canvas.Handle) do
try
DrawImage(image, 0, 0, image.GetWidth, image.GetHeight);
Result := True;
finally
Free;
end;
finally
image.Free;
end;
end;
I think (not sure) the last Delphi version used was 2006, I am on Delphi Rio 10.3.
Online I have managed to find GDI+ 1.2, but this does not solve the problem. The procedure LoadBitmapFromStream does not exit in these libraries. GDIPlusHelper was apparently renamed to GDIPlusHelpers and most code has changed from classes to interfaces. I suspect an older edition of the GDI Plus libraries were used, but I cannot find these.
Reworking the code would be too complex as it would require Content to be an IStream instead of a TMemoryStream. Also, simply using a TBitmap is not feasible either as other code (not shown) uses functionality specific to TGPBitmap (e.g. RotateFlip).
Any suggestions on how to fix/work around this? Thanks in advance!
For this question please refer to a previous question I asked a while back: Do I need TThreads? If so can I pause, resume and stop them? LU RD answered the question with a provided demo and some comments.
I stopped using Delphi for quite a long time but now I am getting back into it and redoing a project. This project has time consuming operations such as opening a Gif, extracting the frames and then adding those frames (bitmaps) into a TImageList and TListView. This time I actually add the bitmaps directly into a TObjectList, as seen here: How to add and retrieve Bitmaps to and from a TList?
Typically nothing special needs doing here to speed it up as most Gif animations are small, but with medium to large Gifs the application can hang. This is going to get worse though as those bitmaps are going to be modified at runtime using various imaging filters such as grayscale, change hue etc. So I am sure I need multi-threading for this otherwise accessing each bitmap and then manipulating is going to be very slow (as I found out before).
So with that said, I am foolishly trying to adapt (without a clue of what I am doing) some of my procedures to work with the TThread example posted by LU RD I linked to at the top.
I wish I spent a bit more time with the original question to ask for more information but I guess I got sidetracked and moved onto something else, which meant I learned nothing.
Take this snippet from the threading example:
const
cWorkLoopMax = 500;
function TForm1.HeavyWork: boolean; // True when ready
var
i, j: integer;
begin
j := 0;
for i := 0 to 10000000 do
Inc(j);
Inc(workLoopIx);
Result := (workLoopIx >= cWorkLoopMax);
end;
For a start I have no idea what cWorkLoopMax is for, and why its value is set to 500?
Secondly I guess the HeavyWork procedure is just a sample, which runs in a loop a 10000000 times whilst incrementing the j variable?
Then we have the workLoopIx which I am unsure what is for? Maybe something to do with the position within the thread maybe?
So, here I have my current code (no threading) which handles opening the Gif and adding to the TListView and TImageList. The procedures I use are in another unit, if needed I will post it also, but this is what I use inside a TAction (actOpen):
if OpenPictureDialog.Execute then
begin
Screen.Cursor := crHourGlass;
try
BitmapCollection.AddFromGif(OpenPictureDialog.FileName, ImageList1);
ListView1.Items.BeginUpdate;
try
ListView1.Items.Clear;
for I := 0 to BitmapCollection.BitmapList.Count - 1 do
begin
with ListView1.Items.Add do
begin
Caption := 'bitmap' + IntToStr(I+1);
ImageIndex := I;
end;
end;
finally
ListView1.Items.EndUpdate;
end;
finally
Screen.Cursor := crDefault;
end;
end;
What I dont understand is how to put that into a thread procedure, such as HeavyWork? I just created a new one called Job_Open and did this:
procedure TForm1.actOpenExecute(Sender: TObject);
begin
if OpenPictureDialog.Execute then
begin
if not Assigned(MyThread) then
begin
workLoopIx := 0;
btnStartTask.Enabled := false;
btnPauseResume.Enabled := true;
btnCancelTask.Enabled := true;
MyThread := TWorkerThread.Create(Self.Handle, WM_MyProgress, Job_Open);
end;
end;
end;
function TForm1.Job_Open: boolean;
var
I: Integer;
begin
BitmapCollection.AddFromGif(OpenPictureDialog.FileName, ImageList1);
for I := 0 to BitmapCollection.BitmapList.Count - 1 do
begin
with ListView1.Items.Add do
begin
Caption := 'bitmap' + IntToStr(I+1);
ImageIndex := I;
end;
Inc(workLoopIx);
end;
Result := (workLoopIx >= BitmapCollection.BitmapList.Count);// cWorkLoopMax);
end;
This is clearly not right, the performance is slower and I am getting all kind of errors such as Invalid Handle.
I would be extremely grateful if someone could take some time to explain my comments, what I am doing wrong and what I should be doing instead, updated code and comments in source are welcome but I am hoping to learn a bit more of what is going on with the code ideally.
In a perfect world if there is a library of sorts that exists out there that is easy to use then that would be a massive help if I cannot understand what is happening above. Is there such a library that can do something like:
procedure DoSomething;
begin
BeginThreading();
HeavyWork;
StopThreading();
end;
Thanks in advance, and apologies for the lengthy post.
DISCLAIMER: While my answer is not an answer directly to your question it is a psobile solution to your problem.
After reading your questions I have one question to you:
Are you applying same image graphical effects on all ImageList images?
If you are then I must say that you started on working on your problem from wrong approach.
First you need to know that Imagelist doesen't store all those images seperately but that it is storing them all in same verry wide image. So when you read any ImageList image internally ImageList creates output bitmap and then uses Canvas.CopyRect which is quite. When you save image to image list it internally uses Canvas.Draw.
So when you do this many times you create lots of unnecessary data movment.
So instead of your approach where you work on seperate images I recomend you work on ImageLists internal image whose handle you can get using ImageList.GetImageBitmap. This will alow you to apply same graphical effect on all ImageList images at once. And if you don't need to apply graphical effects to all ImageList images I bet you can modify your mage processing method to work only on parts of the image.
In order to learn more about ImageList I recomed you read its documentation:
Image list explanation: http://docwiki.embarcadero.com/Libraries/XE6/en/Vcl.Controls.TImageList
Image list GetImageBitmap explanation
http://docwiki.embarcadero.com/Libraries/XE6/en/Vcl.ImgList.TCustomImageList.GetImageBitmap
WIA 2 on Windows 7 doesn't detect my camera while WIA 1 on Windows XP detects it.
I try to run my program as admin.
My camera is :
Asus usb2 webcam.
Delphi return the message:
(like this) not available any wia devices from specified type
or
Access Violation at address ...... in module ......
I use this code:
procedure TForm1.Button9Click(Sender: TObject);
Const
wiaFormatBMP ='{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}';
var
CommonDlg: ICommonDialog;
AImage: IImageFile;
ImagePath: String;
DeviceManager1 :iDeviceManager;
begin
CommonDlg := createOleObject('WIA.CommonDialog') as ICommonDialog;
DeviceManager1 := createOleObject('WIA.DeviceManager') as iDeviceManager;
edit1.Text:= inttostr( DeviceManager1.DeviceInfos.Count);
AImage := CommonDlg.ShowAcquireImage(UnspecifiedDeviceType,UnspecifiedIntent,
MaximizeQuality,wiaFormatBMP,true,False,True);
ImagePath := 'C:\temp\test.bmp';
AImage.SaveFile(ImagePath);
end;
I recently had a similar experience with WIA and Win7.
What I eventually ended up using was a DirectX solution.
Delphi Basics - DirectX webcam capture
I don't remember how I originally found this project, but under Win7 it just works even with older webcams that I found lying around the office.
I recommend you look at Demo3 in the download file as that had the best, simple, example of what I needed. YMMV.
(Edit) My WIA problem extended from the fact that the webcam maker did not support WIA or Twain under Win7.
First of all: this is not a duplicate of Delphi and SAPI. I have a specific problem with the "SAPI in Delphi" subject.
I have used the excellent Import Type-Library guide in Delphi 2009 to get a TSpVoice component in the component palette. This works great. With
var
SpVoice: TSpVoice;
I can write
SpVoice.Speak('This is an example.', 1);
to get asynchronous audio output.
First question
According to the documentation, I would be able to write
SpVoice.Speak('This is an example.', 0);
to get synchronous audio output, but instead I get an EZeroDivide exception. Why's that?
Second question
But more importantly, I would like to be able to create the SpVoice object dynamically (I think this is called to "late-bind" the SpVoice object), partly because only a very small fraction of all sessions of my app will use it, and partly because I do not want to assume the existance of the SAPI server on the end-user's system.
To this end, I tried
procedure TForm1.FormClick(Sender: TObject);
var
SpVoice: Variant;
begin
SpVoice := CreateOleObject('SAPI.SpVoice');
SpVoice.Speak('this is a test', 0);
end;
which apparently does nothing at all! (Replacing the 0 with 1 gives me the EZeroDivide exception.)
Disclaimer
I am rather new to COM/OLE automation. I am sorry for any ignorance or stupidity shown by me in this post...
Update
For the benefit of everyone encountering the same problem as I did, the video by François explained there is a bug in SAPI/Windows (some incompatibility somewhere), which makes the following code raise the EZeroDivide exception:
procedure TForm1.FormClick(Sender: TObject);
var
SpVoice: variant;
begin
SpVoice := CreateOleObject('SAPI.SpVoice');
SpVoice.Speak('This is a text.');
end;
The solution, as presented by the video, is to alter the FPU control word:
procedure TForm1.FormClick(Sender: TObject);
var
SpVoice: variant;
SavedCW: Word;
begin
SpVoice := CreateOleObject('SAPI.SpVoice');
SavedCW := Get8087CW;
Set8087CW(SavedCW or $4);
SpVoice.Speak('This is a text.');
Set8087CW(SavedCW);
end;
And, in addition, if you want to play a sound asynchronously, then you have to make sure that the player doesn't go out of scope!
You may find interesting to see this CodeRage 4 session on "Speech Enabling Delphi Applications (zip)"
You'll get the "how-to" you're looking for...
(and I guess you are on Vista or + as the the zero divide did not happend on XP)
I was having the same problem in Delphi XE2. The Set8087CW(SavedCW or $4) solution presented in the question did not work for me. It merely replaced the division by zero exception with another floating point exception.
What did work for me is this:
SavedCW := Get8087CW;
SetFPUExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]);
SpVoice.Speak('All floating point exceptions disabled!', 0);
Set8087CW(SavedCW);