Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
Private m_TimeToCapture_milliseconds As Integer
Private m_Width As Long
Private m_Height As Long
Private mCapHwnd As Long
Private bStopped As Boolean
Private Sub Combo1_Change()
''Timer1.Interval = Combo1.Text * 100
''If Combo1.Text = 10 Then
'' Call Timer2_Timer
'' Exit Sub
'' ElseIf Combo1.Text = 20 Then
'' Call Timer3_Timer
'' Exit Sub
'' ElseIf Combo1.Text = 30 Then
'' Call Timer4_Timer
'' Exit Sub
'' End If
End Sub
Private Sub Command1_Click()
Shell "WebCam.exe", vbNormalFocus 'run my clone
Unload Me 'let me go away
End Sub
Private Sub Form_Load()
Label1.BackStyle = 0 ' CheckBox
Label4.BackStyle = 0 ' Form Caption
Label5.BackStyle = 0 ' Form Close
m_TimeToCapture_milliseconds = 500
m_Width = 352
m_Height = 288
bStopped = True
mCapHwnd = 0
Combo1.ListIndex = 0
End Sub
Public Sub Start()
If mCapHwnd <> 0 Then Exit Sub
FrameNum = 0
Timer1.Interval = m_TimeToCapture_milliseconds
' for safety, call stop, just in case we are already running
Me.Timer1.Enabled = False
' setup a capture window
mCapHwnd = capCreateCaptureWindowA("WebCap", 0, 0, 0, m_Width, m_Height, Me.hwnd, 0)
DoEvents
' connect to the capture device
Call SendMessage(mCapHwnd, WM_CAP_CONNECT, 1, 0)
'******** change 1 back to 0
DoEvents
Call SendMessage(mCapHwnd, WM_CAP_SET_PREVIEW, 0, 0)
' set the timer information
bStopped = False
Me.Timer1.Enabled = True
End Sub
Public Sub StopWork()
' stop the timer
bStopped = True
Timer1.Enabled = False
' disconnect from the video source
DoEvents
Call SendMessage(mCapHwnd, WM_CAP_DISCONNECT, 0, 0)
mCapHwnd = 0
End Sub
Private Sub Label1_Click()
Image2.Visible = Not Image2.Visible
If Image2.Visible = True Then
Image1.Width = 352
Image1.Height = 288
Image1.Stretch = True
Else
Image1.Stretch = False
End If
End Sub
Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
'Release capture
Call ReleaseCapture
'Send a 'left mouse button down on caption'-message to our form
lngReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Label5_Click()
' From Close
Call lvButtons_H6_Click
End Sub
Private Sub lvButtons_H1_Click()
If mCapHwnd = 0 Then Exit Sub
Call SendMessage(mCapHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
DoEvents
End Sub
Private Sub lvButtons_H2_Click()
If mCapHwnd = 0 Then Exit Sub
Call SendMessage(mCapHwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
DoEvents
End Sub
Private Sub lvButtons_H3_Click()
Start
lvButtons_H1.Enabled = True
lvButtons_H2.Enabled = True
lvButtons_H4.Enabled = True
lvButtons_H3.Enabled = False
End Sub
Private Sub lvButtons_H4_Click()
StopWork
lvButtons_H1.Enabled = False
lvButtons_H2.Enabled = False
lvButtons_H4.Enabled = False
lvButtons_H3.Enabled = True
End Sub
Private Sub lvButtons_H5_Click()
savepic
End Sub
Private Sub savepic()
DoEvents
If Dir(App.Path & "\myPic", vbDirectory) = "" Then MkDir (App.Path & "\myPic")
File1.Path = App.Path & "\myPic"
'File1.Pattern = "*.bmp"
File1.Pattern = "*.jpg"
File1.Refresh
Dim Maxnum As Integer, ii As Integer
For ii = 0 To File1.ListCount - 1
If Left(File1.List(ii), 1) = "p" Then
If CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4)) > Maxnum Then
Maxnum = CInt(Mid(File1.List(ii), 2, Len(File1.List(ii)) - 4))
End If
End If
Next
'SavePicture Image1.Picture, App.Path & "\myPic\p" & Maxnum + 1 & ".bmp"
Picture1.Picture = Image1.Picture
SAVEJPEG App.Path & "\myPic\p" & Maxnum + 1 & ".jpg", 100, Me.Picture1
DoEvents
End Sub
Private Sub lvButtons_H6_Click()
Timer1.Enabled = False
If mCapHwnd <> 0 Then StopWork
Unload Me
End
End Sub
Private Sub Timer1_Timer()
Static cnt As Integer
cnt = cnt + 1
' pause the timer
Timer1.Enabled = False
' get the next frame;
Call SendMessage(mCapHwnd, WM_CAP_GET_FRAME, 0, 0)
' copy the frame to the clipboard
Call SendMessage(mCapHwnd, WM_CAP_COPY, 0, 0)
' For some reason, the API is not resizing the video
' feed to the width and height provided when the video
' feed was started, so the image was resize here
' Image1.Stretch = True
' get from the clipboard
Image1.Picture = Clipboard.GetData
' restart the timer
DoEvents
If cnt > Combo1.Text And Not Combo1.Text = 0 Then
' Debug.Print Timer
savepic
cnt = 0
End If
If Not bStopped Then
Timer1.Enabled = True
End If
End Sub
'''Private Sub Timer2_Timer()
'''If Combo1.Text = 10 And lvButtons_H3.Enabled = False And lvButtons_H4.Enabled = True Then
''' Timer2.Enabled = True
''' Call lvButtons_H5_Click
''' Else
''' Timer2.Enabled = False
''' End If
'''End Sub
'''
'''Private Sub Timer3_Timer()
'''If Combo1.Text = 20 And lvButtons_H3.Enabled = False And lvButtons_H4.Enabled = True Then
''' Timer3.Enabled = True
''' Call lvButtons_H5_Click
''' Else
''' Timer3.Enabled = False
''' End If
'''End Sub
'''
'''Private Sub Timer4_Timer()
'''If Combo1.Text = 30 And lvButtons_H3.Enabled = False And lvButtons_H4.Enabled = True Then
''' Timer4.Enabled = True
''' Call lvButtons_H5_Click
''' Else
''' Timer4.Enabled = False
''' End If
'''End Sub