LoadImageStream Byte Me.PaintPicture Help :s ?

[Harmmy]

Where can you find an error? :S

Form1.frm code:
Form1 control command button := command1

Código: (VB) [Seleccionar]

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:

Código: (VB) [Seleccionar]

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

Código: (VB) [Seleccionar]

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

Código: (VB) [Seleccionar]

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



[Harmmy]

Debug is debug code:

Err.Description & " "  & Err.Number
Object variable or With block variable not set 91

[LeandroA]

a tip, always use "Option Explicit" So you can find bugs faster

point one

Error

Código: [Seleccionar]

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

Código: [Seleccionar]

Public Function DriverConnect() As Boolean
If hwndCap Then DriverConnect= SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0&, 0&)
End Function
point two
declare PictureID

Código: [Seleccionar]

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.

[Harmmy]

please sample project ?