VB不用控件联接摄像头
VB 不用控件联接摄像头，并保存图片为JPG我已于网上找到代码并实现了，并且用监视窗口的形式可以确定是否有其它程序在使用摄像头了，但碰到USB摄像头是联接就失效，
请各位大侠提供下VB 下能联接所有摄像头的代码，特别是USB的，谢谢了！
我只有这点分了，全给了，谢谢大大
以下代码为监控其它程序是否在使用摄像头的方法，请各位测试
'if Findvideo() = True then '其它程序正在使用摄像头
'if Findvideo() = False then '其它程序没有使用摄像头
Type wndClass
style As Long
lpfnwndproc As Long
cbClsextra As Long
cbWndExtra2 As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Function Findvideo() As Boolean
On Error Resume Next
Dim txtTitle As String
Dim lngHand As Long
Dim strName As String * 255
Dim wndClass As wndClass
Dim lngProcID As Long
Dim rctTemp As RECT
Findvideo = False
txtTitle = "ActiveMovie Window" '发现所有使用摄像头时都打开这个窗口"
lngHand = FindWindow(vbNullString, txtTitle)
GetClassName lngHand, strName, Len(strName)
GetWindowThreadProcessId lngHand, lngProcID
lblProcessID = lngProcID
If Left$(strName, 1) = vbNullChar Then
Findvideo = False
Else
If lblProcessID <> GetCurrentProcessId Then Findvideo = True ‘使用程序不是自已
End If
End Function
[解决办法]
在VB里如果不用控件，只有两种方法
1、使用 VFW 技术截取摄像头数据，不过必须先能显示出图像，至少一个橡数点，
否则捕获函数不会被触发。
2、直接与驱动程序通讯，什么 IRQ 呀、HidD_GetHidGuid、SetupDiGetClassDevs、
WriteFile、ReadFile的，过程就要复杂很多了，通常不是一般人做的事情
比较好的方式是使用 DirectShow，不过微软的 DirectShow 对VB支持得不多，
标准支持是 VC，所以如果要用 DirectShow 技术，用 VC 比较合适，在
DirectX SDK 中有相关范例，你可以参考一下
[解决办法]
http://topic.csdn.net/u/20091229/17/a2521ab2-141e-4c71-a928-1f1d9fa4f98c.html
一一试下里面的代码吧
[解决办法]
USB摄像头
添加 Picture1 Timer1
Option Explicit '强制宣告定义变量
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 CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private Const GET_FRAME As Long = 1084
Private Const COPY As Long = 1054
Dim AppDisk$, CapHwnd& '定义变量
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
Picture1.BorderStyle = 0
Picture1.Width = 640 * Screen.TwipsPerPixelX
Picture1.Height = 480 * Screen.TwipsPerPixelY
Timer1.Interval = 50
Call STARTCAM
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call STOPCAM
Set Form1 = Nothing
End Sub
Private Sub Picture1_Click()
SavePicture Picture1.Image, AppDisk & "Catch.bmp"
End Sub
Sub STARTCAM()
CapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Me.hwnd, 0)
DoEvents
SendMessage CapHwnd, CONNECT, 0, 0
Timer1.Enabled = True
End Sub
Sub STOPCAM()
DoEvents: SendMessage CapHwnd, DISCONNECT, 0, 0
Timer1.Enabled = False
End Sub
Private Sub Timer1_Timer()
SendMessage CapHwnd, GET_FRAME, 0, 0
SendMessage CapHwnd, COPY, 0, 0
Picture1.Picture = Clipboard.GetData
End Sub
[解决办法]
用这个SDK包好了：http://www.anychat.cn
[解决办法]
发个才写的。XP下没问题。不用设置。win7下不稳定。代码如下：
'============================================================================================
'定义系统时间精确到毫秒
'============================================================================================
Private Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'============================================================================================
'定义全局变量i.用于存放当前的年月日小时分钟秒毫秒。例如i=201007151532585
'============================================================================================
Dim i
'============================================================================================
'摄像头API声明部分
'============================================================================================
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 WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_USER = &H400
Private Const WM_CAP_START = &H400
Private Const WM_CAP_EDIT_COPY = (WM_CAP_START + 30)
Private Const WM_CAP_DRIVER_CONNECT = (WM_CAP_START + 10)
Private Const WM_CAP_SET_PREVIEWRATE = (WM_CAP_START + 52)
Private Const WM_CAP_SET_OVERLAY = (WM_CAP_START + 51)
Private Const WM_CAP_SET_PREVIEW = (WM_CAP_START + 50)
Private Const WM_CAP_DRIVER_DISCONNECT = (WM_CAP_START + 11)
Private Preview_Handle As Long
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
'============================================================================================
'重定义变量CapturePicture
'============================================================================================
Private Function CapturePicture(nCaptureHandle As Long) As StdPicture
Clipboard.Clear
SendMessage nCaptureHandle, WM_CAP_EDIT_COPY, 0, 0
Set CapturePicture = Clipboard.GetData
End Function
'============================================================================================
'程序加载时将摄像头内容打印到PictureBOX上。 0,0 代表起点坐标。640 480代表分辨率
'============================================================================================
Private Sub Form_Load()
Preview_Handle = capCreateCaptureWindow("Video", WS_CHILD + WS_VISIBLE, 0, 0, 640, 480, picView.hwnd, 1)
SendMessage Preview_Handle, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage Preview_Handle, WM_CAP_SET_PREVIEWRATE, 1, 0
SendMessage Preview_Handle, WM_CAP_SET_PREVIEW, 1, 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
End Sub
'============================================================================================
'调出关于菜单
'============================================================================================
Private Sub imgAbout_Click()
frmAbout.Show
Me.Enabled = False
End Sub
Private Sub imgAbout_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgAbout.BorderStyle = 1
End Sub
Private Sub imgAbout_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgAbout.BorderStyle = 0
End Sub
'============================================================================================
'当前图像存盘
'============================================================================================
Private Sub imgGetphoto_Click()
picView.Picture = CapturePicture(Preview_Handle)
SavePicture picView.Picture, App.Path & "\" & i & ".bmp"
End Sub
Private Sub imgGetphoto_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgGetphoto.BorderStyle = 1
End Sub
Private Sub imgGetphoto_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
imgGetphoto.BorderStyle = 0
End Sub
'============================================================================================
'获取当前年月日时分秒毫秒，格式为:年月日时分秒毫秒。同时在1-9月份前补0.
'============================================================================================
Private Sub timClock_Timer()
Dim t As SYSTEMTIME
GetLocalTime t
Cls
i = t.wMonth
If i < 10 Then
i = 0 & t.wMonth
End If
i = t.wYear & i & t.wDay & t.wHour & t.wMinute & t.wSecond & t.wMilliseconds
End Sub
