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

[mic_k86]

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...

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

[si_the_geek]

I strongly recommend reading the article What is wrong with using "On Error Resume Next"? from our Classic VB FAQs (in the FAQ forum, which is shown near the top of our home page)

There is a good chance that you are getting an error (ie: VB is trying to tell you what is wrong), but you are ignoring it.

[mic_k86]

si_the_geek,

thank for the advise. actually i have try many try and error case in this coding. however, i cant find out what is wrong. maybe i miss some coding? i not sure. so i post here for advance help...

[si_the_geek]

It isn't too clear what you mean.. have you removed all of the "On Error Resume Next"? If not, you should - there is no need for it at all in your code.

[mic_k86]

i have remove all "on error resume next". still have same problem. help...

[dee-u]

Were there any errors raised? Have you tried running it with full compile?

[mic_k86]

dee-u, what error do you mean? error during compile?

FYI, i can compile perfectly and made an exe file of it. however, same problem still occur when i change the time selection during exe is running.

[westconn1]

only timer 1 does anything with the webcam, 2 3 & 4 do not

there is no need for multiple timers, just change the interval to suit, also it is pretty hard to enable a timer from within its own event

if you want someone to help you with this zip and post the whole project or a sample version

[mic_k86]

here i attach my webcam exe file for your testing and help.

one more help, how to remove the arab word at the top of the frame?

[mic_k86]

anyone help on this matter?

[westconn1]

the arab word is part of the picture on the from, as the picture is within the form code you can not remove it easily, you could make a new picture or cover over the word by changing the backstyle of label4, so it does not show through
anyway you should design your own form, not just use someone elses

i wrote the above about 5 hours ago, got distracted

here is a solution to capturing the images to file based on the value in the combo box, only uses one timer, i increased the timer interval as it does not really work any faster even with shorter interval

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

[mic_k86]

westconn, thanks a lot. yeah. it work. however, for the timing period, when i select 10 seconds, but it capture image after 5 seconds. same situation happen for other selection. time capture image reduced half. i hv try double the timer interval for timer 2, timer 3, & timer 4 but it doesnt work.

[westconn1]

don't change timer interval, change
this is about the most accurate i could get, tested with 10 and 20 second

Private Sub Timer1_Timer()
Static lasttime As Single, nexttime As Single
    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 nexttime <= Timer Then
    lasttime = Timer
    nexttime = lasttime + Combo1.Text - 1 'allow processing time in timer event
    'Debug.Print lasttime, nexttime
    savepic
    End If
    If Not bStopped Then
'        Timer1.Enabled = True
    End If
 
End Sub

i am not using any of the timers except timer 1, you may have noticed i commented out all there code

[mic_k86]

westconn, nearly 1second is missed. however, when i change the code

nexttime = lasttime + Combo1.Text - 1 'allow processing time in timer event

to

nexttime = lasttime + Combo1.Text 'allow processing time in timer event

i can get accurate time. so what is the -1 important in the coding? however, i hv found another problem. when the time in combo box is 0 second and i click start, the camera will continue capturing image. how to modify it so that at 0 second and start button is click, no capturing operation is performed?

[westconn1]

If nexttime <= Timer and not combo1.text = 0 Then
should stop it capturing files when set to 0, but the image will still update on the form display

the timer function was not accurate on my computer always seemed to be 1 second slow, with the -1 made it nearly correct, feel free to adjust whichever value suits you best

[mic_k86]

If nexttime <= Timer and not combo1.text = 0

can stop it capturing files when set to 0, but when set to 10, 20 or 30 it continuously capture image without depend on the time. (nearly 10++ image captured in 1 second)

[westconn1]

i just tested the program again, the images saved very close to the correct timing p2 to p8, 5 seconds under 1 minute

if you still have a problem post your form (or the code) again

[mic_k86]

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 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, 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()

    ' 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

    ' 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 nexttime <= Timer And Not Combo1.Text = 0 Then
     lasttime = Timer
     nexttime = lasttime + Combo1.Text 'allow processing time in timer event
     'Debug.Print lasttime, nexttime
    savepic
        
    End If

End Sub

here is my current code

[westconn1]

change the declared variables
Private Sub Timer1_Timer()
Static lasttime As Single, nexttime As Single

other than that i cannot see any difference to what i am using

[mic_k86]

westconn, thanks a lot. ya, i miss to change that line of code. now i think the program is work smooth already. then i plan to made a command button so can direct access the myPic folder from vb. below is my code

Option Explicit

Private Const CSIDL_DESKTOP = &H0
Private Const NOERROR = 0

Private Type SHTEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHTEMID
End Type

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2

Dim strDesktop As String

Private Sub Command2_Click()

strDesktop = GetSpecialfolder(CSIDL_DESKTOP)
ShellExecute Me.hwnd, "open", strDesktop & "\webcam\myPic", vbNullString, strDesktop & "\webcam\myPic", SW_SHOWNORMAL

End Sub


Private Sub Form_Load()
Debug.Print "Desktop path: " & GetSpecialfolder(CSIDL_DESKTOP)
End Sub

Private Function GetSpecialfolder(CSIDL As Long) As String
Dim r As Long
Dim IDL As ITEMIDLIST
Dim Path$

    'Get the special folder
    r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
        If r = NOERROR Then
            'Create a buffer
            Path$ = Space$(512)
            'Get the path from the IDList
            r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
            'Remove the unnecessary chr$(0)'s
            GetSpecialfolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
            Exit Function
    End If
    GetSpecialfolder = ""
End Function

which is study from my post previously in this thread http://www.vbforums.com/showthread.php?t=550827 However, when i execute it, error variable not found and highlighted on cnt = cnt + 1. what wrong and how to correct it?

[westconn1]

that line is not required it was a left over from my previous attempt

[mic_k86]

after i delete that line of code still got another error on this line of code

FrameNum = 0

at public sub start (). i try delete this code and it work fine. what is important of this code?

[dee-u]

Did you ever declare FrameNum and used it anywhere? If not then just remove it.

[westconn1]

it would appear to me that you added option explicit to the top of your form, after you had been testing the code already, any variables that were undeclared, would now have to be declared, preferably with the correct type, or an error will occur, even though no error was generated before adding option explicit

[mic_k86]

so how to declare the FremeNum? or just delete it?

[westconn1]

judging by the name framenum i guess as integer

don't delete first, just comment out in case you still need it, or do a search to see where else it occurs

[mic_k86]

yea. i declare and no more error occur. is it need to declare it as public or private? i got try two types and all work fines.

[dee-u]

http://www.vbforums.com/showthread.p...le+declaration

[mic_k86]

thank everyone especially westconn1, i hv learn a lot about webcam program in vb.

[mic_k86]

hi all, i hv some problem here with my coding. this coding is work fine in my pc. but when i using monitoring software (tightVNC, which i installed my webcam my vb exe in one pc and monitor using another pc), i found following error

Run-time error 521 - Cannot open clipboard"

. i got try debug the coding by putting clipboard.clear but still have same problem. help...

[mic_k86]

any help?

[mic_k86]

i need help here. urgent. anyone help me modify the code? (without using of clipboard)

[westconn1]

you can try to modify this code as it does not use the clipboard (or at least not in the same way), it captures a frame from the webcam to a picturebox

Option Explicit
 
Public Const WS_CHILD As Long = &H40000000
Public Const WS_VISIBLE As Long = &H10000000
 
Public Type POINT
x As Long
y As Long
End Type
 
Public Type CAPSTATUS
uiImageWidth As Long
uiImageHeight As Long
fLiveWindow As Long
fOverlayWindow As Long
fScale As Long
ptScroll As POINT
fUsingDefaultPalette As Long
fAudioHardware As Long
fCapFileExists As Long
dwCurrentVideoFrame As Long
dwCurrentVideoFramesDropped As Long
dwCurrentWaveSamples As Long
dwCurrentTimeElapsedMS As Long
hPalCurrent As Long
fCapturingNow As Long
dwReturn As Long
wNumVideoAllocated As Long
wNumAudioAllocated As Long
End Type
 
Public Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" ( _
ByVal lpszWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal nID As Long) As Long
 
Public Declare Function GetDC Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
 
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As Long) As Long
 
Public Declare Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Public Declare Function BitBlt Lib "gdi32.dll" ( _
ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
 
Public Declare Function DeleteDC Lib "gdi32.dll" ( _
ByVal hdc As Long) As Long
 
 
Public hCapWin As Long
Public w As Long
Public h As Long
 
Public Sub CapFrame(i As Long)
Dim hCapWinDC As Long
Dim hBitmap As Long
Dim hdc As Long
Dim hOldBMP As Long
Dim r As Long, j As Long
Form2.Hide
hCapWinDC = GetDC(hCapWin)
hBitmap = CreateCompatibleBitmap(hCapWinDC, w, h)
hdc = CreateCompatibleDC(hCapWinDC)
hOldBMP = SelectObject(hdc, hBitmap)
 
r = BitBlt(hdc, 0, 0, w, h, hCapWinDC, 0, 0, vbSrcCopy)
(Form2.Picture1(0).Width + 200), Form2.Picture1(0).Top + i Mod 3 * (Form2.Picture1(0).Height + 200), w * Screen.TwipsPerPixelX, h * Screen.TwipsPerPixelY
Form1.Picture1.Move Form1.Picture1.Left, Form1.Picture1.Top, Form1.ScaleWidth, Form1.ScaleHeight
r = BitBlt(Form1.Picture1.hdc, 0, 0, Form1.ScaleWidth, Form1.ScaleHeight, hdc, 0, 0, vbSrcCopy)
Form1.Picture1.Refresh
Form2.Picture1(i).Picture = Form1.Picture1.Image
r = SelectObject(hdc, hOldBMP)
r = DeleteDC(hdc)
End Sub

the whole project is in a thread by me in codebank vb6, i have this in a module, but you could change the declares and put in your form, in this case hcapwin was on form1 and the picture boxes on form 2

[mic_k86]

westconn1, i hv download the vb in the codebank you upload few day ago. but until now i dont have idea how to change my coding part which using clipboard to your coding using DIB. seem need have a major change in the coding. can you help me? i upload here my latest coding which is still using the clipboard part. hope can help...