首页 诗词 字典 板报 句子 名言 友答 励志 学校 网站地图
当前位置: 首页 > 教程频道 > 开发语言 > VB >

VB不要控件联接摄像头

2013-01-02 
VB不用控件联接摄像头VB 不用控件联接摄像头,并保存图片为JPG我已于网上找到代码并实现了,并且用监视窗口

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

热点排行