VBNet - Форум - Помогите с Direct Show

Вопрос: Помогите с Direct Show Добавлено: 28.11.08 12:43

Автор вопроса: KreAtoR

У меня возникла проблема. Вывожу видео с вэб камеры через DShow. После того как я устанавливаю окно видео на неоходимую мне позицию, то видео сигнал остается таким размером как и был.

Подскажите как уменьшить размер исходного видео, чтобы оно залазило в окно выделенное для этого видео.

Вот что у меня есть

MAIN.frm

Private cap As clsDShow

Private Sub Form_Load()
    Init_DShow
End Sub

Private Sub Init_DShow()
    Set cap = New clsDShow
      'здесь вы можете выбрать device
    'cap.RefreshRegFilters 10, 10, 5000, True
    cap.SetSource "Videum 1.1 Standard VidCap"
    cap.SetImage "2007-Lamborghini-Embolado-Concept-Luca-Serafini-4.jpg"
    cap.SetFrame Main.Frame1
    cap.PreviewSource
    'cap.PreviewImage
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set cap = Nothing
End Sub

Class Direct Show (clsDShow.cls)


    'option explicit



    ' GDI functions to draw a DIBSection into a DC
    Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "GDI32" (ByVal hdc As Long, ByVal hbitmap As Long) As Long
    Private Declare Function BitBlt Lib "GDI32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
        ByVal width As Long, ByVal height As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, _
        ByVal ySrc As Long, ByVal mode As Long) As Long
    Private Declare Sub DeleteDC Lib "GDI32" (ByVal hdc As Long)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal count As Long)
    Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long

    ' non-portable (win32 only) types and functions to
    ' convert a bitmap into a safe array of bytes
    Private Type SAFEARRAYBOUND
        cElements As Long
        lLbound As Long
    End Type
    Private Type SAFEARRAY
        cDims As Integer
        fFeatures As Integer
        cbElements As Long
        cLocks As Long
        pvData As Long
        rgsabound(0 To 1) As SAFEARRAYBOUND
    End Type

    Dim gGraph As IMediaControl
    Dim gVidWindow As IVideoWindow
    Dim gRegFilters As Object
    Dim gCapStill As VBGrabber
    Dim gBasAudio As IBasicAudio
    Dim gBasVideo As IBasicVideo
    Dim gBasVideo2 As IBasicVideo2
    Dim gMedEvent As IMediaEvent
    Dim gMedPosition As IMediaPosition
    'Dim gState As GraphState

    Dim WithEvents comboBox As VB.comboBox

    Dim dShow_source As String
    Dim imageName As String
    Dim frame As Object

Public Sub StartDShow()
    If CLng(gMedPosition.CurrentPosition) = CLng(gMedPosition.Duration) Then
    gMedPosition.CurrentPosition = 0
End If
Call gGraph.Run
End Sub

Public Sub PauseDShow()
    Call gGraph.Pause
End Sub

Public Sub StopDShow()
    Call gGraph.Stop
    gMedPosition.CurrentPosition = 0
End Sub

Public Sub OpenDShowFile(Filename As String)
    On Local Error GoTo OpenFileError
    Set m_objMediaControl = New FilgraphManager
    Call m_objMediaControl.RenderFile(Filename)

    Set gBasAudio = m_objMediaControl
    gBasAudio.Volume = 0 'Volle Lautst?rke
    gBasAudio.Balance = 0 'Zentrierte Balance

    Set gVidWindow = m_objMediaControl
    gVidWindow.WindowStyle = WS_VISIBLE 'WS_VISIBLE = &H10000000
    gVidWindow.top = 0
    gVidWindow.left = 0
    gVidWindow.width = picTarget.width
    gVidWindow.height = picTarget.height
    gVidWindow.Owner = picTarget.hWnd

    Set m_objMediaEvent = m_objMediaControl

    Set gMedEvent = m_objMediaControl
    gMedPosition.Rate = 1 'Normale Wiedergabegeschwindigkeit

    Exit Sub
OpenFileError:
    Err.Clear
    Resume Next
End Sub

Public Sub RefreshRegFilters(top As Integer, left As Integer, width As Integer, height As Integer, visible As Boolean)
    Init_ComboBox top, left, width, height, visible
    Set gGraph = New FilgraphManager
    Set gRegFilters = gGraph.RegFilterCollection
    Set gCapStill = New VBGrabber
' update the listbox of registered filters
' using the global variable gRegFilters
    Dim filter As IRegFilterInfo
    comboBox.Clear
    If Not gRegFilters Is Nothing Then
        For Each filter In gRegFilters
            comboBox.AddItem filter.name
        Next filter
    End If
    If comboBox.ListCount > 0 Then
        comboBox.ListIndex = 0  ' select first in list
    End If
comboBox.Text = dShow_source

    Set gGraph = Nothing
    Set gRegFilters = Nothing
    Set gCapStill = Nothing

End Sub

Private Sub AddToFrame()
    gVidWindow.WindowStyle = CLng(&H10000000) 'WS_VISIBLE 'WS_VISIBLE = &H10000000
    With frame
        gVidWindow.SetWindowPosition 0, 0, .width, .height
        gVidWindow.Owner = .hWnd
        Dim l, t, w, h As Integer
        l = .left / 15
        t = .top / 15
        w = .width / 15
        h = .height / 15
        gBasVideo.SetDestinationPosition 0, 0, w, h
        gBasVideo.SetSourcePosition 0, 0, w, h

        gBasVideo2.SetDestinationPosition 0, 0, w, h
        gBasVideo2.SetSourcePosition 0, 0, w, h
    End With
End Sub

Private Sub Init_ComboBox(top As Integer, left As Integer, width As Integer, height As Integer, visible As Boolean)
    On Error GoTo errTerminate
    Set comboBox = Nothing
errTerminate:
    Set comboBox = Main.Controls.Add("VB.ComboBox", "comboBox")
    comboBox.Move left, top, width, height
    'ComboBox.Text = "comSourceVideo"
    comboBox.visible = visible
End Sub

Public Sub PreviewSource()
    ' make a new graph
    Set gGraph = Nothing
    Set gCapStill = Nothing
    Set gVidWindow = Nothing
    Set gGraph = New FilgraphManager
    Set gRegFilters = gGraph.RegFilterCollection
    Set gVidWindow = gGraph
    Set gBasVideo = gGraph
    Set gBasVideo2 = gGraph

    ' add the grabber including vb wrapper and default props
    Dim filter As IRegFilterInfo
    Dim fGrab As IFilterInfo
    For Each filter In gRegFilters
        If filter.name = "SampleGrabber" Then
            filter.filter fGrab

            ' wrap this filter in the capstill vb wrapper
            ' also sets rgb-24 media type and other properties
            Set gCapStill = New VBGrabber
            gCapStill.FilterInfo = fGrab
            Exit For
        End If
    Next filter

    ' add the selected source filter
    Dim fSrc As IFilterInfo
    For Each filter In gRegFilters
        If filter.name = dShow_source Then
            filter.filter fSrc
            Exit For
        End If
    Next filter

    ' check for crossbar and select decoder
    Dim xbar As CrossbarInfo
    Set xbar = New CrossbarInfo
    On Error GoTo NoXBar
    xbar.SetFilter fSrc

    Dim idx As Long
    For idx = 0 To xbar.Inputs - 1
        Dim pin As String
        pin = xbar.name(True, idx)
        ' probably you want a dialog listing all input pins
        ' that xbar.CanRoute to the out
        ' or something hardwired like:
        'If pin = "1: Video Composite In" Then
            'xbar.Route idx, 0
            'Exit For
        'End If
    Next idx

    If xbar.Standard <> AnalogVideo_PAL_B Then
        xbar.Standard = AnalogVideo_PAL_B
    End If

NoXBar:
    On Error Resume Next

    ' find first output on src
    Dim pinOut As IPinInfo
    On Error GoTo errOut
    For Each pinOut In fSrc.Pins
        If pinOut.Direction = 1 Then
            Exit For
        End If
errOut:
    Next pinOut

    On Error GoTo errConfig
    'restore specified file before dlg
    Dim pSC As StreamConfig
    Set pSC = New StreamConfig
    pSC.pin = pinOut
    If pSC.SupportsConfig Then
        If Dir$("mtsave.mt") <> "" Then
            On Error GoTo errConfig
            'pSC.Restore ("mtsave.mt")   'als default war eingeschaltet
        End If
    End If
errConfig:
    On Error GoTo errPropOut
    ' show format of output pin before rendering
    Dim ppropOut As PinPropInfo
    Set ppropOut = New PinPropInfo
    ppropOut.pin = pinOut
    'ppropOut.ShowPropPage 0
    ' save selected format to file
    If pSC.SupportsConfig Then
        pSC.SaveCurrentFormat ("mtsave.mt")
    End If
errPropOut:
    On Error GoTo errPinIn
    ' find first input on grabber and connect
    Dim pinIn As IPinInfo
    For Each pinIn In fGrab.Pins
        If pinIn.Direction = 0 Then
            pinOut.Connect pinIn
            Exit For
        End If
    Next pinIn
errPinIn:
    On Error GoTo errPinOut
    ' find grabber output pin and render
    For Each pinOut In fGrab.Pins
        If pinOut.Direction = 1 Then
            pinOut.Render
            Exit For
        End If
    Next pinOut
errPinOut:
    'AddToFrame
    ' run graph and we are successfully in preview mode
                    'Public   Const WS_BORDER = &H800000
                    ''Public Const WS_CAPTION = &HC00000
                    'Public Const WS_CHILD = &H40000000
                    'Public Const WS_CHILDWINDOW = (WS_CHILD)
                    'Public Const WS_CLIPCHILDREN = &H2000000
                    'Public Const WS_CLIPSIBLINGS = &H4000000
                    'Public Const WS_DISABLED = &H8000000
                    'Public Const WS_DLGFRAME = &H400000
                    'Public Const WS_GROUP = &H20000
                    'Public Const WS_HSCROLL = &H100000
                    'Public Const WS_ICONIC = WS_MINIMIZE
                    'Public Const WS_MAXIMIZE = &H1000000
                    'Public Const WS_MAXIMIZEBOX = &H10000
                    'Public Const WS_MINIMIZE = &H20000000
                    'Public Const WS_MINIMIZEBOX = &H20000
                    'Public Const WS_OVERLAPPED = &H0&
                    'Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or _
                    '   WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
                    ''Public Const WS_POPUP = &H80000000
                    'Public Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
                    'Public Const WS_SIZEBOX = WS_THICKFRAME
                    'Public Const WS_SYSMENU = &H80000
                    'Public Const WS_TABSTOP = &H10000
                    'Public Const WS_THICKFRAME = &H40000
                    'Public Const WS_TILED = WS_OVERLAPPED
                    'Public Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
                    'Public Const WS_VISIBLE = &H10000000
                    'Public Const WS_VSCROLL = &H200000
    AddToFrame
    gGraph.Run
End Sub

Public Sub SetSource(newSource As String)
    dShow_source = newSource
End Sub

Public Sub SetImage(newImage As String)
    imageName = App.Path & "\" & newImage
End Sub

Public Sub SetFrame(newFrame As Object)
    Set frame = newFrame
End Sub

Private Function ReadString(strVar As String) As String
    Dim str As String
    Dim strArr() As String
    Dim i As Integer

    On Local Error GoTo ErrRead
    Open App.Path & "\config.txt" For Input As #1
nextRow:
        Input #1, str
        If str <> "" Then
            strArr = Split(str, "::")
        End If
        str = ""
        For i = 0 To UBound(strArr)
            If strArr(0) <> strVar Then GoTo nextRow
                If i > 0 Then
                    str = str & strArr(i)
                End If
        Next i
    Close #1
    ReadString = str
    Exit Function
ErrRead:
    MsgBox "read txt main problem"
End Function

Public Sub PreviewImage()
    On Error GoTo cancelopen
    'dlgFile.ShowOpen
    On Error GoTo 0

    ' make a new graph
    Set gGraph = Nothing
    Set gCapStill = Nothing
    Set gVidWindow = Nothing
    Set gGraph = New FilgraphManager
    Set gRegFilters = gGraph.RegFilterCollection
    Set gVidWindow = gGraph

    ' add the grabber including vb wrapper and default props
    Dim filter As IRegFilterInfo
    Dim fGrab As IFilterInfo
    For Each filter In gRegFilters
        If filter.name = "SampleGrabber" Then
            filter.filter fGrab

            ' wrap this filter in the capstill vb wrapper
            ' also sets rgb-24 media type and other properties
            Set gCapStill = New VBGrabber
            gCapStill.FilterInfo = fGrab
            Exit For
        End If
    Next filter

    Dim fSrc As IFilterInfo
    gGraph.AddSourceFilter imageName, fSrc

    ' find first output on src
    Dim pinOut As IPinInfo
    For Each pinOut In fSrc.Pins
        If pinOut.Direction = 1 Then
            Exit For
        End If
    Next pinOut

    ' find first input on grabber and connect
    Dim pinIn As IPinInfo
    For Each pinIn In fGrab.Pins
        If pinIn.Direction = 0 Then
            pinOut.Connect pinIn
            Exit For
        End If
    Next pinIn

    ' find grabber output pin and render
    For Each pinOut In fGrab.Pins
        If pinOut.Direction = 1 Then
            pinOut.Render
            Exit For
        End If
    Next pinOut


    ' run graph and we are successfully in preview mode
    gGraph.Run

cancelopen:

End Sub

Private Sub Class_Terminate()
    Set gGraph = Nothing
    Set gVidWindow = Nothing
    Set gRegFilters = Nothing
    Set gCapStill = Nothing
    Set gBasAudio = Nothing
    Set gBasVideo = Nothing
    Set gBasVideo2 = Nothing
    Set gMedEvent = Nothing
    Set gMedPosition = Nothing

    Set comboBox = Nothing
End Sub

Ответить

Ответы Всего ответов: 0

Нет ответов

Страница: