视频捕捉源代码

'请尊重著作权！谢绝转摘，有疑问请与作者联系！
Imports Microsoft.VisualBasic
Imports Microsoft.Win32
'VideoCampture using VB.NET
' author:自由奔腾 wgscd@126.com
'www.topds.com
'QQ:153964481 website: http://www.topds.com
' 2004 11-26
Public Class Form1
    Inherits System.Windows.Forms.Form

#Region " Windows 窗体设计器生成的代码 "

    Public Sub New()
        MyBase.New()

        '该调用是 Windows 窗体设计器所必需的。
        InitializeComponent()

        '在 InitializeComponent() 调用之后添加任何初始化

    End Sub

    '窗体重写 dispose 以清理组件列表。
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    'Windows 窗体设计器所必需的
    Private components As System.ComponentModel.IContainer

    '注意: 以下过程是 Windows 窗体设计器所必需的
    '可以使用 Windows 窗体设计器修改此过程。
    '不要使用代码编辑器修改它。
    Friend WithEvents camSrc As System.Windows.Forms.PictureBox
    Friend WithEvents Button1 As System.Windows.Forms.Button
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Me.camSrc = New System.Windows.Forms.PictureBox
        Me.Button1 = New System.Windows.Forms.Button
        Me.SuspendLayout()
        '
        'camSrc
        '
        Me.camSrc.Location = New System.Drawing.Point(8, 8)
        Me.camSrc.Name = "camSrc"
        Me.camSrc.Size = New System.Drawing.Size(320, 240)
        Me.camSrc.TabIndex = 0
        Me.camSrc.TabStop = False
        '
        'Button1
        '
        Me.Button1.Location = New System.Drawing.Point(8, 256)
        Me.Button1.Name = "Button1"
        Me.Button1.Size = New System.Drawing.Size(75, 32)
        Me.Button1.TabIndex = 1
        Me.Button1.Text = "关闭"
        '
        'Form1
        '
        Me.AutoScaleBaseSize = New System.Drawing.Size(6, 14)
        Me.ClientSize = New System.Drawing.Size(336, 294)
        Me.Controls.Add(Me.Button1)
        Me.Controls.Add(Me.camSrc)
        Me.Name = "Form1"
        Me.Text = "VideoCampture"
        Me.ResumeLayout(False)

    End Sub

#End Region

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

        MapWebcamToWindow(camSrc.Width, camSrc.Height, camSrc.Handle.ToInt32)

    End Sub

    Public lwndC As Integer

    Public Const WS_CHILD As Integer = &H40000000

    Public Const WS_VISIBLE As Integer = &H10000000

    Public Const SWP_NOMOVE As Short = &H2S

    Public Const SWP_NOZORDER As Short = &H4S

    Public Const WM_USER As Short = &H400S
    Public Const WM_CAP_DRIVER_CONNECT As Integer = WM_USER + 10

    Public Const WM_CAP_DRIVER_DISCONNECT As Integer = WM_USER + 11

    Public Const WM_CAP_SET_VIDEOFORMAT As Integer = WM_USER + 45

    Public Const WM_CAP_SET_PREVIEW As Integer = WM_USER + 50

    Public Const WM_CAP_SET_PREVIEWRATE As Integer = WM_USER + 52

    Public Structure BITMAPINFOHEADER

        Dim biSize As Integer

        Dim biWidth As Integer

        Dim biHeight As Integer

        Dim biPlanes As Short

        Dim biBitCount As Short

        Dim biCompression As Integer

        Dim biSizeImage As Integer

        Dim biXPelsPerMeter As Integer

        Dim biYPelsPerMeter As Integer

        Dim biClrUsed As Integer

        Dim biClrImportant As Integer

    End Structure

    Public Structure BITMAPINFO

        Dim bmiHeader As BITMAPINFOHEADER

        Dim bmiColors() As Integer

    End Structure

    Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer

    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Short, ByVal lParam As Integer) As Integer

    Declare Function SendMessageAsBitMap Lib "user32" Alias "SendMessageA" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByRef lParam As BITMAPINFO) As Integer

    Declare Function capCreateCaptureWindowA Lib "avicap32.dll" (ByVal lpszWindowName As String, ByVal dwStyle As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Short, ByVal hWndParent As Integer, ByVal nID As Integer) As Integer

    Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Short, ByVal lpszName As String, ByVal cbName As Integer, ByVal lpszVer As String, ByVal cbVer As Integer) As Boolean

    Function capDriverConnect(ByVal lwnd As Integer, ByVal i As Short) As Boolean
        capDriverConnect = SendMessage(lwnd, WM_CAP_DRIVER_CONNECT, i, 0)
    End Function

    Function capDriverDisconnect(ByVal lwnd As Integer) As Boolean
        capDriverDisconnect = SendMessage(lwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)

    End Function

    Function capSetVideoFormat(ByVal hCapWnd As Integer, ByRef BmpFormat As BITMAPINFO, ByVal CapFormatSize As Integer) As Boolean
        capSetVideoFormat = SendMessageAsBitMap(hCapWnd, WM_CAP_SET_VIDEOFORMAT, CapFormatSize, BmpFormat)
    End Function

    Function capPreview(ByVal lwnd As Integer, ByVal f As Boolean) As Boolean
        capPreview = SendMessage(lwnd, WM_CAP_SET_PREVIEW, f, 0)
    End Function

    'The capPreview function is used to initiate the streaming of images between the VFW driver and the capture window.
    Function capPreviewRate(ByVal lwnd As Integer, ByVal wMS As Short) As Boolean
        capPreviewRate = SendMessage(lwnd, WM_CAP_SET_PREVIEWRATE, wMS, 0)

    End Function
    'The capPreviewRate function determines the refresh rate by specifying the refresh interval in milliseconds. In our case, it is set to 66 ms (15 Frames Per second).

    'Now, we must implement the two functions referenced by the main form as follows ?

    Sub MapWebcamToWindow(ByRef lWidth As Integer, ByRef lHeight As Integer, ByRef hWnd As Integer)
        ' Dim lpszName As New VB6.FixedLengthString(100)
        Dim lpszName As New VBFixedStringAttribute(100)

 

        Dim bmp As BITMAPINFO
        With bmp.bmiHeader
            .biSize = Len(bmp.bmiHeader)
            .biWidth = 320
            .biHeight = 240
            .biPlanes = 1
            .biBitCount = 24
        End With
        ' capGetDriverDescriptionA(0, lpszName.Value, 100, Nothing, 100)
        'lwndC = capCreateCaptureWindowA(lpszName.Value, WS_VISIBLE Or WS_CHILD, 0, 0, lWidth, lHeight, hWnd, 0)

        capGetDriverDescriptionA(0, lpszName.Length, 100, Nothing, 100)
        lwndC = capCreateCaptureWindowA(lpszName.Length, WS_VISIBLE Or WS_CHILD, 0, 0, lWidth, lHeight, hWnd, 0)

        If capDriverConnect(lwndC, 0) Then
            capPreviewRate(lwndC, 66)
            capPreview(lwndC, True)
            capSetVideoFormat(lwndC, bmp, Len(bmp))
            SetWindowPos(lwndC, 0, 0, 0, bmp.bmiHeader.biWidth, bmp.bmiHeader.biHeight, SWP_NOMOVE Or SWP_NOZORDER)
        End If

    End Sub
    'The MapWebcamToWindow sub performs the following tasks
    'Retrieves the name of the first available VFW driver.
    'Creates a capture window, and attaches it to a given window handle.
    'Connects the VFW driver to the capture window
    'Sets the refresh rate to 15 frames per second
    'Initiates the transfer of video between the VFW driver and capture window
    'Sets the video format to 320x240
    'Moves and stretches the capture window to 320 x 240 pixels
    'Finally, we provide our CloseWebcam function to perform the cleanup

    Sub CloseWebcam()
        capDriverDisconnect(lwndC)

    End Sub

    Dim cc As VBFixedStringAttribute

    Private Sub Form1_Closed(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Closed
        CloseWebcam()
    End Sub

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        If Button1.Text = "关闭" Then
            CloseWebcam()
            Button1.Text = "显示"
        Else : MapWebcamToWindow(camSrc.Width, camSrc.Height, camSrc.Handle.ToInt32)
            Button1.Text = "关闭"
        End If
    End Sub

    Private Sub Form1_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Click
        MsgBox("VideoCampture  Power By wgscd 自由奔腾 2004-12  QQ：153964481 E-mail:wgscd@126.com www.topds.com", MsgBoxStyle.OKOnly, "版权所有")

    End Sub
End Class