'Hi , hier ist der Code :
 
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" ( _
  ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal _
  uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As _
String, ByVal cchBuffer As Long) As Long
 
Public Sub DoÖffnen(DateiV As String, InFensterHWND As Long)
Dim sBuffer As String * 255
Dim gg As String
Dim Datei As String
Dim IsVideoZ As Boolean
Datei = DateiV
Dim lResult As Long
Dim Dateiendung As String
On Error Resume Next
lResult = GetShortPathName(Datei, sBuffer, Len(sBuffer))
Datei = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
gg = GetMCIType(Datei, IsVideoZ)
'Wenn Video in Fenster!!!-------------------------------------------------
mciSendString "open " & Datei & " type " & CStr(gg) & " alias bdPlayerMCI", 0, _
  0, 0
DoEvents
mciSendString "set bdPlayerMCI time format milliseconds", 0, 0, 0
DoEvents
If IsVideoZ = True Then
Load Videofrm
mciSendString "window bdPlayerMCI handle " & CStr(InFensterHWND), 0, 0, 0
Videofrm.Show , Player
Videofrm.Refresh
End If
'Wenn Video in Fenster!!!-------------------------------------------------
PlayDateiName = DateiV
 
End Sub
 
Public Sub DoPlay(Optional FromA As Double = 0)
On Error Resume Next
mciSendString "play bdPlayerMCI from " & CStr(FromA), 0, 0, 0
 
End Sub
 
Public Sub DoSchließen()
On Error Resume Next
mciSendString "close bdPlayerMCI", 0, 0, 0
PlayDateiName = ""
 
End Sub
 
Public Sub DoStop()
On Error Resume Next
mciSendString "stop bdPlayerMCI", 0, 0, 0
 
End Sub
 
Public Sub DoPause()
On Error Resume Next
mciSendString "pause bdPlayerMCI", 0, 0, 0
 
End Sub
 
Public Sub DoResume()
On Error Resume Next
mciSendString "resume bdPlayerMCI", 0, 0, 0
 
End Sub
 
Public Function GetAktuellePosition() As Double
Dim Antwort As String * 255
On Error Resume Next
mciSendString "status bdPlayerMCI position", Antwort, Len(Antwort), 0
GetAktuellePosition = CDbl(Antwort)
 
End Function
 
Public Function GetGesammtLänge() As Double
Dim Antwort As String * 255
On Error Resume Next
mciSendString "status bdPlayerMCI length", Antwort, Len(Antwort), 0
GetGesammtLänge = CDbl(Antwort)
 
End Function
 
Public Sub SetSpeed(Optional SpeedA As Long = 1000)
On Error Resume Next
If SpeedA < 0 Or SpeedA > 2000 Then Exit Sub
mciSendString "set bdPlayerMCI speed " & CStr(SpeedA), 0, 0, 0
 
End Sub
 
Public Function GetMCIType(DateiA As String, ByRef IsVideoA As Boolean) As _
  String
Dim TempA As String
TempA = Right$(DateiA, Len(DateiA) - InStrRev(DateiA, ".", Len(DateiA)))
Select Case LCase(TempA)
Case "mid"
GetMCIType = "Sequencer"
IsVideoA = False
Case "rmi"
GetMCIType = "Sequencer"
IsVideoA = False
Case "wav"
GetMCIType = "waveaudio"
IsVideoA = False
Case "cda"
GetMCIType = "CDAudio"
IsVideoA = False
Case "aif"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "aifc"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "aiff"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "au"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "midi"
GetMCIType = "Sequencer"
IsVideoA = False
Case "mp3"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "snd"
GetMCIType = "MPEGVideo"
IsVideoA = False
Case "wma"
GetMCIType = "MPEGVideo2"
IsVideoA = False
'Video--------------------
Case "mpeg"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "avi"
GetMCIType = "AVIVideo"
IsVideoA = True
Case "mpg"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "m1v"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "mp2"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "mpa"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "mpe"
GetMCIType = "MPEGVideo"
IsVideoA = True
Case "wmv"
GetMCIType = "MPEGVideo2"
IsVideoA = True
'Else--------------------
Case Else
GetMCIType = "MPEGVideo"
IsVideoA = False
End Select
 
End Function
 
 
'______________________________________________________________________________
'ComputerBild 15-03 bestaetigt: Den besten Spam-Schutz gibt es bei 
'WEB.DE FreeMail - Deutschlands beste E-Mail - http://web