Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: Harmmy en Diciembre 17, 2012, 02:04:21 pm
-
Where can you find an error? :S
Form1.frm code:
Form1 control command button := command1
Private Sub Command1_Click()
Dim aa As cWebcam
Set aa = New cWebcam
Form2.Show
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set aa = Nothing
End Sub
cWebcam.cls Code:
Private Sub Class_Initialize()
If MWebcam.CreateCaptureWindow Then
Debug.Print "Webcam Penceresi Olusturuldu" 'create webcam window
End If
If MWebcam.DriverConnect Then
Debug.Print "Drivere Baglanıldı" 'connect driver
End If
End Sub
mWebcam.bas code
Private Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ImageCodecPNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const GdiPlusVersion As Long = 1&
Private Const WM_USER As Long = &H400
Private Const WM_CAP_START As Long = WM_USER
Private Const WM_CAP_SET_CALLBACK_FRAME As Long = WM_CAP_START + 5
Private Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Private Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Private Const WM_CAP_GET_VIDEOFORMAT As Long = WM_CAP_START + 44
Private Const WM_CAP_GRAB_FRAME As Long = WM_CAP_START + 60
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
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(15) As EncoderParameter
End Type
Public Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAPINFO256
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 255) As RGBQUAD
End Type
Private Type VIDEOHDR
lpData As Long
dwBufferLength As Long
dwBytesUsed As Long
dwTimeCaptured As Long
dwUser As Long
dwFlags As Long
dwReserved(3) As Long
End Type
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt As Long
End Type
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Integer, ByVal hwndParent As Long, ByVal nID As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal Image As Long, ByVal Stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Function GdipCreateBitmapFromGdiDib Lib "GdiPlus.dll" (ByRef mGdiBitmapInfo As Any, ByVal mGdiBitmapData As Long, ByRef mBitmap As Long) As Long
Private Declare Function DrawDibOpen Lib "msvfw32.dll" () As Long
Private Declare Function DrawDibClose Lib "msvfw32.dll" (ByVal hdd As Long) As Long
Private Declare Function DrawDibDraw Lib "msvfw32.dll" (ByVal hdd As Long, ByVal hdc As Long, ByVal xDst As Long, ByVal yDst As Long, ByVal dxDst As Long, ByVal dyDst As Long, ByRef lpbi As BITMAPINFOHEADER, lpBits As Any, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dxSrc As Long, ByVal dySrc As Long, ByVal wFlags As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, ByRef BITMAP As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As Any, ByRef Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, ByRef hbmReturn As Long, ByVal background As Long) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICTDESC, riid As GUID, ByVal fOwn As Boolean, lplpvObj As Object)
Public hwndCap As Long
Public m_hImage As Long
Public Function CreateCaptureWindow() As Boolean
hwndCap = capCreateCaptureWindowA(vbNullString, 0&, 0&, 0&, 0&, 0&, 0&, 0&)
If hwndCap Then
Call SendMessage(hwndCap, WM_CAP_SET_CALLBACK_FRAME, 0, AddressOf FrameCallBack)
CreateCaptureWindow = True
End If
End Function
Public Function DriverConnect() As Boolean
If hwndCap Then ConnectDriver = SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0&, 0&)
End Function
Public Function DisconnectDriver() As Boolean
If hwndCap Then
Call SendMessage(hwndCap, WM_CAP_SET_CALLBACK_FRAME, 0&, vbNull)
DisconnectDriver = SendMessage(hwndCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End If
End Function
Public Function DestroyCaptureWindow() As Boolean
If hwndCap Then DestroyCaptureWindow = DestroyWindow(hwndCap): hwndCap = 0
End Function
Function capGetVideoFormat(ByVal hCapWnd As Long, ByVal CapFormatSize As Long, ByVal BmpFormat As Long) As Long
capGetVideoFormat = SendMessage(hCapWnd, WM_CAP_GET_VIDEOFORMAT, CapFormatSize, BmpFormat)
End Function
Public Function capGetImageStream(ByRef outStream() As Byte, Optional ByVal JPG_Quality As Long = 80) As Boolean
Dim GdipToken As Long
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = GdiPlusVersion
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
If GdipToken Then
Call SendMessage(hwndCap, WM_CAP_GRAB_FRAME, ByVal 0&, ByVal 0&)
If m_hImage Then
capGetImageStream = SaveImageToStream(m_hImage, outStream, JPG_Quality)
GdipDisposeImage m_hImage
End If
Call GdiplusShutdown(GdipToken)
End If
End Function
Public Function SaveImageToStream(ByVal hImage As Long, ByRef outStream() As Byte, Optional ByVal JPG_Quality As Long = 80, Optional ByVal PNGFormat As Boolean) As Boolean
Dim IIStream As IUnknown
Dim tEncoder As GUID
Dim tParams As EncoderParameters
Erase outStream
Set IIStream = CreateStream(outStream)
If Not IIStream Is Nothing Then
If PNGFormat Then
CLSIDFromString StrPtr(ImageCodecPNG), tEncoder
If GdipSaveImageToStream(hImage, IIStream, tEncoder, ByVal 0&) = 0& Then
SaveImageToStream = ArrayFromStream(IIStream, outStream())
End If
Else
CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
With tParams
.Count = 1
.Parameter(0).NumberOfValues = 1
.Parameter(0).Type = EncoderParameterValueTypeLong
.Parameter(0).Value = VarPtr(JPG_Quality)
CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
End With
If GdipSaveImageToStream(hImage, IIStream, tEncoder, tParams) = 0& Then
SaveImageToStream = ArrayFromStream(IIStream, outStream())
End If
End If
End If
End Function
Private Function CreateStream(byteContent() As Byte, Optional byteOffset As Long = 0&) As stdole.IUnknown
On Error GoTo HandleError
Dim o_lngLowerBound As Long
Dim o_lngByteCount As Long
Dim o_hMem As Long
Dim o_lpMem As Long
If iparseIsArrayEmpty(VarPtrArray(byteContent)) = 0& Then ' create a growing stream as needed
Call CreateStreamOnHGlobal(0, 1, CreateStream)
Else ' create a fixed stream
o_lngByteCount = UBound(byteContent) - byteOffset + 1
o_hMem = GlobalAlloc(&H2&, o_lngByteCount)
If o_hMem <> 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
CopyMemory ByVal o_lpMem, byteContent(byteOffset), o_lngByteCount
Call GlobalUnlock(o_hMem)
Call CreateStreamOnHGlobal(o_hMem, 1, CreateStream)
End If
End If
End If
Exit Function
HandleError:
End Function
Public Function iparseIsArrayEmpty(FarPointer As Long) As Long
' test to see if an array has been initialized
CopyMemory iparseIsArrayEmpty, ByVal FarPointer, 4&
End Function
Private Function ArrayFromStream(Stream As IUnknown, arrayBytes() As Byte) As Boolean
Dim o_hMem As Long, o_lpMem As Long
Dim o_lngByteCount As Long
If Not Stream Is Nothing Then
If GetHGlobalFromStream(ByVal ObjPtr(Stream), o_hMem) = 0 Then
o_lngByteCount = GlobalSize(o_hMem)
If o_lngByteCount > 0 Then
o_lpMem = GlobalLock(o_hMem)
If o_lpMem <> 0 Then
ReDim arrayBytes(0 To o_lngByteCount - 1)
CopyMemory arrayBytes(0), ByVal o_lpMem, o_lngByteCount
GlobalUnlock o_hMem
ArrayFromStream = True
End If
End If
End If
End If
End Function
Private Function FrameCallBack(ByVal lWnd As Long, ByVal lpVHdr As Long) As Long
Dim VideoHeader As VIDEOHDR
Dim StreamBMI As BITMAPINFO
Dim DrawDibhDC As Long
Dim ScreenhDC As Long
Dim BMhDC As Long
Dim BMHandle As Long
Dim BMHandleOld As Long
Dim hImage As Long
Dim hGraphic As Long
CopyMemory VideoHeader, ByVal lpVHdr, Len(VideoHeader)
capGetVideoFormat lWnd, Len(StreamBMI), VarPtr(StreamBMI)
If StreamBMI.bmiHeader.biCompression = 0 Then
Call GdipCreateBitmapFromGdiDib(StreamBMI, VideoHeader.lpData, m_hImage)
Else
ScreenhDC = GetDC(0&)
BMhDC = CreateCompatibleDC(ScreenhDC) 'BMhDC = CreateCompatibleDC(ScreenhDC)
BMHandle = CreateCompatibleBitmap(ScreenhDC, StreamBMI.bmiHeader.biWidth, StreamBMI.bmiHeader.biHeight) 'BMHandle = CreateCompatibleBitmap(ScreenhDC, StreamBMI.bmiHeader.biWidth, StreamBMI.bmiHeader.biHeight)
BMHandleOld = SelectObject(BMhDC, BMHandle) 'BMHandleOld = SelectObject(BMhDC, BMHandle)
Call ReleaseDC(0&, ScreenhDC) 'ReleaseDC ScreenhWnd, ScreenhDC
DrawDibhDC = DrawDibOpen 'DrawDibhDC = DrawDibOpen
Call DrawDibDraw(DrawDibhDC, BMhDC, 0, 0, -1, -1, StreamBMI.bmiHeader, ByVal VideoHeader.lpData, 0, 0, StreamBMI.bmiHeader.biWidth, StreamBMI.bmiHeader.biHeight, 0)
Call DrawDibClose(DrawDibhDC) 'DrawDibClose DrawDibhDC
Call SelectObject(BMhDC, BMHandleOld) 'SelectObject BMhDC, BMHandleOld
Call DeleteDC(BMhDC) 'DeleteDC BMhDC
Call DeleteObject(BMHandleOld) 'DeleteObject BMHandleOld
Call GdipCreateBitmapFromHBITMAP(BMHandle, 0&, m_hImage)
Call DeleteObject(BMHandle) 'DeleteObject BMHandle
End If
End Function
Public Function LoadPictureFromStream(ByRef bvData() As Byte) As StdPicture
Dim IStream As IUnknown
Dim gToken As Long
Dim tRect As RECTF
Dim hImage As Long
Dim hBitmap As Long
Dim hGraphics As Long
Dim pLeft As Single
Dim pTop As Single
Dim GDIsi As GDIPlusStartupInput
If iparseIsArrayEmpty(VarPtrArray(bvData)) = 0& Then Exit Function
Set IStream = CreateStream(bvData())
If Not IStream Is Nothing Then
GDIsi.GdiPlusVersion = 1&
GdiplusStartup gToken, GDIsi
If gToken Then
If GdipLoadImageFromStream(IStream, hImage) = 0 Then
If GdipCreateHBITMAPFromBitmap(hImage, hBitmap, 0) = 0 Then
Set LoadPictureFromStream = HandleToPicture(hBitmap, vbPicTypeBitmap)
End If
GdipDisposeImage hImage
End If
GdiplusShutdown gToken
End If
Set IStream = Nothing
End If
End Function
Private Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants, Optional ByVal hPal As Long = 0) As StdPicture
Dim tPictDesc As PICTDESC
Dim IID_IPicture As GUID
Dim oPicture As IPicture
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = ObjectType
.hgdiObj = hGDIHandle
.hPalOrXYExt = hPal
End With
CLSIDFromString StrPtr(PictureID), IID_IPicture
OleCreatePictureIndirect tPictDesc, IID_IPicture, True, oPicture
Set HandleToPicture = oPicture
End Function
Form2.frm code
Private StPic As StdPicture
Private Sub Form_Load()
Me.AutoRedraw = True
Me.Cls
DoEvents
EkranResminiAl
End Sub
Private Sub Timer1_Timer()
Timer1.Enabled = False
EkranResminiAl
End Sub
Function EkranResminiAl()
On Local Error Resume Next
Dim arrBytes() As Byte
If hwndCap Then
If capGetImageStream(arrBytes, 1) Then
DoEvents
Me.Cls
Set StPic = LoadPictureFromStream(arrBytes)
End If
End If
If Not StPic Is Nothing Then
Render StPic
End If
Me.Refresh
Timer1.Enabled = True
End Function
Public Function Render(ByVal Img As StdPicture)
Dim pLeft As Long, pTop As Long
Dim ReqWidth As Long, ReqHeight As Long
Dim HScale As Double, VScale As Double
Dim MyScale As Double
Dim ImgWidth As Long
Dim ImgHeight As Long
ImgWidth = Me.ScaleX(Img.Width, vbHimetric, vbPixels)
ImgHeight = Me.ScaleY(Img.Height, vbHimetric, vbPixels)
HScale = Me.ScaleWidth / ImgWidth
VScale = (Me.ScaleHeight - ucToolbar1.Height) / ImgHeight
MyScale = IIf(VScale >= HScale, HScale, VScale)
ReqWidth = ImgWidth * MyScale
ReqHeight = ImgHeight * MyScale
pLeft = (Me.ScaleWidth - ReqWidth) / 2
pTop = (ucToolbar1.Height / 2) + (Me.ScaleHeight - ReqHeight) / 2
Me.PaintPicture Img, pLeft, pTop, ReqWidth, ReqHeight
End Function
Private Sub Form_Unload(Cancel As Integer)
DisconnectDriver
DestroyCaptureWindow
End Sub
-
Debug is debug code:
Err.Description & " " & Err.Number
Object variable or With block variable not set 91
-
a tip, always use "Option Explicit" So you can find bugs faster
point one
Error
Public Function DriverConnect() As Boolean
If hwndCap Then ConnectDriver = SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0&, 0&)
End Function
the function name is DriverConnect, but placed in the middle ConnectDriver
Correct
Public Function DriverConnect() As Boolean
If hwndCap Then DriverConnect= SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0&, 0&)
End Function
point two
declare PictureID
Const PictureID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
point three
remove operations ucToolbar1.Height
point four
capGetImageStream(arrBytes, 1) is a very low quality, use 80 or 50
Greetings.
-
please sample project ?