Последние записи
- Перенести программу из Delphi в Lazarus
- Определить текущую ОС
- Автоматическая смена языка (раскладки клавиатуры)
- Сравнение языков на массивах. Часть 2
- wprintf как напечатать кириллицу
- Взаимодействие через командную строку
- Сравнение языков на массивах. Часть 1
- Сравнение языков по скорости
- Чтение огромных xml-файлов
- Как в Python+Selenium webdriver открыть новую вкладку в уже открытом браузере?
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
23rd
Мар
Фото с вебкамеры в Delphi
Posted by obzor under Delphi
Дайте пример делания фото с вебкамеры, предварительно выбрав нужное устройство. К примеру если на компе 2 вебки, нужно их отобразить, и потом выбрать 1 из них. Желательно сделать именно фотографию, без записи видео.
перечисление камер
function TForm2.go: HResult;
var
enum : ICreateDevEnum;
eMon : IEnumMoniker;
monAr : array of IMoniker;
pMoniker : IMoniker;
DeviceName:OleVariant;
PropertyName:IPropertyBag;
begin
Result:=CoCreateInstance(CLSID_SystemDeviceEnum, NIL, CLSCTX_INPROC_SERVER,
IID_ICreateDevEnum, Enum);
if Result<>S_OK then EXIT;
Result:=Enum.CreateClassEnumerator(CLSID_videoInputDeviceCategory, eMon, 0);
if FAILED(Result) then EXIT;
setlength(monAr,0);
while (S_OK=emon.Next(1,pMoniker,Nil)) do
begin
setlength(monAr,length(monAr)+1);
monAr[length(monAr)-1]:=pMoniker;
Result:=pMoniker.BindToStorage(NIL, NIL, IPropertyBag, PropertyName);
if FAILED(Result) then Continue;
Result:=PropertyName.Read('FriendlyName', DeviceName, NIL);
if FAILED(Result) then Continue;
ListBox1.Items.Add(DeviceName);
end;
end;
каждый моникер в массиве monAr соответствует камере. Выбираем нужную и делаем:
var
fCamera : IBaseFilter;
Result := monAr[n].BindToObject(nil,nil,IID_IBaseFilter,fCamera);
потом ставим fCamera первым в цепочку Графа фильтров.
Далее:
pGrabber: ISampleGrabber = nil;
fGrabber : IBaseFilter = nil;
CoCreateInstance(CLSID_SampleGrabber,nil,CLSCTX_INPROC,
IID_IBaseFilter,fGrabber);
Result := pGraphBuilder.AddFilter(fGrabber,'Sample Grabber');
if Result = s_ok then
begin
fGrabber.QueryInterface(IID_ISampleGrabber,pGrabber);
ZeroMemory(@DesiredMT,SizeOf(DesiredMT));
DesiredMT.majortype := MEDIATYPE_Video;
DesiredMT.subtype := MEDIASUBTYPE_RGB24;
DesiredMT.formattype := FORMAT_VideoInfo;
Result := pGrabber.SetMediaType(DesiredMT);
if Result = s_ok then
begin
pGrabber.SetOneShot(False);
pGrabber.SetBufferSamples(True);
end else
begin
//error
Exit;
end;
pCaptureGraphBuilder.RenderStream(@pin_category_preview,@mediatype_video,
FVideoCaptureFilter,fGrabber,nil);
pCaptureGraphBuilder.RenderStream(@pin_category_preview,@mediatype_audio,
fAudioCaptureFilter,nil,nil);
end;
//процедура снятия скриншота
//граф должен быть на паузе!!!!
function MakeScreenshot(var bmp: TBitmap; var ErrorCode: Integer):Boolean;
const
nl = #13#10;
var
BufferSize : Integer;
vih : TVideoInfoHeader;
mt : TAMMediaType;
BMPInfo : TBitmapInfo;
Buffer : Pointer;
tmp : array of Byte;
hr : HRESULT;
hbmp : hbitmap;
Begin
Result := False;
ErrorCode := -1;
hr := pGrabber.GetCurrentBuffer(BufferSize,nil);
ZeroMemory(@mt,SizeOf(tammediatype));
hr := pGrabber.GetConnectedMediaType(mt);
vih := tvideoinfoheader(mt.pbFormat^);
ZeroMemory(@bmpinfo,SizeOf(tbitmapinfo));
CopyMemory(@bmpinfo.bmiheader,@vih.bmiheader,SizeOf(tbitmapinfoheader));
Buffer := nil;
hbmp := CreateDIBSection(0,BMPInfo,DIB_PAL_COLORS,Buffer,0,0);
case hbmp of
0:
begin
MoFreeMediaType(@mt);
{ MessageBox(form1,PChar('...!'+nl+'... HBMP = 0'),
PChar('...!'), MB_ICONERROR);}
ErrorCode := 0;
Exit;
end;
ERROR_INVALID_PARAMETER:
begin
MoFreeMediaType(@mt);
{ MessageBox(form1,PChar('...!'+nl+
'...: ERROR_INVALID_PARAMETER'),
pchar('...!'), MB_ICONERROR);}
ErrorCode := ERROR_INVALID_PARAMETER;
Exit;
end;
end;
bmp.Handle := hbmp;
SetLength(tmp,BufferSize);
pGrabber.GetCurrentBuffer(BufferSize,@tmp[0]);
CopyMemory(Buffer,@tmp[0],mt.lSampleSize);
SetLength(tmp,0);
MoFreeMediaType(@mt);
Result := True;
end;
кнопка
pMediaControl.Pause;
bmp := TBitmap.Create;
if MakeScreenshot(bmp,n) then
begin
fn := FormatDateTime('"C:\"yyyy-mm-dd, hh-mm-ss".bmp"',Now);
bmp.SaveToFile(fn);
end;
bmp.Free;
pMediaControl.Run;
В этот код надо добавить обработчики возможных ошибок. Проверяйте возвращаемый результат каждого метода и функции.
Похожие статьи
Купить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
пеллетные котлы
Пеллетный котел Emtas
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)