急，用DIRECTSHOW制作视频播放程序的时候如何才能捕捉EC_COMPLETE消息以达到自动循环播放的效果？
用DIRECTSHOW制作一个视频播放的VB程序，但是其本身没有提供循环播放的参数，查了资料当FilgraphManager播放结束时会释放一个为EC_COMPLETE的消息，再查资料看到应该是要调用WindowProc函数来捕捉，小弟初学VB不久，试了多种网上的代码都不能正常使用
时间比较紧，有朋友能帮我直接改下代码么？
万分感谢 QQ 282224306
FORM代码如下
Option ExplicitPrivate TextLine As String '文字信息Private Index As Long '字符索引Private Scrolling As Boolean '滚动标志Private t As Long '帧延时Private RText As RECTPrivate RClip As RECTPrivate RUpdate As RECTPrivate Const WS_CHILD = &H40000000Private Const WS_CLIPCHILDREN = &H2000000Private m_FilGraph As FilgraphManagerPrivate m_Video As IVideoWindowPrivate Function VideoPlay() '视频播放 Dim strFileName As String ' strFileName = App.Path & "\魅力杭州.mpg" '电影的地址 strFileName = VIDEOPATH Set m_FilGraph = New FilgraphManager m_FilGraph.RenderFile strFileName Set m_Video = m_FilGraph With m_Video .Owner = Picture1.hwnd .WindowStyle = WS_CHILD Or WS_CLIPCHILDREN .Top = 0 .Left = 0 .Width = Picture1.Width / Screen.TwipsPerPixelX .Height = Picture1.Height / Screen.TwipsPerPixelY End With m_FilGraph.RunEnd FunctionPrivate Sub cmdExit_Click() '退出Set m_FilGraph = NothingSet m_Video = NothingUnload MeEnd SubPrivate Sub Form_Load() '初始化窗口视频尺寸和公告VideoPlayer.Left = 0VideoPlayer.Top = 0VideoPlayer.Width = Screen.WidthVideoPlayer.Height = Screen.HeightVideoPlayer.AutoRedraw = TruePicture1.AutoRedraw = TruePicture1.Left = 0Picture1.Top = 0Picture1.Width = Screen.WidthPicture1.Height = Screen.HeightTimer1.Enabled = TrueTimer1.Interval = 100TextLine = ALERTTEXT & " "End SubPrivate Sub Form_Unload(Cancel As Integer) Scrolling = 0 '!End SubPrivate Function Scroll() '公告滚动 Dim Char As String Scrolling = -1 Index = 1 With iScroll SetRect RClip, 1, 2, .ScaleWidth, .ScaleHeight SetRect RText, .ScaleWidth, 2, .ScaleWidth + .TextWidth(Left$(TextLine, 1)), .ScaleHeight End With Char = Left$(TextLine, 1) With iScroll Do If (timeGetTime - t >= 30) Then t = timeGetTime If (RText.Right <= .ScaleWidth) Then Index = Index + 1 Char = Mid$(TextLine, Index, 1) SetRect RText, .ScaleWidth, 2, .ScaleWidth + .TextWidth(Mid$(TextLine, Index, 1)), .ScaleHeight End If DrawText .hdc, Char, 2, RText, &H0 OffsetRect RText, -1, 0 ScrollDC .hdc, -1, 0, RClip, RClip, 0, RUpdate iScroll.Line (.ScaleWidth - 2, 0)-(.ScaleWidth - 2, .ScaleHeight - 1), .BackColor End If If (Index > Len(TextLine)) Then Index = 0 DoEvents Loop Until Scrolling = 0 End WithEnd FunctionPrivate Sub Timer1_Timer() '播放计时触发Timer1.Enabled = FalseTimer1.Interval = 0VideoPlayTimer2.Interval = 500Timer2.Enabled = TrueEnd SubPrivate Sub Timer2_Timer() '滚动计时触发Timer2.Enabled = FalseTimer2.Interval = 0ScrollEnd Sub
Public VIDEOPATH As StringPublic ALERTTEXT As StringPublic Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePublic Const EM_FMTLINES As Long = &HC8Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongDeclare Function timeGetTime Lib "winmm.dll" () As LongDeclare Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongDeclare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As LongDeclare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As Long, ByVal dy As Long, lprcScroll As RECT, lprcClip As RECT, ByVal hrgnUpdate As Long, lprcUpdate As RECT) As LongDeclare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
If nReturnCode = 0 Then ' Playing 'get the current position for display dblPosition = m_objMediaPosition.CurrentPositionElse ' Stopped ' NOTE: only occurs when clip FINISHES playin ' Set State m_boolVideoRunning = False ' Send event RaiseEvent VideoFinishedEvent() End If
[解决办法]
3。
Private evEx As IMediaEventEx
' Event Notifications
Set evEx = graph
evEx.SetNotifyFlags 0
evEx.SetNotifyWindow Me.hWnd, WM_GRAPHEVENT, 0
你可以Subclass WM_GRAPHEVENT,Call DirectShowEventCallback
Public Sub DirectShowEventCallback()
Dim lngEvent As Long
Dim lngParam1 As Long
Dim lngParam2 As Long
On Error GoTo ExitSub
Do
evEx.GetEvent lngEvent, lngParam1, lngParam2, 0
If lngEvent = 1 Then ' complete
Debug.Print "complete"
graph.Pause
Else
Debug.Print "Event: " & lngEvent
End If
evEx.FreeEventParams lngEvent, lngParam1, lngParam2
Loop
ExitSub:
End Sub
