Visual Basic 2013 Videorecorder und Fernsehen programmieren
Author D.Selzer-McKenzie
Video: http://youtu.be/jF306zS3NBA
Auf diesem Video sehen Sie, mit welchem Code sich ein
Videorecorder einschliesslich Fernsehempfang programmieren lässt. Beim Code
müssen Sie das Video jeweils anhalten, falls Sie diesen abschreiben wollen.
Ansonsten finden Sie den gesamten Code auch im Forum
Hier der SourceCode:
'das MODUL
Imports System.IO
Imports System.Text
Imports System.Runtime.InteropServices
Public Class VideoUnterprogrammierung
Private Shared
Function mciSendString(lpstrCommand As String,
lpstrReturnString As StringBuilder, uReturnLength As Integer,
hwndCallback As
IntPtr) As Integer
End Function
Private Shared
Function mciGetErrorString(dwError As Integer,
lpstrBuffer
As StringBuilder, uLength As Integer) As Integer
End Function
Private Function
getMciError(errCode As Integer) As String
Dim errMsg As
New StringBuilder(255)
If
mciGetErrorString(errCode, errMsg, errMsg.Capacity) = 0 Then
Return
"MCI-Fehler " & errCode
Else
Return
errMsg.ToString()
End If
End Function
Private _alias As
String = "mciAlias"
Private _isOpen As
Boolean = False
Public ReadOnly
Property IsOpen As Boolean
Get
Return
_isOpen
End Get
End Property
Public Sub
Open(filename As String)
If Me._isOpen
Then Me.Close()
If Not
File.Exists(filename) Then
MessageBox.Show("Die Datei '" & filename & "' ist
nicht vorhanden!", "Fehler",
MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
Dim mciStr As
String = "open " & Chr(34) & filename & Chr(34) &
"
type mpegvideo alias " & _alias
'MessageBox.Show(mciStr)
Dim res As
Integer = mciSendString(mciStr, Nothing, 0, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res),
"MCI-Fehler beim Öffnen des Geräts ('Open'-Befehl)",
MessageBoxButtons.OK, MessageBoxIcon.Error)
Exit Sub
End If
mciStr =
"set " & Me._alias & " time format ms"
res = mciSendString(mciStr, Nothing, 0,
IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim Zuweisen des
Zeitformats", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
Me._isOpen =
True
End Sub
Public ReadOnly
Property Length As Integer
Get
Dim buffer
As New StringBuilder(255)
Dim res As
Integer = mciSendString("status " & _alias & "
length", buffer,
buffer.Capacity, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Length'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
Return Convert.ToInt32(buffer.ToString())
End Get
End Property
Public Sub
Play(von As Integer, bis As Integer)
Dim res As
Integer = mciSendString("Play " & _alias & " From "
& von & " To " & bis, Nothing, 0, IntPtr.Zero)
End Sub
Public Sub Play()
Play(0,
Me.Length)
End Sub
Public Property
Position As Integer
Get
Dim buffer
As New StringBuilder(261)
Dim res As
Integer = mciSendString("status " & _alias & "
position",
buffer,
buffer.Capacity, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Position'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
Return Convert.ToInt32(buffer.ToString())
End Get
Set(value As
Integer)
Dim res As
Integer = mciSendString("seek " & _alias & " to "
& value, Nothing, 0, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "Fehler beim 'Seek'-Befehl",
MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
res =
mciSendString("play " & _alias, Nothing, 0, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res),
"MCI-Fehler beim 'Play'-Befehl", MessageBoxButtons.OK,
MessageBoxIcon.Error)
End If
End Set
End Property
Public Sub Pause()
Dim res As
Integer = mciSendString("Pause " & _alias, Nothing, 0,
IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Pause'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
Public Sub
Resume_()
Dim res As
Integer = mciSendString("Resume " & _alias, Nothing, 0,
IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Resume'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
Public Sub volume(wert
As Integer)
Dim res As
Integer = mciSendString("setaudio " & _alias & " volume
to " & wert, Nothing, 0, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Volume'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
Public Sub Stop_()
Dim res As
Integer = mciSendString("Stop " & _alias, Nothing, 0, IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Stop'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
Public Sub Close()
If Me._isOpen
Then
Dim res As
Integer = mciSendString("Close " & _alias, Nothing, 0,
IntPtr.Zero)
If res
<> 0 Then
MessageBox.Show(getMciError(res), "MCI-Fehler beim
'Close'-Befehl", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
Me._isOpen
= False
End If
End Sub
End Class
'der SOURCE-CODE
Private
VideoProgramm As New VideoUnterprogrammierung()
Private kf As
Single = 1
Private Sub
KnopfVideoDateiOeffnen_Click(sender As Object, e As EventArgs) Handles
KnopfVideoDateiOeffnen.Click
If
OpenFileDialog1.ShowDialog() = DialogResult.OK Then
VideoProgramm.Open(OpenFileDialog1.FileName)
kf =
Convert.ToSingle(VideoProgramm.Length) / TrackBarVideoPosition.Maximum
ToolStripStatusLabel1.Text = OpenFileDialog1.FileName
KnopfVideoAbspielen.Text = "PLAY"
End If
End Sub
Private Sub KnopfVideoAbspielen_Click(sender
As Object, e As EventArgs) Handles KnopfVideoAbspielen.Click
If
KnopfVideoAbspielen.Text = "PLAY" Then
VideoProgramm.Play()
UhrVideoAudio.Enabled = True
KnopfVideoAbspielen.Text = "STOPP"
Else
VideoProgramm.Stop_()
UhrVideoAudio.Enabled = False
TrackBarVideoPosition.Value = 0
AbspielZeitAnzeige.Text = "00:00"
KnopfVideoAbspielen.Text = "PLAY"
End If
End Sub
Private Sub
KnopfVideoPause_Click(sender As Object, e As EventArgs) Handles
KnopfVideoPause.Click
If
KnopfVideoPause.Text = "PAUSE" Then
VideoProgramm.Pause()
KnopfVideoPause.Text = "WEITER"
Else
KnopfVideoPause.Text = "PAUSE"
VideoProgramm.Resume_()
End If
End Sub
Private Function
getMinutes() As String
Dim sekunden
As Integer = Convert.ToInt32((TrackBarVideoPosition.Value * kf / 1000))
Return
(sekunden / 60).ToString("00") & ":" & (sekunden
Mod 60).ToString("00")
End Function
Private Sub
UhrVideoAudio_Tick(sender As Object, e As EventArgs) Handles UhrVideoAudio.Tick
Dim val As
Integer = Convert.ToInt32(VideoProgramm.Position / kf)
If val <
TrackBarVideoPosition.Maximum Then
TrackBarVideoPosition.Value = val
AbspielZeitAnzeige.Text = getMinutes()
Else
VideoProgramm.Stop_()
UhrVideoAudio.Enabled = False
TrackBarVideoPosition.Value = 0
AbspielZeitAnzeige.Text = "00:00"
KnopfVideoAbspielen.Text = "PLAY"
End If
End Sub
Private Sub
TrackBarVideoPosition_Scroll(sender As Object, e As EventArgs) Handles
TrackBarVideoPosition.Scroll
Try
Me.VideoProgramm.Position = Convert.ToInt32(TrackBarVideoPosition.Value
* kf)
Catch ex As
Exception
MessageBox.Show(ex.Message,
Application.ProductName,
MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
End Sub
Private Sub
TrackBarVideoLautstärke_Scroll(sender As Object, e As EventArgs) Handles
TrackBarVideoLautstärke.Scroll
VideoProgramm.volume(TrackBarVideoLautstärke.Value)
End Sub
Keine Kommentare:
Kommentar veröffentlichen
Hinweis: Nur ein Mitglied dieses Blogs kann Kommentare posten.