'take a picture of whatever you want every <millisecond>
' from a plugged WebCam !
'
' ---- RQ Code Start
' VIEW WEBCAM AND TAKES SNAPSHOT With APICAP32.DLL
' By Jacques Philippe 16 October 2004
' Inspired by FASM example WEBCAM.ASM at http://flatassembler.net/examples.php
' ?? DOC at ?? :
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vcsample98/html\vcsmpvideo.asp
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/multimed/htm/_win32_changing_a_video_capture_setting.asp
' and VB Example & all Constantes :
'http://familia.rebello.nom.br/~caco/Projetos/VB/Video%20mouse%20game/VBAVICAP.bas
'this for the missing const....... 
' http://www.vb-fun.de/cgi-bin/loadframe.pl?ID=vb/tipps/tip0273.shtml
'
$INCLUDE "RapidQ.Inc"
$ESCAPECHARS ON
$TYPECHECK ON
'
Const WS_VISIBLE = &H10000000
Const WS_CHILD = &H40000000
'
Const WM_USER = 1024
Const WM_CAP_DRIVER_CONNECT = WM_USER + 10
Const WM_CAP_DRIVER_DISCONNECT = WM_USER + 11
Const WM_CAP_FILE_SAVEDIB = WM_USER + 25
Const WM_CAP_SET_PREVIEW = WM_USER + 50
Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Const WM_CAP_SET_SCALE = WM_USER + 53
'
Declare Function SendMessageX Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA"_
	(ByVal lpszWindowName As String,_
	ByVal dwStyle As Long,_
	ByVal left As Long, ByVal top As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
	ByVal hwndParent As Long, _
	ByVal nID As Long) As Long
'
Declare Sub OnClose_frmMyForm
Declare Sub OnClic_AnyMenu (Sender As QMenuItem)
Declare Function CreateViewWindow () As Long
'
Create frmMyForm As QForm
	Center
	Width = 600
	height = 800
	Caption = "frmMyForm"
	AutoScroll = False
	OnClose = OnClose_frmMyForm

 Create rchWin AS QRichEdit
	Height = 200
	Align = alTop
	Font.Name = "courier"
	Font.Size = 8
	color = &HFAFFFF
	Font.Color = &H000040
	ReadOnly = True
	WordWrap = False
	ScrollBars = ssBoth
	HideSelection = False
	PlainText = True
 End Create

Create mnuMain AS QMAINMENU
	Create mnuOpenCam AS QMENUITEM
		Caption = "&OPEN CAM"
		OnClick = OnClic_AnyMenu
	End Create
	Create mnuViewCam AS QMENUITEM
		Caption = "&VIEW CAM"
		OnClick = OnClic_AnyMenu
	End Create
	Create mnuCloseCam AS QMENUITEM
		Caption = "&CLOSE CAM"
		OnClick = OnClic_AnyMenu
	End Create
	Create mnuSavePicBmp AS QMENUITEM
		Caption = "&SAVE A PICTURE"
		OnClick = OnClic_AnyMenu
	End Create
	Create mnuSetScalable AS QMENUITEM
		Caption = "&SCALABLE IS FALSE"
		OnClick = OnClic_AnyMenu
	End Create
End Create
End Create
'
'
' --------------------------------------------------------------------
' New Code API Call that lets RapidQ programs minimize to the task bar
DECLARE FUNCTION SetWindowLong LIB "user32" ALIAS "SetWindowLongA" (hWnd AS LONG, nIndex AS LONG, dwNewLong AS LONG) AS LONG
' ----- API Constants and Functions
CONST GWL_HWNDPARENT = (-8) 'Minimize to task bar
CONST HWND_DESKTOP = 0
setwindowlong(frmMyForm.handle, GWL_HWNDPARENT, HWND_DESKTOP)
setwindowlong(application.handle, GWL_HWNDPARENT, frmMyForm.handle)
' --------------------------------------------------------------------
' GLOBAL DATAS
DefInt hCamWnd
DefStr CamTitle = "CaptureWindow"
DefInt iScalable = False
' *************************************
frmMyForm.Show
' *************************************
'
'
' *************************************
frmMyForm.Visible = False
frmMyForm.ShowModal
' *************************************
'
Sub OnClose_frmMyForm
	DefInt iReturn
	iReturn = SendMessageX (hCamWnd, WM_CAP_DRIVER_DISCONNECT, Camtitle, 0)
	Application.Terminate
	End
End Sub
'
'
Sub OnClic_AnyMenu (Sender)
	DefInt iReturn
	DefInt iDevice = 0 ' 0 to 9
	DefInt iFramesSpacedMS = 1000 ' Duration between two frames in Milliseconds
	DefStr sFileName, sTmp
	DefInt iTmp
	Select Case Sender.Handle

		Case mnuOpenCam.Handle
			hCamWnd = capCreateCaptureWindow(CamTitle, ws_child Or ws_visible, 0, 210, 4*(frmMyForm.ClientHeight-250)/3, frmMyForm.ClientHeight-250, frmMyForm.Handle, 0)
			If hCamWnd <> 0 then
				rchWin.Addstring (" - OK : Cam Opened")
			Else
				rchWin.Addstring (" - ERROR : Camnot Opened Cam")
			End If

		Case mnuCloseCam.Handle
			rchWin.Addstring (" CLOSED = " & Str$(SendMessageX(hCamWnd, WM_CAP_DRIVER_DISCONNECT, Camtitle, 0)))

		Case mnuViewCam.Handle
			If hCamWnd = 0 Then ShowMessage ("You must Open Cam First"):Exit Sub
			rchWin.Addstring (" CONNECT = " & Str$(SendMessageX (hCamWnd, WM_CAP_DRIVER_CONNECT, iDevice, 0)))
			rchWin.Addstring ("SET REVIEW RATE = " & Str$(SendMessageX (hCamWnd, WM_CAP_SET_PREVIEWRATE, iFramesSpacedMS, 0)))
			rchWin.Addstring ("SET PREVIEW ON = " & Str$(SendMessageX (hCamWnd, WM_CAP_SET_PREVIEW, True, 0)))

		Case mnuSavePicBmp.Handle
			sFileName = "Pic_" & (Date$ - "/" - "-") & "_" & (Time$ -":") & ".Bmp"
			rchWin.Addstring (" FILE SAVE BMP = " & Str$(SendMessageX (hCamWnd, WM_CAP_FILE_SAVEDIB, 0, VarPtr(sFilename))) & "\n In CurDir : " & CurDir$)

		Case mnuSetScalable.Handle
			If iScalable = True Then
				iTmp = False
				sTmp = "SCALABLE IS FASLE"
			Else
				sTmp = "SCALABLE IS TRUE"
				iTmp = True
			End If
			iReturn = SendMessageX (hCamWnd, WM_CAP_SET_SCALE, iTmp, 0)
			rchWin.Addstring (" SET SCALABLE = " & Str$(iReturn))
			If iReturn = Then mnuSetScalable.Caption = sTmp:iScalable = iTmp
	End Select
End Sub
'
'
'
'Extras if you add them as QMENUITEMS
'Case mnuFormatDlg.Handle
'	If hCamWnd = 0 Then
'		rchWin.Addstring (" *** ERROR *** : CAM MUST BE OPENED TO SET VIDEO FORMAT")
'		Exit Sub
'	End If
'	rchWin.Addstring ("VIDEO FORMAT DIALOG = " & Str$(SendMessageX (hCamWnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)) & " (If 0,You Have None)")
'
'Case mnuDisplayDlg.Handle
'	If hCamWnd = 0 Then
'		rchWin.Addstring (" *** ERROR *** : CAM MUST BE OPENED TO SET VIDEO DISPLAY")
'		Exit Sub
'	End If
'	rchWin.Addstring ("VIDEO FORMAT DISPLAY = " & Str$(SendMessageX (hCamWnd, WM_CAP_DLG_VIDEODISPLAY, 0, 0)) & " (If 0,You Have None)")
'
'Case mnuSourceDlg.Handle
'	If hCamWnd = 0 Then
'		rchWin.Addstring (" *** ERROR *** : CAM MUST BE OPENED TO SET VIDEO SOURCE")
'		Exit Sub
'	End If
'	rchWin.Addstring ("VIDEO FORMAT SOURCE = " & Str$(SendMessageX (hCamWnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)) & " (If 0,You Have None)")
'
' ---- End of RQ Code