uso de web cam en vfp

Este es un programa para usar la web-cam desde un formulario de visual foxpro (vfp).

noesmio el codigo, me lo paso un amigo- Nexis Mejía.

Espero les sirva y lo usen.

ATT. luis lagos amaya

LOCAL oForm
oForm = CREATEOBJECT("Tform")
oForm.show(1)
return

DEFINE CLASS Tform As Form
#DEFINE WM_CAP_START 0x0400
#DEFINE WM_CAP_DRIVER_CONNECT (WM_CAP_START+10)
#DEFINE WM_CAP_DRIVER_DISCONNECT (WM_CAP_START+11)
#DEFINE WM_CAP_DRIVER_GET_CAPS (WM_CAP_START+14)
#DEFINE WM_CAP_SET_PREVIEW (WM_CAP_START+50)
#DEFINE WM_CAP_SET_OVERLAY (WM_CAP_START+51)
#DEFINE WM_CAP_SET_PREVIEWRATE (WM_CAP_START+52)
#DEFINE WM_CAP_GET_STATUS (WM_CAP_START+54)
#DEFINE WM_CAP_GRAB_FRAME (WM_CAP_START+60)

*Width=540 && para poner imagenes del click.
Width=340
Height=310
Autocenter=.T.
Caption="Captura de Foto del Interno"
MinButton=.F.
MaxButton=.F.
hWindow=0
hCapture=0
capWidth=0
capHeight=0
capOverlay=0

ADD OBJECT cmdGetFrame As CommandButton WITH Default=.T.,;
Left=10, Top=264, Height=27, Width=90, Caption="Tomar Foto ", ;
Enabled=.F.

Add Object cmdPreview As CommandButton With Default=.T., Visible=.f.,;
Left=100, Top=264, Height=27, Width=120, Caption="Video",;
Enabled=.t.

ADD OBJECT cmdClose As CommandButton WITH Cancel=.T., enabled=.f.,;
Left=202, Top=264, Height=27, Width=130, Caption="Salir"

PROCEDURE Activate
IF THIS.hWindow = 0
DECLARE INTEGER GetFocus IN user32
THIS.hWindow = GetFocus()
THIS.CreateCaptureWindow
THIS.DriverConnect
ENDIF

PROCEDURE Destroy
THIS.ReleaseCaptureWindow
*!* DO FORM entradam.scx
PROCEDURE init
*_screen.Visible=.f.



PROCEDURE cmdClose.Click
THIS.Destroy
ThisForm.Release

PROCEDURE cmdGetFrame.Click
thisform.cmdClose.enabled=.t.
ThisForm.GetFrame

PROCEDURE cmdPreview.Click
ThisForm.StartPreview

PROCEDURE GetFrame
#DEFINE WM_CAP_FILE_SAVEDIB (WM_CAP_START + 25)
LOCAL lcFile
SET DEFAULT TO SYS(5) + CURDIR() && guarda la foto en donde se ejecuta el prg
lnombrefoto="Perfil"
lcFile = lnombrefoto + '.JPG'
THIS.msg(WM_CAP_GRAB_FRAME, 0,0)
THIS.msg(WM_CAP_FILE_SAVEDIB, 0, lcFile,1)

PROCEDURE CreateCaptureWindow
#DEFINE WS_CHILD 0x40000000
#DEFINE WS_VISIBLE 0x10000000

DECLARE INTEGER capCreateCaptureWindow IN avicap32;
STRING lpszWindowName, LONG dwStyle,;
INTEGER x, INTEGER y,;
INTEGER nWidth, INTEGER nHeight,;
INTEGER hParent, INTEGER nID

THIS.hCapture = capCreateCaptureWindow("",;
WS_CHILD+WS_VISIBLE,;
10,8,320,240, THIS.hWindow, 1)

PROCEDURE DriverConnect
THIS.msg(WM_CAP_DRIVER_CONNECT, 0,0)
IF THIS.IsCaptureConnected()
THIS.GetCaptureDimensions
STORE .T. TO THIS.cmdGetFrame.Enabled,;
THIS.cmdPreview.Enabled
this.cmdPreview.Click
ELSE
THIS.Caption = THIS.Caption + ": failed to connect"
ENDIF

PROCEDURE DriverDisconnect
THIS.msg(WM_CAP_DRIVER_DISCONNECT, 0,0)

PROCEDURE ReleaseCaptureWindow
IF THIS.hCapture <> 0
THIS.DriverDisconnect
DECLARE INTEGER DestroyWindow IN user32 INTEGER hWnd
= DestroyWindow(THIS.hCapture)
THIS.hCapture = 0
thisform.Release
ENDIF

PROCEDURE msg(msg, wParam, lParam, nMode)
IF THIS.hCapture = 0
RETURN
ENDIF

IF VARTYPE(nMode) <> "N" Or nMode=0
DECLARE INTEGER SendMessage IN user32;
INTEGER hWnd, INTEGER Msg,;
INTEGER wParam, INTEGER lParam
= SendMessage(THIS.hCapture, msg, wParam, lParam)
ELSE
DECLARE INTEGER SendMessage IN user32;
INTEGER hWnd, INTEGER Msg,;
INTEGER wParam, STRING @lParam
= SendMessage(THIS.hCapture, msg, wParam, @lParam)
ENDIF

FUNCTION IsCaptureConnected
* analyzing fCaptureInitialized member of the CAPDRIVERCAPS structure
#DEFINE CAPDRIVERCAPS_SIZE 44
LOCAL cBuffer, nResult
cBuffer = Repli(Chr(0),CAPDRIVERCAPS_SIZE)
THIS.msg(WM_CAP_DRIVER_GET_CAPS, Len(cBuffer), @cBuffer, 1)
THIS.capOverlay = buf2dword(SUBSTR(cBuffer,5,4))
nResult = Asc(SUBSTR(cBuffer, 21,1))
RETURN (nResult<>0)

PROCEDURE GetCaptureDimensions
* reading uiImageWidth and uiImageHeight members
* of the CAPSTATUS structure
#DEFINE CAPSTATUS_SIZE 76
LOCAL cBuffer
cBuffer = Repli(Chr(0), CAPSTATUS_SIZE)
THIS.msg(WM_CAP_GET_STATUS, Len(cBuffer), @cBuffer, 1)
THIS.capWidth = buf2dword(SUBSTR(cBuffer,1,4))
THIS.capHeight = buf2dword(SUBSTR(cBuffer,5,4))

PROCEDURE StartPreview
THIS.msg(WM_CAP_SET_PREVIEWRATE, 30,0)
THIS.msg(WM_CAP_SET_PREVIEW, 1,0)
IF THIS.capOverlay <> 0
THIS.msg(WM_CAP_SET_OVERLAY, 1,0)
ENDIF

PROCEDURE StopPreview
THIS.msg(WM_CAP_SET_PREVIEW, 0,0)
ENDDEFINE

FUNCTION buf2dword(lcBuffer)
RETURN Asc(SUBSTR(lcBuffer, 1,1)) + ;
BitLShift(Asc(SUBSTR(lcBuffer, 2,1)), 8) +;
BitLShift(Asc(SUBSTR(lcBuffer, 3,1)), 16) +;
BitLShift(Asc(SUBSTR(lcBuffer, 4,1)), 24)

Este codigo solo ponen en un prg.