' kurzer Pfad(8.3) ermitteln
Private Declare Function GetShortPathName Lib "kernel32" _
Alias "GetShortPathNameA" ( _
ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
 
' Sound, Video, infos, spielen u.s.w.
Private 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
 
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
 (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
 
Private Declare Function GetTempFileName Lib "kernel32" Alias _
  "GetTempFileNameA" _
  (ByVal lpszPath As String, _
   ByVal lpPrefixString As String, _
   ByVal wUnique As Long, _
   ByVal lpTempFileName As String) As Long
 
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias _
  "mciGetErrorStringA" _
  (ByVal dwError As Long, _
   ByVal lpstrBuffer As String, _
   ByVal uLength As Long) As Long
 
Public Function GetNewTempFile(strPrefix As String) As String
 
Dim strPath As String * 512
Dim strName As String * 576
Dim nRtn As Long
 
nRtn = GetTempPath(512, strPath)
If (nRtn > 0 And nRtn < 512) Then
   nRtn = GetTempFileName(strPath, strPrefix, 0, strName)
   If nRtn <> 0 Then
       GetNewTempFile = Left$(strName, InStr(strName, vbNullChar) - 1)
   End If
End If
 
End Function
 
Private Sub Play_From_ResourceFile()
 
Dim bytArray() As Byte
Dim nFreeFile As Integer
'Dim strTemp As String
Dim nRtn As Long
Dim strCommand As String
Dim strAlias As String
Dim Buffer As String
Dim ErrHandler As Long
Dim ShortFullPath As String
 
Const WS_CHILD = &H40000000
 
' Create a temp filename
strTemp = GetNewTempFile("MYAVI")
strAlias = Replace(Mid$(strTemp, InStrRev(strTemp, "\") + 1), ".tmp", "")
strTemp = Replace(strTemp, ".tmp", ".mid")
 
' Load RES File into a Byte Array
bytArray = LoadResData(501, "MID")
 
' Load Byte array into temp file
nFreeFile = FreeFile
 
Open strTemp For Binary As #nFreeFile
Put #nFreeFile, 1, bytArray()
Close #nFreeFile
nRtn = mciSendString("Play " & strAlias & " wait", vbNullString, 0, 0&)
 
' Prüfen ob eine MIDI-Datei übergeben wurde
If UCase$(Mid$(strTemp, Len(strTemp) - 2)) <> "MID" Then
GoTo MIDIError
End If
 
''' Prüfen ob der kurze pfad übergeben wurde
ShortFullPath = Get_ShortFullPath(strTemp)
If Len(ShortFullPath) = 0 Then GoTo MIDIError
 
Buffer = Space$(256)
nRtn = mciSendString("open sequencer!" & ShortFullPath & " alias MIDI", Buffer, _
  Len(Buffer), 0)
nRtn = mciSendString("play MIDI", Buffer, Len(Buffer), 0)
If nRtn <> 0 Then GoTo MIDIError
 
' Close the device
strCommand = "Close " & strTemp
nRtn = mciSendString(strCommand, vbNullString, 0, 0&)
 
Exit Sub
 
MIDIError:
' An error occurred.
' Get the error description
Dim ErrorString As String
ErrorString = Space$(256)
mciGetErrorString nRtn, ErrorString, Len(ErrorString)
ErrorString = Left$(ErrorString, InStr(ErrorString, vbNullChar) - 1)
 
' close the device if necessary
strCommand = "Close " & strTemp
mciSendString strCommand, vbNullString, 0, 0&
 
' raise a custom error, with the proper description
Err.Raise 999, , ErrorString
End Sub
 
' kurzer Pfad ermitteln (8.3)
Private Function Get_ShortFullPath(ByVal FullPath As String) As String
Dim Buffer As String
Buffer = Space$(256)
If GetShortPathName(FullPath, Buffer, Len(Buffer)) <> 0 Then
Get_ShortFullPath = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
End If
End Function

Kill strTemp