7,765
社区成员
发帖
与我相关
我的任务
分享请发表友善的回复…
发表回复
user88888888 2010-06-17
- 打赏
- 举报
kankan
cbm6666 2010-01-09
- 打赏
- 举报
在桌面 属性设置 高级 疑难解答 将 硬件加速 拖到 无 试下看吧.
jimyy 2010-01-09
- 打赏
- 举报
问题在这里---if Findvideo = False then。。。。。
false 改为 True
否则，Preview_Handle 没有赋值，图像不知向哪里输出。
false 改为 True
否则，Preview_Handle 没有赋值，图像不知向哪里输出。
K-dash 2010-01-03
- 打赏
- 举报
－ － 还没想过这样
LUOLZD001 2010-01-02
- 打赏
- 举报
学习中
追求者2 2009-12-31
- 打赏
- 举报
只要换个有驱的摄像头就可以用,奇了怪了
追求者2 2009-12-30
- 打赏
- 举报
试了老马的这个程序,结果还是黑,我哭啊
Jeff_youzi 2009-12-30
- 打赏
- 举报
老马这个不错。
嗷嗷叫的老马 2009-12-30
- 打赏
- 举报
那你跟踪一下,看看为什么会黑.
嗷嗷叫的老马 2009-12-29
- 打赏
- 举报
贝隆 2009-12-29
- 打赏
- 举报
学习。。。
baije130 2009-12-29
- 打赏
- 举报
关注...
我也碰到同样的问题,求解
贴出我所用的代码(代码来源于网上,经过一定修改):
'主窗口,联接摄像头
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
Dim a As Integer
Dim CamErr As Boolean
Dim msg As Boolean
Private Function CapturePicture(nCaptureHandle As Long) As StdPicture
Clipboard.Clear
SendMessage nCaptureHandle, WM_CAP_EDIT_COPY, 0, 0
Set CapturePicture = Clipboard.GetData
If CapturePicture = 0 Then
CamErr = True
Else:
CamErr = False
End If
End Function
Private Sub Form_Load()
On Error Resume Next
Me.Visible = True
a = 0
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, Flags
Me.Timer1.Interval = 1000
msg = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
End Sub
Private Sub CamCont()
Preview_Handle = capCreateCaptureWindow("Video", WS_CHILD + WS_VISIBLE, 2, 2, 640, 480, Me.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 CameStar()
CapturePicture Preview_Handle
If CamErr = False Then PictureBoxSaveJPG CapturePicture(Preview_Handle), App.Path & "\ok.jpg"
If CamErr = True Then MsgBox "无法联接摄像头,你需要手动拍摄!"
SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags
Unload Me
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
If Findvideo = False Then
a = a + 1
If a = 1 Then Call CamCont
If a = 4 Then Call CameStar
Else
a = 0
If msg = False Then MsgBox "有其它程序正在使用摄像头,请先停止其它程序!": msg = True
End If
End Sub
'监控是否有其它程序在使用摄像头
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 SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags 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 lngProcID As Long
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
'存为JPG模块
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByValoutputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
'Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解码器的GUID标识
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'设置解码器参数
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
'销毁GDI+图像
GdipDisposeImage lBitmap
End If
'销毁 GDI+
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
'窗体前置,不然拍不了图片
'窗体在load事件中添加如下的代码
'SetWindowPos Me.hwnd, HWND_TOPMOST,0, 0, 0, 0, Flags '前置
' SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags '不前置
Public Declare Function SetWindowPos Lib "user32" _
( _
ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
'以上为API函数声明
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_FRAMECHANGED = &H20
'The frame changed: send WM_NCCALCSIZE
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'以上为程序中用到的常量
Public Const HWND_BOTTOM = 1
Public Const HWND_BROADCAST = &HFFFF&
Public Const HWND_DESKTOP = 0
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOOWNERZORDER = &H200
'Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SWP_NOZORDER = &H4
Public Const SWP_SHOWWINDOW = &H40
'以上常量声明在程序中没有使用
'可以试着在调用SetWindowPos函数时使用这些常量或它们的组合
'得到其他效果
Public Const Flags = SWP_DRAWFRAME Or SWP_NOMOVE Or SWP_NOSIZE
我也碰到同样的问题,求解
贴出我所用的代码(代码来源于网上,经过一定修改):
'主窗口,联接摄像头
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
Dim a As Integer
Dim CamErr As Boolean
Dim msg As Boolean
Private Function CapturePicture(nCaptureHandle As Long) As StdPicture
Clipboard.Clear
SendMessage nCaptureHandle, WM_CAP_EDIT_COPY, 0, 0
Set CapturePicture = Clipboard.GetData
If CapturePicture = 0 Then
CamErr = True
Else:
CamErr = False
End If
End Function
Private Sub Form_Load()
On Error Resume Next
Me.Visible = True
a = 0
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, Flags
Me.Timer1.Interval = 1000
msg = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
End Sub
Private Sub CamCont()
Preview_Handle = capCreateCaptureWindow("Video", WS_CHILD + WS_VISIBLE, 2, 2, 640, 480, Me.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 CameStar()
CapturePicture Preview_Handle
If CamErr = False Then PictureBoxSaveJPG CapturePicture(Preview_Handle), App.Path & "\ok.jpg"
If CamErr = True Then MsgBox "无法联接摄像头,你需要手动拍摄!"
SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags
Unload Me
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
If Findvideo = False Then
a = a + 1
If a = 1 Then Call CamCont
If a = 4 Then Call CameStar
Else
a = 0
If msg = False Then MsgBox "有其它程序正在使用摄像头,请先停止其它程序!": msg = True
End If
End Sub
'监控是否有其它程序在使用摄像头
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 SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags 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 lngProcID As Long
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
'存为JPG模块
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByValoutputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
'Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解码器的GUID标识
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'设置解码器参数
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
'销毁GDI+图像
GdipDisposeImage lBitmap
End If
'销毁 GDI+
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
'窗体前置,不然拍不了图片
'窗体在load事件中添加如下的代码
'SetWindowPos Me.hwnd, HWND_TOPMOST,0, 0, 0, 0, Flags '前置
' SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags '不前置
Public Declare Function SetWindowPos Lib "user32" _
( _
ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
'以上为API函数声明
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_FRAMECHANGED = &H20
'The frame changed: send WM_NCCALCSIZE
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
'以上为程序中用到的常量
Public Const HWND_BOTTOM = 1
Public Const HWND_BROADCAST = &HFFFF&
Public Const HWND_DESKTOP = 0
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOOWNERZORDER = &H200
'Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SWP_NOZORDER = &H4
Public Const SWP_SHOWWINDOW = &H40
'以上常量声明在程序中没有使用
'可以试着在调用SetWindowPos函数时使用这些常量或它们的组合
'得到其他效果
Public Const Flags = SWP_DRAWFRAME Or SWP_NOMOVE Or SWP_NOSIZE
