//------------------------------------------
// WEBCAM DirectShow
// Модуль доступа к WEB камере средствами DirectShow-DSPack
// Author: Бадло Сергей Григорьевич
// H-page: http://raxp.radioliga.com
// Cистемные требования: win32 + DSPACK
//------------------------------------------

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls, Menus,
  DSUtil,DSPack, DirectShow9;


type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Timer1: TTimer;
    Panel2: TPanel;
    ComboBox1: TComboBox;
    Button1: TButton;
    pm: TPopupMenu;
    close1: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    Label1: TLabel;
    Memo1: TMemo;
    FilterGraph: TFilterGraph;
    Filter: TFilter;
    SampleGrabber: TSampleGrabber;
    VideoWindow: TVideoWindow;

    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure N1Click(Sender: TObject);
    procedure close1Click(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);

  private
    { Private declarations }
    procedure seeh;

    //нажатие средней кнопки-
    procedure wm(var Msg:TMsg; var h:boolean);
    procedure iconmsg(var Mess:TMessage);message TRAY_CALLBACK;
    procedure CreateParams(VAR Params: TCreateParams); override;

  public
  end;

var
  Form1: TForm1;
  //
  fl_see,fl_max: boolean;
  glx,gly: integer;
  OrgP,OrgXY: tPoint;
  //
  VideoDevice: TSysDevEnum;

implementation
{$R *.dfm}

// СЕРВИС-МОДУЛЬ =============================================================

//--- средняя кнопка
procedure Tform1.wm(var Msg:TMsg; var h:boolean);
begin
 if Msg.message = WM_MBUTTONDOWN then N1.OnClick(NIL);
end;

//--- управление окном
procedure Tform1.CreateParams(VAR Params: TCreateParams);
begin
 Inherited CreateParams(Params);
 WITH Params DO
  Style:= (Style OR WS_POPUP) AND NOT WS_DLGFRAME
end;

procedure tform1.seeh;
begin
 fl_see:= not fl_see;
 if not fl_see then begin
  show; setforegroundwindow(Handle)
 end else hide
end;

//--- меню и трей-бар
procedure Tform1.iconmsg(var Mess:TMessage);
var Mouse: TMouse;
begin
 case Mess.lParam of
  WM_LBUTTONDBLCLK: seeh;
  WM_LBUTTONDOWN  : seeh;
  WM_MBUTTONDOWN  : ;//n3.OnClick(nil);
  WM_RBUTTONUP: begin
                 SetForegroundWindow(form1.Handle);
                 pm.Popup(Mouse.CursorPos.x, Mouse.CursorPos.y)
                end;
 end
end;


procedure TForm1.close1Click(Sender: TObject);
begin
 close
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 OrgP := Point(Left, Top);
 OrgXY:= ClientToScreen(Point(X, Y))
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var _p: TPoint;
begin
 APPLICATION.ProcessMessages;
 if (Shift = [ssLeft])and(not fl_max) then
  begin
   _p:= ClientToScreen(Point(X, Y));
   SetBounds(OrgP.X + (_p.X - OrgXY.X), OrgP.Y + (_p.Y - OrgXY.Y), Width, Height)
  end
end;




procedure TForm1.N1Click(Sender: TObject);
begin
 fl_max:= not fl_max;
 if fl_max then begin
  glx:= left; gly:= top;
  WindowState:= wsMaximized
 end else begin
  WindowState:= wsnormal;
  left:= glx; top:= gly
 end
end;
// END СЕРВИС-МОДУЛЬ ==========================================================


// ИНИЦИАЛИЗАЦИЯ ==============================================================
procedure TForm1.FormCreate(Sender: TObject);
var
 i: integer;
begin
 //SetWindowLong(Application.Handle,GWL_EXSTYLE,GetWindowLong(Application.Handle, GWL_EXSTYLE) or
 // not WS_EX_APPWINDOW);
 //set_tn(0,0,'WEBCAM');
 Application.OnMessage:= wm;
 DoubleBuffered:= true;

 // перечисляем текущие видеоустройства
 VideoDevice:= TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
 if VideoDevice.CountFilters > 0 then
  for i:= 0 to VideoDevice.CountFilters - 1 do
   ComboBox1.Items.Add(VideoDevice.Filters[i].FriendlyName);

 with videowindow do begin
  parent:= panel1;
  align:= alclient;
  onmousedown:= FormMouseDown;
  onmousemove:= FormMouseMove
 end;

 // устанавливаем активным первое найденное устр-во захвата
 ComboBox1.ItemIndex:= 0;
 ComboBox1Change(nil)
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 VideoDevice.Free;
 FilterGraph.ClearGraph;
 FilterGraph.Active:= false
end;


// смена устройства видеозахвата
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
  FilterGraph.ClearGraph;
  FilterGraph.Active := false;

  // текущее устройство видеозахвата
  Filter.BaseFilter.Moniker:= VideoDevice.GetMoniker(ComboBox1.ItemIndex);

  FilterGraph.Active := true;
  with FilterGraph as ICaptureGraphBuilder2 do
    RenderStream(nil, nil, Filter as IBaseFilter, SampleGrabber as IBaseFilter, VideoWindow as IbaseFilter);
  FilterGraph.Play;
end;

// стоп видеозахвата
procedure TForm1.Button1Click(Sender: TObject);
begin
 FilterGraph.Stop;
 combobox1.Text:= 'выберите устройство видеозахвата...';
 label1.Caption:= '0'
end;
// END ИНИЦИАЛИЗАЦИЯ ==========================================================




function GetDosOutput(const CommandLine,Parametrs:string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of Char;
  BytesRead: Cardinal;
  WorkDir, Line: String;
begin
  Application.ProcessMessages;
  with SA do
    begin
      nLength := SizeOf(SA);
      bInheritHandle := True;
      lpSecurityDescriptor := nil;
    end;
  // создаём пайп для перенаправления стандартного вывода
  CreatePipe(StdOutPipeRead,  // дескриптор чтения
             StdOutPipeWrite, // дескриптор записи
             @SA,              // аттрибуты безопасности
             0                // количество байт принятых для пайпа - 0 по умолчанию
             );
  try
    // Создаём дочерний процесс, используя StdOutPipeWrite в качестве стандартного вывода,
    // а так же проверяем, чтобы он не показывался на экране.
    with SI do
      begin
        FillChar(SI, SizeOf(SI), 0);
        cb := SizeOf(SI);
        dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
        wShowWindow := SW_HIDE;
        hStdInput := GetStdHandle(STD_INPUT_HANDLE); // стандартный ввод не перенаправляем
        hStdOutput := StdOutPipeWrite;
        hStdError := StdOutPipeWrite;
      end;
    // Запускаем компилятор из командной строки
    WorkDir := ExtractFilePath(CommandLine);
    WasOK := CreateProcess(nil,
                           PChar(CommandLine+' '+Parametrs),
                           nil,
                           nil,
                           True,
                           0,
                           nil,
                           PChar(WorkDir),
                           SI,
                           PI);
    // Теперь, когда дескриптор получен, для безопасности закрываем запись.
    // Нам не нужно, чтобы произошло случайное чтение или запись.
    CloseHandle(StdOutPipeWrite);
    // если процесс может быть создан, то дескриптор, это его вывод
    if not WasOK then //raise Exception.Create('Could not execute command line!')
    else
      try
        // получаем весь вывод до тех пор, пока DOS-приложение не будет завершено
        Line := '';
        repeat
          Application.ProcessMessages;
          // читаем блок символов (могут содержать возвраты каретки и переводы строки)
          WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
          // есть ли что-нибудь ещё для чтения?
          if BytesRead > 0 then
            begin
              // завершаем буфер PChar-ом
              Buffer[BytesRead] := #0;
              // добавляем буфер в общий вывод
              Line := Line + Buffer;
            end;
        until not WasOK or (BytesRead = 0);
        // ждём, пока завершится консольное приложение
        WaitForSingleObject(PI.hProcess, INFINITE);
      finally
        // Закрываем все оставшиеся дескрипторы
        CloseHandle(PI.hThread);
        CloseHandle(PI.hProcess);
      end;
  finally
    result:= utf8toansi(Line); // перекодируем UTF-8 в ANSI
    CloseHandle(StdOutPipeRead);
  end;
end;

// ТАЙМЕР ВЫБОРКИ ИЗОБРАЖЕНИЯ ДЛЯ РАСПОЗНАВАНИЯ ===============================
procedure TForm1.Timer1Timer(Sender: TObject);
var b: tbitmap;
    dir: pansichar;
begin
 timer1.Enabled:= false;
 dir:= pansichar(extractfilepath(paramstr(0)));

 // граб кадра с устройства видеозахвата
 b:= TBitmap.Create;
 SampleGrabber.GetBitmap(b);
 b.SaveToFile('grab.bmp');
 b.Free;
 
 // запуск консоли и перехват через Pipes
 if fileexists('grab.bmp') then
  memo1.Text:= GetDosOutput(dir+'zbarimg.exe', 'grab.bmp');

 timer1.Enabled:= true
end;


end.
