Конкретный звук на запуск конкретной программы

Option Explicit
Option Compare Text
 
Public Declare Function mciSendString& Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand$, _
    ByVal lpstrReturnString$, _
    ByVal uReturnLength&, _
    ByVal hwndCallback&)
 
Private Const MCI_ALIAS As String = "Media_1" '// Любой псевдоним
 
Private myFSO   As Object
Private stdIn   As Object
Private stdOut  As Object
Private stdErr  As Object
 
 
Sub Main()
    On Error GoTo errH
    Dim strFileName$, arrCMD, ASync As Boolean
    
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    Set stdIn = myFSO.GetStandardStream(0&) '// Устанавливаем связь с потоками
    Set stdOut = myFSO.GetStandardStream(1&)
    Set stdErr = myFSO.GetStandardStream(2&)
 
    arrCMD = ParseCMD() '// Получаем аргументы ком. строки
    
    '// Using Block
    If Not IsArray(arrCMD) Then Using: UnloadStream: Exit Sub '// Нет аргументов
    
    If arrCMD(0) = "stop" Then StopSnd '// Остановить (достаточно 1 аргумента)
    
    If UBound(arrCMD) = 0 Then Using: UnloadStream: Exit Sub '// Только 1 аргумент
    
    '// ASync Flag
    ASync = True
    If UBound(arrCMD) >= 2 Then If arrCMD(2) = "wait" Then ASync = False
    
    '// Check FileName for existence
    strFileName = arrCMD(1)
    If Dir$(strFileName) = vbNullString Then
        strFileName = App.Path & "\" & strFileName
        If Dir$(strFileName) = vbNullString Then '// Пытаемся найти в рабочем каталоге
            stdOut.writeline "WARNING: specified file does not exists!"
            stdOut.writeline "Anywhere, this command was sended to MCISendString API :)"
        End If
    End If
 
    Select Case arrCMD(0) '// main command
        Case "play"
            PlaySnd Chr(34) & strFileName & Chr(34), ASync '// Воспроизвести
        'Case "stop"
        '    StopSnd '// Остановить
        Case Else '// Another command
            MCISend Command()
    End Select
    
    UnloadStream
    Exit Sub
errH:
    stdOut.writeline "CRITICAL ERROR: " & Err.Number & ". " & Err.Description
    Err.Clear
End Sub
 
Sub StopSnd()
    MCISend "Stop " & MCI_ALIAS '// Останавливаем воспроизведение
    MCISend "Close " & MCI_ALIAS '// Закрываем файл
End Sub
 
Sub PlaySnd(strFileName$, Optional ASync As Boolean = True)
        '// Закрываем файл.
        '// Если он не закрыт, воспроизведение будет продолжено с предыдущей позиции
        '// Seek не использую. Приводит к искажениям в начале воспроизведения на некоторых дорожках.
    MCISend "Close " & MCI_ALIAS
    MCISend "Open " & strFileName & " alias " & MCI_ALIAS '// Присваиваем алиас
    MCISend "Play " & MCI_ALIAS & IIf(ASync, "", " wait")
End Sub
 
Sub MCISend(lpstrCommand$)
    mciSendString lpstrCommand, vbNullString, 0&, 0&
End Sub
 
Function ParseCMD(Optional comm$) '// Парсер командной строки
    On Error GoTo errH
    Dim st, argv, arg, n&, a&
    
    If Len(comm) = 0 Then comm = Command()
    If Len(comm) = 0 Then Exit Function
 
    comm = Replace(comm, " " & Chr(34), Chr(34)) '// ( ")->(")
    comm = Replace(comm, Chr(34) & " ", Chr(34)) '// (" )->(")
    
    st = Split(comm, Chr(34))
    ReDim argv(0 To UBound(Split(Replace(comm, Chr(34), " "))))
    For n = 0 To UBound(st)
        If n Mod 2 = 0 Then '// Не в кавычках
            For Each arg In Split(st(n))
                argv(a) = arg
                a = a + 1
            Next
          Else '// в кавычках - не разбивать по пробелам
            argv(a) = st(n)
            a = a + 1
        End If
    Next
    ReDim Preserve argv(0 To a - 1)
    ParseCMD = argv
    Exit Function
errH:
    stdOut.writeline "CRITICAL ERROR: " & Err.Number & ". " & Err.Description
    Err.Clear
End Function
 
Sub Using()
    With stdOut
        .writeline ""
        .writeline "MCISendString. Console Sound Player."
        .writeline ""
        .writeline "Using:"
        .writeline App.EXEName & ".exe [play|pause|resume|stop] [FileName] {wait}"
    End With
End Sub
 
Sub UnloadStream()
    Set stdIn = Nothing
    Set stdOut = Nothing
    Set stdErr = Nothing
    Set myFSO = Nothing
End Sub

'/// by Xameleon
 
Set WMPlayer = New WMPlayerClass
 
Dim FilePath
 
'/// Так же можно указать URl - ссылку на файл в интернете
FilePath = "C:\ringout.wav"
 
'/// Открываем ресурс
WMPlayer.OpenMedia FilePath
 
'/// Выводим длительность файла
msgbox "Длительность файла: " & WMPlayer.CurrentMedia.DurationString,vbInformation,"WMPlayerClass"
 
'/// проверка изменения громкости
msgbox "Сейчас будет произведена проверка изменения громкости звука. Эффект эхо. 100% 50% 10%"
WMPlayer.Settings.Volume = 100
WMPlayer.Play
WMPlayer.Settings.Volume = 50
WMPlayer.Play
WMPlayer.Settings.Volume = 10
WMPlayer.Play
 
'/// проверка изменения баланса
MsgBox "Сейчас будет произведена проверка баланса. (левого и правого динамика)",vbInformation,"WMPlayerClass"
WMPlayer.Settings.Volume = 100
WMPlayer.Settings.Balance = -100
WMPlayer.Play
WMPlayer.Settings.Balance = 100
WMPlayer.Play
 
MsgBox "Проверка завершена.",vbInformation,"WMPlayerClass"
 
'/// Класс проигрывателя
Class WMPlayerClass
    '/// Переменная для хранения ссылки на объект плеера
    Dim WMPlayer
    Private Sub Class_Initialize()
        Set WMPlayer = CreateObject("WMPlayer.OCX")
        WMPlayer.settings.autoStart = False
        WMPlayer.settings.enableErrorDialogs = False
    End Sub
 
    '/// Свойство возвращает ссылку на объект настроек плеера
    Public Property Get Settings
        Set Settings = WMPlayer.Settings
    End Property
 
    '/// Метод подключения к ресурсу
    Function OpenMedia(URL)
        '/// Несколько из констант состояния открытия
        Const wmposMediaLoading = 11
        Const wmposMediaLocating = 9
        Const wmposPlaylistOpenNoMedia = 6
        Const wmposMediaOpen = 13
        Const wmposPlaylistOpening = 5
        Const wmposOpeningUnknownURL = 21
        Const wmposUndefined = 0
 
        '/// Для корректного получения данных о содержимом, нужно открыть ресурс.
        WMPlayer.URL = URL
        '/// Убираем звук        
        WMPlayer.settings.mute=true
        '/// Запускаем на проигрывание
        WMPlayer.controls.Play
        '/// Ждём состояния открытия файла. Если файл открыть не удалось вернётся wmposPlaylistOpenNoMedia
        Do
            WScript.Sleep 10
        Loop Until WMPlayer.OpenState = wmposMediaOpen or WMPlayer.OpenState=wmposPlaylistOpenNoMedia
        '/// Останавливаем проигрывание
        WMPlayer.controls.Stop
        '/// Возвращаем звук
        WMPlayer.settings.mute=false
    End Function
 
    '/// Свойство возвращает ссылку на параметры открытого файла
    Public Property Get CurrentMedia
        Set CurrentMedia = WMPlayer.CurrentMedia
    End Property
 
    '/// Метод запуска проигрывания
    Function Play()
        WMPlayer.Controls.Play
        '/// Ожидаем окончания проигрывания (ждём пока плеер не перейдёт в состояние остановки)
        Do
            WScript.Sleep 100
        Loop Until WMPlayer.playState = 1
    End Function
End Class