' VB6把摄像头的图像放入 Image 或 PictureBox 里，可进行截图。（用到2个PictureBox，1个Image，1个CommandButton）

' 但本程序会占用Windows的剪贴板（打开程序后，Windows的剪贴板不能使用）

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 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
Private Const GET_FRAME As Long = 1084
Private Const COPY As Long = 1054
Private Const CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private CapHwnd As Long

Private Sub Command1_Click()
    On Error Resume Next
    SendMessage CapHwnd, GET_FRAME, 0, 0
    SendMessage CapHwnd, COPY, 0, 0
    Picture2.Picture = Clipboard.GetData
    Clipboard.Clear
    SavePicture Picture2.Image, "c:\TEST.BMP"   ' 将图片保存到文件。
End Sub

 

Private Sub Form_Load()

    '打开摄像头
    CapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 320, 240, Me.hwnd, 0)
    DoEvents
    SendMessage CapHwnd, CONNECT, 0, 0
    Timer1.Enabled = True
End Sub

 

Private Sub Form_Unload(Cancel As Integer)
    '停止摄像头
    DoEvents: SendMessage CapHwnd, DISCONNECT, 0, 0
    Timer1.Enabled = False

End Sub

 

Private Sub Timer1_Timer() 'timer1.Interval=50

    On Error Resume Next
    SendMessage CapHwnd, GET_FRAME, 0, 0
    SendMessage CapHwnd, COPY, 0, 0
'    Picture1.Picture = Clipboard.GetData
    Image1.Picture = Clipboard.GetData
    Clipboard.Clear
End Sub