Ir al contenido


Foto

MiniWebCam


  • Por favor identifícate para responder
7 respuestas en este tema

#1 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 02 mayo 2016 - 02:30

A mi hijo le ha dado por grabar video capturando la pantalla del PC y me preguntó si se podía colocar su imagen, capturada por una webcam, en un lugar de la pantalla mientras grababa. Por supuesto le dije que era posible y me puse a escribir el programita que os presento.

Se trata de una pequeña aplicación que coloca en pantalla nuestra imagen, bien en un recuadro rectangular o redondo, a elegir en un PopUpMenu, asi como una variedad de tamaños. La imagen se puede recolocar por toda la pantalla.

Se basa en el manejo que proporciona la API de Windows para estos menesteres que básicamente se usa con mensajes a una ventana especial creada con la API capCreateCaptureWindow. Para que el formulario principal pueda capturar mensajes a esa ventana, he hecho un subclassing, con esto reenvío los mensajes al formulario y podemos activar el PopUpMenu  y conseguir el movimiento de la misma arrastrándola con el ratón.

El código es como sigue:


delphi
  1. var
  2. OldWindowProc: Pointer;
  3.  
  4. function NewWindowProc(hWnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall;
  5. var
  6. hParent: THANDLE;
  7. begin
  8. hParent:= GetParent(hWnd);
  9. if (Msg = WM_LBUTTONDOWN) or (Msg = WM_RBUTTONDOWN) then
  10. CallWindowProc(Pointer(GetWindowLong(hParent, GWL_WNDPROC)), hParent, Msg, WParam, LParam);
  11. Result:= CallWindowProc(OldWindowProc, hWnd, Msg, WParam, lParam);
  12. end;
  13.  
  14. procedure TForm1.FormCreate(Sender: TObject);
  15. begin
  16. Round:= false;
  17. Height:= 120;
  18. Width:= MulDiv(Height, 4, 3);
  19. hWndC := capCreateCaptureWindowA('Mi Ventana de captura', WS_CHILD or WS_VISIBLE ,0, 0, Width, Height, Handle, 0);
  20. if hWndC <> 0 then
  21. begin
  22. OldWindowProc:= Pointer(SetWindowLong(hWndC, GWL_WNDPROC, LongInt(@NewWindowProc)));
  23. SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
  24. SendMessage(hWndC, WM_CAP_SET_SCALE, 1, 0);
  25. SendMessage(hWndC, WM_CAP_SET_PREVIEWRATE, 40, 0);
  26. SendMessage(hWndC, WM_CAP_SET_OVERLAY, 1, 0);
  27. SendMessage(hWndC, WM_CAP_SET_PREVIEW, 1, 0);
  28. // SetResolution(320, 240);
  29. SetResolution(640, 480);
  30. // SetResolution(800, 600);
  31. end;
  32. end;
  33.  
  34. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  35. begin
  36. if hWndC <> 0 then
  37. SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
  38. end;
  39.  
  40. procedure TForm1.Exit1Click(Sender: TObject);
  41. begin
  42. Close;
  43. end;
  44.  
  45. procedure TForm1.SetResolution(Width, Height: integer);
  46. var
  47. bi: BITMAPINFO;
  48. begin
  49. SendMessage(hWndC, WM_CAP_GET_VIDEOFORMAT, sizeof(bi), Cardinal(@bi));
  50. bi.bmiHeader.biWidth:= Width;
  51. bi.bmiHeader.biHeight:= Height;
  52.  
  53. if SendMessage(hWndC, WM_CAP_SET_VIDEOFORMAT, sizeof(bi), Cardinal(@bi)) <> 0 then
  54. begin
  55. SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
  56. SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
  57. end;
  58. end;
  59.  
  60. procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  61. Shift: TShiftState; X, Y: Integer);
  62. begin
  63. if Button = mbLeft then
  64. begin
  65. ReleaseCapture;
  66. Perform(WM_SYSCOMMAND, $F012, 0);
  67. end
  68. else if Button = mbRight then
  69. PopupMenu1.Popup(Left+X, Top+Y);
  70. end;
  71.  
  72. procedure TForm1.Round1Click(Sender: TObject);
  73. var
  74. Rgn: HRGN;
  75. Rect: TRect;
  76. begin
  77. Round:= true;
  78. Rect:= ClientRect;
  79. Rgn:= CreateRoundRectRgn(Rect.left, Rect.top, Rect.bottom, Rect.bottom, Rect.bottom, Rect.bottom);
  80. SetWindowRgn(Handle, Rgn, true);
  81. end;
  82.  
  83. procedure TForm1.Rectangle1Click(Sender: TObject);
  84. var
  85. Rgn: HRGN;
  86. Rect: TRect;
  87. begin
  88. Round:= false;
  89. Rect:= ClientRect;
  90. Rgn:= CreateRectRgn(Rect.left, Rect.top, Rect.Right, Rect.Bottom);
  91. SetWindowRgn(Handle, Rgn, true);
  92. end;
  93.  
  94. procedure TForm1.SizeClick(Sender: TObject);
  95. var
  96. Item: TMenuItem;
  97. begin
  98. Item:= TMenuItem(Sender);
  99. Height:= StrToInt(StringReplace(Item.Caption, '&', '', [rfReplaceAll]));
  100. Width:= MulDiv(Height, 4, 3);
  101. if Round then Round1Click(self)
  102. else Rectangle1Click(self);
  103. SetWindowPos(hWndC, 0, 0, 0, Width, Height, SWP_SHOWWINDOW or SWP_NOZORDER);
  104. end;

 
Subo el proyecto completo y el binario compilado.

Espero que sea de utilidad.


Saludos.

Archivos adjuntos


  • 2

#2 enecumene

enecumene

    Webmaster

  • Administrador
  • 7.419 mensajes
  • LocationRepública Dominicana

Escrito 02 mayo 2016 - 08:48

:o
  • 0

#3 egostar

egostar

    missing my father, I love my mother.

  • Administrador
  • 14.446 mensajes
  • LocationMéxico

Escrito 02 mayo 2016 - 10:11

Que interesante y sobre todo que buen padre eres :)

 

Saludos


  • 1

#4 dandyuno

dandyuno

    Newbie

  • Miembros
  • Pip
  • 3 mensajes

Escrito 23 mayo 2019 - 04:27

solo sale la imagen en negro ¿que ocurre?


  • 0

#5 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 23 mayo 2019 - 01:44

solo sale la imagen en negro ¿que ocurre?

 

Probablemente tengas abierta otra aplicación que conecte con la webcam antes de abrir MiniWebCam. en ese caso prevalece la primera conexión. Cierra todas las aplicaciones que puedan estar usando la webcam. 

 

Saludos.


  • 0

#6 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 23 mayo 2019 - 01:57

Una forma de desconectar a lo bruto cualquier ventana de captura de la webcam puede ser usar este código antes de crear la nuestra:


delphi
  1. function EnumWindowsProc(Handle: Thandle; lParam: LPARAM): BOOL; stdcall;
  2. var
  3.   Buffer: ShortString;
  4. begin
  5.   Result:= true;
  6.   GetClassName(Handle, @Buffer[0], 255);
  7.   if lstrcmpiA(@Buffer[0], 'ClsCapWin') = 0 then
  8.     PostMessage(Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0)
  9.   else
  10.     EnumChildWindows(Handle, @EnumWindowsProc, 0);
  11. end;

Y se usaría así:


delphi
  1. // Desconecta otra App que use la WebCam
  2. EnumWindows(@EnumWindowsProc, 0);

Ejemplo en el código de MiniWebCam:


delphi
  1. procedure TForm1.FormCreate(Sender: TObject);
  2. begin
  3. Round:= false;
  4. Height:= 120;
  5. Width:= MulDiv(Height, 4, 3);
  6. // Desconecta otra App que use la WebCam
  7. EnumWindows(@EnumWindowsProc, 0);
  8.  
  9. hWndC := capCreateCaptureWindowA('Mi Ventana de captura', WS_CHILD or WS_VISIBLE ,0, 0, Width, Height, Handle, 0);
  10. if hWndC <> 0 then
  11. begin
  12. OldWindowProc:= Pointer(SetWindowLong(hWndC, GWL_WNDPROC, LongInt(@NewWindowProc)));
  13. SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
  14. .......

Saludos.


  • 1

#7 verovegah23

verovegah23

    Newbie

  • Miembros
  • Pip
  • 1 mensajes

Escrito 21 agosto 2019 - 04:23

Agregué lo último al código para cerrar todas las aplicaciones que tuvieran la cámara abierta y ni siquiera me ejecuta el exe al mandar llamar a esa Function, que podría ser??


  • 0

#8 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 22 agosto 2019 - 09:18

Agregué lo último al código para cerrar todas las aplicaciones que tuvieran la cámara abierta y ni siquiera me ejecuta el exe al mandar llamar a esa Function, que podría ser??

El código expuesto aquí busca en todas las ventanas y ventanas hijas de todas las aplicaciones tratando de localizar las de la clase "ClsCapWin". Este es el tipo de ventana para captura de webcam. Al encontrarla la desconecta. Esto puede llevar un tiempo que de la sensación de bloqueo de la app. Si haces cambios en EnumWindowsProc debes hacerlos bien para evitar un bloqueo real.

 

El método descrito es válido para casi todas las app que usen webcam pero no funcionará en navegadores que hagan uso de la misma.

 

Saludos.


  • 0




IP.Board spam blocked by CleanTalk.