我是新來的stackoverflow,但我註冊,因爲我認爲這裏是獲得專業編程幫助的正確地方:) 我的目標是創建一個網絡攝像頭快照工具,直接將快照保存到文件。 我不需要任何預覽在一個picturebox或類似的東西。 我想這樣的應用:VB.Net Directshow攝像頭快照
一個簡單的接口,與所連接的攝像頭設備組合框和一個按鈕,將拍攝快照,並將其保存到一個文件中。 我喜歡爲此使用DirectShow,因爲所有其他方式使用AForge或advcap32.dll,因爲它們有時會導致一個Videoourcedialog彈出,我不想這樣做。 我喜歡手動選擇我的組合框中的webcamdevice,並能夠拍攝快照。 這樣我喜歡使用DirectShow。
我已經添加了DirectShowLib-2005.dll我的VB.Net項目 我也加入這個類:
Imports System
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports System.Diagnostics
Imports DirectShowLib
Public Class Capture
Implements ISampleGrabberCB
Implements IDisposable
#Region "Member variables"
Private m_graphBuilder As IFilterGraph2 = Nothing
Private m_mediaCtrl As IMediaControl = Nothing
Private mediaEventEx As IMediaEventEx = Nothing
Private videoWindow As IVideoWindow = Nothing
Private UseHand As IntPtr = MainForm.PictureBox1.Handle
Private Const WMGraphNotify As Integer = 13
Private m_takePicture As Boolean = False
Public mytest As String = "yes"
Dim sampGrabber As ISampleGrabber = Nothing
Private bufferedSize As Integer = 0
Private savedArray() As Byte
Public capturedPic As bitmap
Public captureSaved As Boolean
Public unsupportedVideo As Boolean
' <summary> Set by async routine when it captures an image </summary>
Public m_bRunning As Boolean = False
' <summary> Dimensions of the image, calculated once in constructor. </summary>
Private m_videoWidth As Integer
Private m_videoHeight As Integer
Private m_stride As Integer
Private m_bmdLogo As BitmapData = Nothing
Private m_Bitmap As Bitmap = Nothing
#If DEBUG Then
' Allow you to "Connect to remote graph" from GraphEdit
Private m_rot As DsROTEntry = Nothing
#End If
#End Region
#Region "API"
Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As IntPtr, ByVal Source As IntPtr, <MarshalAs(UnmanagedType.U4)> ByVal Length As Integer)
#End Region
' zero based device index, and some device parms, plus the file name to save to
Public Sub New(ByVal iDeviceNum As Integer, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim capDevices As DsDevice()
' Get the collection of video devices
capDevices = DsDevice.GetDevicesOfCat(FilterCategory.VideoInputDevice)
If (iDeviceNum + 1 > capDevices.Length) Then
Throw New Exception("No video capture devices found at that index!")
End If
Dim dev As DsDevice = capDevices(iDeviceNum)
Try
' Set up the capture graph
SetupGraph(dev, iFrameRate, iWidth, iHeight)
Catch
Dispose()
If unsupportedVideo Then
msgbox("This video resolution isn't supported by the camera - please choose a different resolution.")
Else
Throw
End If
End Try
End Sub
' <summary> release everything. </summary>
Public Sub Dispose() Implements IDisposable.Dispose
CloseInterfaces()
If (Not m_Bitmap Is Nothing) Then
m_Bitmap.UnlockBits(m_bmdLogo)
m_Bitmap = Nothing
m_bmdLogo = Nothing
End If
End Sub
Protected Overloads Overrides Sub finalize()
CloseInterfaces()
End Sub
' <summary> capture the next image </summary>
Public Sub Start()
If (m_bRunning = False) Then
Dim hr As Integer = m_mediaCtrl.Run()
DsError.ThrowExceptionForHR(hr)
m_bRunning = True
End If
End Sub
' Pause the capture graph.
' Running the graph takes up a lot of resources. Pause it when it
' isn't needed.
Public Sub Pause()
If (m_bRunning) Then
Dim hr As Integer = m_mediaCtrl.Pause()
DsError.ThrowExceptionForHR(hr)
m_bRunning = False
End If
End Sub
'Added by jk
Public Sub TakePicture()
m_takePicture = True
End Sub
' <summary> Specify the logo file to write onto each frame </summary>
Public Sub SetLogo(ByVal fileName As String)
SyncLock Me
If (fileName.Length > 0) Then
m_Bitmap = New Bitmap(fileName)
Dim r As Rectangle = New Rectangle(0, 0, m_Bitmap.Width, m_Bitmap.Height)
m_bmdLogo = m_Bitmap.LockBits(r, ImageLockMode.ReadWrite, PixelFormat.Format24bppRgb)
Else
If Not m_Bitmap Is Nothing Then
m_Bitmap.UnlockBits(m_bmdLogo)
m_Bitmap = Nothing
m_bmdLogo = Nothing
End If
End If
End SyncLock
End Sub
' <summary> build the capture graph for grabber. </summary>
Private Sub SetupGraph(ByVal dev As DsDevice, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim hr As Integer
Dim baseGrabFlt As IBaseFilter = Nothing
Dim capFilter As IBaseFilter = Nothing
Dim muxFilter As IBaseFilter = Nothing
Dim fileWriterFilter As IFileSinkFilter = Nothing
Dim capGraph As ICaptureGraphBuilder2 = Nothing
Dim sampGrabberSnap As ISampleGrabber = Nothing
' Get the graphbuilder object
m_graphBuilder = DirectCast(New FilterGraph(), IFilterGraph2)
m_mediaCtrl = DirectCast(m_graphBuilder, IMediaControl)
'if taking a picture (a still snapshot), then remove the videowindow
If Not m_takePicture Then
mediaEventEx = DirectCast(m_graphBuilder, IMediaEventEx)
videoWindow = DirectCast(m_graphBuilder, IVideoWindow)
Else
mediaEventEx = Nothing
videoWindow = Nothing
End If
#If DEBUG Then
m_rot = New DsROTEntry(m_graphBuilder)
#End If
Try
' Get the ICaptureGraphBuilder2
capGraph = DirectCast(New CaptureGraphBuilder2(), ICaptureGraphBuilder2)
' Get the SampleGrabber interface
sampGrabber = DirectCast(New SampleGrabber(), ISampleGrabber)
sampGrabberSnap = DirectCast(New SampleGrabber(), ISampleGrabber)
' Start building the graph
hr = capGraph.SetFiltergraph(DirectCast(m_graphBuilder, IGraphBuilder))
DsError.ThrowExceptionForHR(hr)
' Add the video device
hr = m_graphBuilder.AddSourceFilterForMoniker(dev.Mon, Nothing, dev.Name, capFilter)
DsError.ThrowExceptionForHR(hr)
baseGrabFlt = DirectCast(sampGrabber, IBaseFilter)
ConfigureSampleGrabber(sampGrabber)
' Add the frame grabber to the graph
hr = m_graphBuilder.AddFilter(baseGrabFlt, "Ds.NET Grabber")
DsError.ThrowExceptionForHR(hr)
' If any of the default config items are set
If (iFrameRate + iHeight + iWidth > 0) Then
SetConfigParms(capGraph, capFilter, iFrameRate, iWidth, iHeight)
End If
hr = capGraph.RenderStream(PinCategory.Capture, MediaType.Video, capFilter, baseGrabFlt, muxFilter)
DsError.ThrowExceptionForHR(hr)
'if you set the m_takePicture it won't
If Not m_takePicture Then
'Set the output of the preview
hr = mediaEventEx.SetNotifyWindow(UseHand, WMGraphNotify, IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
'Set Owner to Display Video
hr = videoWindow.put_Owner(UseHand)
DsError.ThrowExceptionForHR(hr)
'Set window location - this was necessary so that the video didn't move down and to the right when you pushed the start/stop button
hr = videoWindow.SetWindowPosition(0, 0, 320, 240)
DsError.ThrowExceptionForHR(hr)
'Set Owner Video Style
hr = videoWindow.put_WindowStyle(WindowStyle.Child)
DsError.ThrowExceptionForHR(hr)
End If
SaveSizeInfo(sampGrabber)
Finally
If (Not fileWriterFilter Is Nothing) Then
Marshal.ReleaseComObject(fileWriterFilter)
fileWriterFilter = Nothing
End If
If (Not muxFilter Is Nothing) Then
Marshal.ReleaseComObject(muxFilter)
muxFilter = Nothing
End If
If (Not capFilter Is Nothing) Then
Marshal.ReleaseComObject(capFilter)
capFilter = Nothing
End If
If (Not sampGrabber Is Nothing) Then
Marshal.ReleaseComObject(sampGrabber)
sampGrabber = Nothing
End If
End Try
End Sub
' <summary> Read and store the properties </summary>
Private Sub SaveSizeInfo(ByVal sampGrabber As ISampleGrabber)
Dim hr As Integer
' Get the media type from the SampleGrabber
Dim media As AMMediaType = New AMMediaType()
hr = sampGrabber.GetConnectedMediaType(media)
DsError.ThrowExceptionForHR(hr)
If (Not (media.formatType.Equals(FormatType.VideoInfo)) AndAlso Not (media.formatPtr.Equals(IntPtr.Zero))) Then
Throw New NotSupportedException("Unknown Grabber Media Format")
End If
' Grab the size info
Dim vInfoHeader As VideoInfoHeader = New VideoInfoHeader()
Marshal.PtrToStructure(media.formatPtr, vInfoHeader)
m_videoWidth = vInfoHeader.BmiHeader.Width
m_videoHeight = vInfoHeader.BmiHeader.Height
m_stride = CInt(m_videoWidth * (vInfoHeader.BmiHeader.BitCount/8))
DsUtils.FreeAMMediaType(media)
media = Nothing
End Sub
' <summary> Set the options on the sample grabber </summary>
Private Sub ConfigureSampleGrabber(ByVal sampGrabber As ISampleGrabber)
Dim hr As Integer
Dim media As AMMediaType = New AMMediaType()
media.majorType = MediaType.Video
media.subType = MediaSubType.RGB24
media.formatType = FormatType.VideoInfo
hr = sampGrabber.SetMediaType(media)
DsError.ThrowExceptionForHR(hr)
DsUtils.FreeAMMediaType(media)
media = Nothing
' Configure the samplegrabber callback
hr = sampGrabber.SetOneShot(False)
DsError.ThrowExceptionForHR(hr)
If m_takePicture Then
hr = sampGrabber.SetCallback(Me, 0)
Else
hr = sampGrabber.SetCallback(Me, 0)
End If
DsError.ThrowExceptionForHR(hr)
DsError.ThrowExceptionForHR(hr)
'set the samplegrabber
sampGrabber.SetBufferSamples(False)
End Sub
' Set the Framerate, and video size
Private Sub SetConfigParms(ByVal capGraph As ICaptureGraphBuilder2, ByVal capFilter As IBaseFilter, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim hr As Integer
Dim o As Object = Nothing
Dim media As AMMediaType = Nothing
Dim videoStreamConfig As IAMStreamConfig
Dim videoControl As IAMVideoControl = DirectCast(capFilter, IAMVideoControl)
' Find the stream config interface
hr = capGraph.FindInterface(PinCategory.Capture, MediaType.Video, capFilter, GetType(IAMStreamConfig).GUID, o)
videoStreamConfig = DirectCast(o, IAMStreamConfig)
Try
If (videoStreamConfig Is Nothing) Then
Throw New Exception("Failed to get IAMStreamConfig")
End If
' Get the existing format block
hr = videoStreamConfig.GetFormat(media)
DsError.ThrowExceptionForHR(hr)
' copy out the videoinfoheader
Dim v As VideoInfoHeader = New VideoInfoHeader()
Marshal.PtrToStructure(media.formatPtr, v)
' if overriding the framerate, set the frame rate
If (iFrameRate > 0) Then
v.AvgTimePerFrame = CLng(10000000/iFrameRate)
End If
' if overriding the width, set the width
If (iWidth > 0) Then
v.BmiHeader.Width = iWidth
End If
' if overriding the Height, set the Height
If (iHeight > 0) Then
v.BmiHeader.Height = iHeight
End If
' Copy the media structure back
Marshal.StructureToPtr(v, media.formatPtr, False)
' Set the new format
hr = videoStreamConfig.SetFormat(media)
If hr <> 0 Then unsupportedVideo = True Else unsupportedVideo = False
DsError.ThrowExceptionForHR(hr)
DsUtils.FreeAMMediaType(media)
media = Nothing
' Fix upsidedown video
If (Not videoControl Is Nothing) Then
Dim pCapsFlags As VideoControlFlags
Dim pPin As IPin = DsFindPin.ByCategory(capFilter, PinCategory.Capture, 0)
hr = videoControl.GetCaps(pPin, pCapsFlags)
DsError.ThrowExceptionForHR(hr)
If (CDbl(pCapsFlags & VideoControlFlags.FlipVertical) > 0) Then
hr = videoControl.GetMode(pPin, pCapsFlags)
DsError.ThrowExceptionForHR(hr)
hr = videoControl.SetMode(pPin, 0)
End If
End If
Finally
Marshal.ReleaseComObject(videoStreamConfig)
End Try
End Sub
' <summary> Shut down capture </summary>
Private Sub CloseInterfaces()
Dim hr As Integer
Try
If (Not m_mediaCtrl Is Nothing) Then
' Stop the graph
hr = m_mediaCtrl.Stop()
m_mediaCtrl = Nothing
m_bRunning = False
'Release Window Handle, Reset back to Normal
hr = videoWindow.put_Visible(OABool.False)
DsError.ThrowExceptionForHR(hr)
hr = videoWindow.put_Owner(IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
If mediaEventEx Is Nothing = False Then
hr = mediaEventEx.SetNotifyWindow(IntPtr.Zero, 0, IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
End If
End If
Catch ex As Exception
Debug.WriteLine(ex)
End Try
#If DEBUG Then
If (Not m_rot Is Nothing) Then
m_rot.Dispose()
m_rot = Nothing
End If
#End If
If (Not m_graphBuilder Is Nothing) Then
Marshal.ReleaseComObject(m_graphBuilder)
m_graphBuilder = Nothing
End If
GC.Collect()
End Sub
' <summary> sample callback, Originally not used - call this with integer 0 on the setcallback method </summary>
Function SampleCB(ByVal SampleTime As Double, ByVal pSample As IMediaSample) As Integer Implements ISampleGrabberCB.SampleCB
myTest = "In SampleCB"
Dim i As Integer = 0
'jk added this code 10-22-13
If IsDBNull(pSample) = True Then Return -1
Dim myLen As Integer = pSample.GetActualDataLength()
Dim pbuf As IntPtr
If pSample.GetPointer(pbuf) = 0 And mylen > 0 Then
Dim buf As Byte() = New Byte(myLen) {}
Marshal.Copy(pbuf, buf, 0, myLen)
'Alter the video - you could use this to adjust the brightness/red/green, etc.
'for i = myLen-1 to 0 step -1
' buf(i) = (255 - buf(i))
'Next i
If m_takePicture Then
Dim bm As New Bitmap(m_videoWidth, m_videoHeight, Imaging.PixelFormat.Format24bppRgb)
Dim g_RowSizeBytes As Integer
Dim g_PixBytes() As Byte
mytest = "Execution point #1"
Dim m_BitmapData As BitmapData = Nothing
Dim bounds As Rectangle = New Rectangle(0, 0, m_videoWidth, m_videoHeight)
mytest = "Execution point #2"
m_BitmapData = bm.LockBits(bounds, Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format24bppRgb)
mytest = "Execution point #4"
g_RowSizeBytes = m_BitmapData.Stride
mytest = "Execution point #5"
' Allocate room for the data.
Dim total_size As Integer = m_BitmapData.Stride * m_BitmapData.Height
ReDim g_PixBytes(total_size)
mytest = "Execution point #10"
'this writes the data to the Bitmap
Marshal.Copy(buf, 0, m_BitmapData.Scan0, mylen)
capturedPic = bm
mytest = "Execution point #15"
' Release resources.
bm.UnlockBits(m_BitmapData)
g_PixBytes = Nothing
m_BitmapData = Nothing
bm = Nothing
buf = Nothing
m_takePicture = False
captureSaved = True
mytest = "Execution point #20"
End If
End If
Marshal.ReleaseComObject(pSample)
Return 0
End Function
' <summary> buffer callback, Not used - call this with integer 1 on the setcallback method </summary>
Function BufferCB(ByVal SampleTime As Double, ByVal pBuffer As IntPtr, ByVal BufferLen As Integer) As Integer Implements ISampleGrabberCB.BufferCB
SyncLock Me
myTest = "In BufferCB"
End SyncLock
Return 0
End Function
End Class
有人能幫助實現上述我的目標。 1)枚舉Combobox中的設備 2)將選定的攝像頭設備快照到文件。
任何幫助表示讚賞:)
我想知道我能做到這一點,每一個幫助真的很感激:) – nexno