Results 1 to 34 of 34

Thread: [RESOLVED] webcam can't continuous capture image after time selection change

Threaded View

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Jul 2008
    Posts
    172

    Resolved [RESOLVED] webcam can't continuous capture image after time selection change

    hi all,

    i have download a webcam program and modify with it. i want the webcam to continuous capture image in the time period i set in the combo box. my combo box contain 10, 20 and 30 seconds interval. at 1st, i select 10 seconds and click start. the webcam works well and can continuous capture image every 10 seconds. however, when i change to 20 seconds, the webcam no more capture any image. even i stop and start again the webcam also no function anymore. below is my coding, help plz...


    Code:
    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()
    
    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 Form_Load()
    On Error Resume Next
    Label1.BackStyle = 0 ' CheckBox
    Label4.BackStyle = 0 ' Form Caption
    Label5.BackStyle = 0 ' Form Close
    
        m_TimeToCapture_milliseconds = 100
        m_Width = 352
        m_Height = 288
        bStopped = True
        mCapHwnd = 0
        
    End Sub
    
    Public Sub Start()
        On Error Resume Next
        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, 0, 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()
        On Error Resume Next
        ' 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()
    On Error Resume Next
        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)
        On Error Resume Next
        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()
    On Error Resume Next
      If mCapHwnd = 0 Then Exit Sub
    
        Call SendMessage(mCapHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
        DoEvents
        
    End Sub
    
    Private Sub lvButtons_H2_Click()
    On Error Resume Next
        
        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()
    On Error Resume Next
    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()
    On Error Resume Next
    
        ' 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 we must resize the image here
        ' Image1.Stretch = True
                
        ' get from the clipboard
        Image1.Picture = Clipboard.GetData
             
             
        ' restart the timer
        DoEvents
        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
    Last edited by si_the_geek; Dec 19th, 2008 at 10:33 AM. Reason: corrected Code tags

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width