le falta algo a este kodigo
Publicado por scorpionhack (120 intervenciones) el 10/11/2005 19:40:26
Buenas kiero k el reproductor k tengo abajo reproduzca videos de internet metiendo la url, pero he exo un monton de intentos y no lo knsigo, aver si alguien me puede ayudar y sabe k tengo k añadirle al kodigo, le estaria muy agradecido.
GRACIAS
formulario:
Dim Paused
Const NormalWidth = 5280
Private Sub Command1_Click()
CommonDialog1.ShowOpen
Path_t.Text = CommonDialog1.FileName
End Sub
Private Sub Form_Load()
Me.Width = NormalWidth
End Sub
Private Sub FullScreen_c_Click()
End Sub
Private Sub Play_But_Click()
If Paused Then ' Check if paused
ActiveMovieControl.PlayActiveMovie
Else
DontMaintainRatio = (Ratio_c.Value = 0)
RunFullScreen = (FullScreen_c.Value = 1)
ActiveMovieControl.RunVideoContent Path_t.Text, DontMaintainRatio, RunFullScreen
End If
End Sub
Private Sub Stop_But_Click() ' Stop
' Setting flag
Paused = False
ActiveMovieControl.StopActiveMovie
End Sub
Private Sub Pause_But_Click()
Paused = True
ActiveMovieControl.PauseActiveMovie
End Sub
Private Sub Volume_s_Click()
ActiveMovieControl.SetActiveMovieVolume Volume_s.Value
End Sub
Private Sub Balance_s_Click()
ActiveMovieControl.SetActiveMovieBalance Balance_s.Value
End Sub
Private Sub RefreshTimer_Timer()
If ActiveMovieControl.VideoRunning Then
Length_l.Caption = "Length: " & ActiveMovieControl.GetVideoLength
CurrentPos_l.Caption = "Current Pos: " & ActiveMovieControl.GetVideoPos
End If
End Sub
Private Sub StateTimer_Timer()
ActiveMovieControl.ActiveMovieTimerEvent
End Sub
Public Sub VideoFinishedEvent()
CurrentPos_l.Caption = "Video Finished!"
End Sub
Modulo:
Option Explicit
Option Base 0
Option Compare Text
Private m_dblRate As Double 'Rate in Frames Per Second
Private m_bstrFileName As String 'Loaded Filename
Private m_dblRunLength As Double 'Duration in seconds
Private m_dblStartPosition As Double 'Start position in seconds
Public m_boolVideoRunning As Boolean 'Flag used to trigger clock
Private dblPosition As Double ' Current Play position
Private m_objBasicAudio As IBasicAudio
Private m_objBasicVideo As IBasicVideo
Private m_objMediaEvent As IMediaEvent
Private m_objVideoWindow As IVideoWindow
Private m_objMediaControl As IMediaControl
Private m_objMediaPosition As IMediaPosition
Sub RunVideoContent(ByVal path As String, Optional ByVal DontMaintainRatio As Boolean, Optional ByVal FullScreen As Boolean)
Dim nCount As Long
Dim sScale As Double
Dim topMod As Long
On Local Error GoTo ErrLine
UnloadActiveMovieControl
m_bstrFileName = path
Set m_objMediaControl = New FilgraphManager
Call m_objMediaControl.RenderFile(m_bstrFileName)
Set m_objBasicAudio = m_objMediaControl
m_objBasicAudio.Volume = 0
m_objBasicAudio.Balance = 0
Set m_objVideoWindow = m_objMediaControl
m_objVideoWindow.WindowStyle = CLng(&H6000000)
m_objVideoWindow.Left = 0
sScale = m_objVideoWindow.Height / m_objVideoWindow.Width
m_objVideoWindow.Width = Video_ActiveMovie.Video.Width
If Not (DontMaintainRatio) Then
m_objVideoWindow.Height = Video_ActiveMovie.Video.Width * sScale
topMod = (Video_ActiveMovie.Video.Height - m_objVideoWindow.Height) / 2
Else
m_objVideoWindow.Height = Video_ActiveMovie.Video.Height
End If
m_objVideoWindow.Top = topMod
' Setting FullScreen Mode
m_objVideoWindow.FullScreenMode = FullScreen
m_objVideoWindow.Owner = Video_ActiveMovie.Video.hWnd
Set m_objMediaEvent = m_objMediaControl
Set m_objMediaPosition = m_objMediaControl
m_objMediaPosition.Rate = 1 ' Normal play rate
m_dblRate = m_objMediaPosition.Rate
m_dblRunLength = Round(m_objMediaPosition.Duration, 2)
m_dblStartPosition = 0
PlayActiveMovie
Exit Sub
ErrLine:
Err.Clear
Resume Next
End Sub
Sub UnloadActiveMovieControl()
On Local Error GoTo ErrLine
m_boolVideoRunning = False
DoEvents
If Not m_objMediaControl Is Nothing Then
m_objMediaControl.Stop
End If
If Not m_objVideoWindow Is Nothing Then
m_objVideoWindow.Left = Screen.Width * 8
m_objVideoWindow.Height = Screen.Height * 8
m_objVideoWindow.Owner = 0 'sets the Owner to NULL
End If
If Not m_objBasicAudio Is Nothing Then Set m_objBasicAudio = Nothing
If Not m_objBasicVideo Is Nothing Then Set m_objBasicVideo = Nothing
If Not m_objMediaControl Is Nothing Then Set m_objMediaControl = Nothing
If Not m_objVideoWindow Is Nothing Then Set m_objVideoWindow = Nothing
If Not m_objMediaPosition Is Nothing Then Set m_objMediaPosition = Nothing
Exit Sub
ErrLine:
Err.Clear
End Sub
Sub PlayActiveMovie()
On Local Error GoTo errHandle
If CLng(m_objMediaPosition.CurrentPosition) < CLng(m_dblStartPosition) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
ElseIf CLng(m_objMediaPosition.CurrentPosition) = CLng(m_dblRunLength) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
End If
m_boolVideoRunning = True
Call m_objMediaControl.Run
Exit Sub
errHandle:
Err.Clear
Resume Next
End Sub
Sub PauseActiveMovie()
On Local Error GoTo errHandle
If Not (m_boolVideoRunning) Then Exit Sub
Call m_objMediaControl.Pause
m_boolVideoRunning = False
Exit Sub
errHandle:
Err.Clear
'logerror
End Sub
Sub StopActiveMovie()
On Local Error GoTo errHandle
If Not (m_boolVideoRunning) Then Exit Sub
Call m_objMediaControl.Stop
m_boolVideoRunning = False
m_objMediaPosition.CurrentPosition = 0
Exit Sub
errHandle:
Err.Clear
End Sub
Sub SetActiveMovieBalance(ByVal Value As Long)
On Local Error GoTo ErrLine
'Set the balance using the slider
If Not m_objMediaControl Is Nothing Then _
m_objBasicAudio.Balance = Value
Exit Sub
ErrLine:
Err.Clear
End Sub
Sub SetActiveMovieVolume(ByVal Value As Long)
On Local Error GoTo ErrLine
'Set the volume using the slider
If Not m_objMediaControl Is Nothing Then _
m_objBasicAudio.Volume = Value
Exit Sub
ErrLine:
Err.Clear
End Sub
Function GetVideoLength() As Double
GetVideoLength = m_dblRunLength
End Function
Function GetVideoPos() As Double
dblPosition = m_objMediaPosition.CurrentPosition
GetVideoPos = dblPosition
End Function
Function VideoRunning() As Boolean
VideoRunning = m_boolVideoRunning
End Function
Public Sub ActiveMovieTimerEvent()
Dim nReturnCode As Long
On Local Error GoTo errHandle
If m_boolVideoRunning = True Then
Call m_objMediaEvent.WaitForCompletion(100, nReturnCode)
If nReturnCode = 0 Then ' Playing
'get the current position for display
dblPosition = m_objMediaPosition.CurrentPosition
Else
m_boolVideoRunning = False
Video_ActiveMovie.VideoFinishedEvent
End If
End If
Exit Sub
errHandle:
Err.Clear
Resume Next
End Sub
GRACIAS
formulario:
Dim Paused
Const NormalWidth = 5280
Private Sub Command1_Click()
CommonDialog1.ShowOpen
Path_t.Text = CommonDialog1.FileName
End Sub
Private Sub Form_Load()
Me.Width = NormalWidth
End Sub
Private Sub FullScreen_c_Click()
End Sub
Private Sub Play_But_Click()
If Paused Then ' Check if paused
ActiveMovieControl.PlayActiveMovie
Else
DontMaintainRatio = (Ratio_c.Value = 0)
RunFullScreen = (FullScreen_c.Value = 1)
ActiveMovieControl.RunVideoContent Path_t.Text, DontMaintainRatio, RunFullScreen
End If
End Sub
Private Sub Stop_But_Click() ' Stop
' Setting flag
Paused = False
ActiveMovieControl.StopActiveMovie
End Sub
Private Sub Pause_But_Click()
Paused = True
ActiveMovieControl.PauseActiveMovie
End Sub
Private Sub Volume_s_Click()
ActiveMovieControl.SetActiveMovieVolume Volume_s.Value
End Sub
Private Sub Balance_s_Click()
ActiveMovieControl.SetActiveMovieBalance Balance_s.Value
End Sub
Private Sub RefreshTimer_Timer()
If ActiveMovieControl.VideoRunning Then
Length_l.Caption = "Length: " & ActiveMovieControl.GetVideoLength
CurrentPos_l.Caption = "Current Pos: " & ActiveMovieControl.GetVideoPos
End If
End Sub
Private Sub StateTimer_Timer()
ActiveMovieControl.ActiveMovieTimerEvent
End Sub
Public Sub VideoFinishedEvent()
CurrentPos_l.Caption = "Video Finished!"
End Sub
Modulo:
Option Explicit
Option Base 0
Option Compare Text
Private m_dblRate As Double 'Rate in Frames Per Second
Private m_bstrFileName As String 'Loaded Filename
Private m_dblRunLength As Double 'Duration in seconds
Private m_dblStartPosition As Double 'Start position in seconds
Public m_boolVideoRunning As Boolean 'Flag used to trigger clock
Private dblPosition As Double ' Current Play position
Private m_objBasicAudio As IBasicAudio
Private m_objBasicVideo As IBasicVideo
Private m_objMediaEvent As IMediaEvent
Private m_objVideoWindow As IVideoWindow
Private m_objMediaControl As IMediaControl
Private m_objMediaPosition As IMediaPosition
Sub RunVideoContent(ByVal path As String, Optional ByVal DontMaintainRatio As Boolean, Optional ByVal FullScreen As Boolean)
Dim nCount As Long
Dim sScale As Double
Dim topMod As Long
On Local Error GoTo ErrLine
UnloadActiveMovieControl
m_bstrFileName = path
Set m_objMediaControl = New FilgraphManager
Call m_objMediaControl.RenderFile(m_bstrFileName)
Set m_objBasicAudio = m_objMediaControl
m_objBasicAudio.Volume = 0
m_objBasicAudio.Balance = 0
Set m_objVideoWindow = m_objMediaControl
m_objVideoWindow.WindowStyle = CLng(&H6000000)
m_objVideoWindow.Left = 0
sScale = m_objVideoWindow.Height / m_objVideoWindow.Width
m_objVideoWindow.Width = Video_ActiveMovie.Video.Width
If Not (DontMaintainRatio) Then
m_objVideoWindow.Height = Video_ActiveMovie.Video.Width * sScale
topMod = (Video_ActiveMovie.Video.Height - m_objVideoWindow.Height) / 2
Else
m_objVideoWindow.Height = Video_ActiveMovie.Video.Height
End If
m_objVideoWindow.Top = topMod
' Setting FullScreen Mode
m_objVideoWindow.FullScreenMode = FullScreen
m_objVideoWindow.Owner = Video_ActiveMovie.Video.hWnd
Set m_objMediaEvent = m_objMediaControl
Set m_objMediaPosition = m_objMediaControl
m_objMediaPosition.Rate = 1 ' Normal play rate
m_dblRate = m_objMediaPosition.Rate
m_dblRunLength = Round(m_objMediaPosition.Duration, 2)
m_dblStartPosition = 0
PlayActiveMovie
Exit Sub
ErrLine:
Err.Clear
Resume Next
End Sub
Sub UnloadActiveMovieControl()
On Local Error GoTo ErrLine
m_boolVideoRunning = False
DoEvents
If Not m_objMediaControl Is Nothing Then
m_objMediaControl.Stop
End If
If Not m_objVideoWindow Is Nothing Then
m_objVideoWindow.Left = Screen.Width * 8
m_objVideoWindow.Height = Screen.Height * 8
m_objVideoWindow.Owner = 0 'sets the Owner to NULL
End If
If Not m_objBasicAudio Is Nothing Then Set m_objBasicAudio = Nothing
If Not m_objBasicVideo Is Nothing Then Set m_objBasicVideo = Nothing
If Not m_objMediaControl Is Nothing Then Set m_objMediaControl = Nothing
If Not m_objVideoWindow Is Nothing Then Set m_objVideoWindow = Nothing
If Not m_objMediaPosition Is Nothing Then Set m_objMediaPosition = Nothing
Exit Sub
ErrLine:
Err.Clear
End Sub
Sub PlayActiveMovie()
On Local Error GoTo errHandle
If CLng(m_objMediaPosition.CurrentPosition) < CLng(m_dblStartPosition) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
ElseIf CLng(m_objMediaPosition.CurrentPosition) = CLng(m_dblRunLength) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
End If
m_boolVideoRunning = True
Call m_objMediaControl.Run
Exit Sub
errHandle:
Err.Clear
Resume Next
End Sub
Sub PauseActiveMovie()
On Local Error GoTo errHandle
If Not (m_boolVideoRunning) Then Exit Sub
Call m_objMediaControl.Pause
m_boolVideoRunning = False
Exit Sub
errHandle:
Err.Clear
'logerror
End Sub
Sub StopActiveMovie()
On Local Error GoTo errHandle
If Not (m_boolVideoRunning) Then Exit Sub
Call m_objMediaControl.Stop
m_boolVideoRunning = False
m_objMediaPosition.CurrentPosition = 0
Exit Sub
errHandle:
Err.Clear
End Sub
Sub SetActiveMovieBalance(ByVal Value As Long)
On Local Error GoTo ErrLine
'Set the balance using the slider
If Not m_objMediaControl Is Nothing Then _
m_objBasicAudio.Balance = Value
Exit Sub
ErrLine:
Err.Clear
End Sub
Sub SetActiveMovieVolume(ByVal Value As Long)
On Local Error GoTo ErrLine
'Set the volume using the slider
If Not m_objMediaControl Is Nothing Then _
m_objBasicAudio.Volume = Value
Exit Sub
ErrLine:
Err.Clear
End Sub
Function GetVideoLength() As Double
GetVideoLength = m_dblRunLength
End Function
Function GetVideoPos() As Double
dblPosition = m_objMediaPosition.CurrentPosition
GetVideoPos = dblPosition
End Function
Function VideoRunning() As Boolean
VideoRunning = m_boolVideoRunning
End Function
Public Sub ActiveMovieTimerEvent()
Dim nReturnCode As Long
On Local Error GoTo errHandle
If m_boolVideoRunning = True Then
Call m_objMediaEvent.WaitForCompletion(100, nReturnCode)
If nReturnCode = 0 Then ' Playing
'get the current position for display
dblPosition = m_objMediaPosition.CurrentPosition
Else
m_boolVideoRunning = False
Video_ActiveMovie.VideoFinishedEvent
End If
End If
Exit Sub
errHandle:
Err.Clear
Resume Next
End Sub
Valora esta pregunta


0