在窗口中运行的 VBScript 如何发出哔哔声（或播放系统声音）？ [复制]

Question

如何让 doalert.vbs 脚本发出哔哔声（或至少播放系统声音）？

• doalert.vbs 是一个 VBScript
• 它在窗口中运行
• 它是由 wscript.exe 启动的（不是由 cscript.exe 启动的）

Answer 1

这是一个简单的例子：

Option Explicit
Dim WS,Notify_Sound,AirHorn_Sound,i
Set WS = CreateObject("Wscript.Shell")
Notify_Sound = WS.ExpandEnvironmentStrings("%Windir%\Media\Notify.wav")
' Playing Notify sound 10 times inside the loop For ..Loop
For i = 1 to 10
    'WS.Popup i & vbTab & "Do you feel alright ?",2,"Answer This Question:",vbYesNo+vbQuestion+vbSystemModal
    Call Play(Notify_Sound)
    'wscript.Sleep 500
Next
AirHorn_Sound = "https://soundbible.com/mp3/Airhorn-SoundBible.com-975027544.mp3"
Call Play(AirHorn_Sound)
'--------------------------------------------------------------------------------
Sub Play(URL)
    Dim Sound
    Set Sound = CreateObject("WMPlayer.OCX")
    Sound.URL = URL
    Sound.settings.volume = 100
    Sound.Controls.play
    Do while Sound.currentmedia.duration = 0
        wscript.sleep 100
    Loop
    wscript.sleep (int(Sound.currentmedia.duration)+1)*1000
End Sub
'--------------------------------------------------------------------------------

---

编辑 2021 年 9 月 3 日：

SoundBible_Player_Downloader.vbs

'====================================== Description of this Vbscript =======================================
' English : This vbscript can extract from  https://soundbible.com many sounds using RegEx.
' and you have the possibility for choosing to play (and / or) save the sound on your hard drive.
' Vbscript Created by Hackoo on 09/04/2021 and tested on Windows 10.
'-----------------------------------------------------------------------------------------------------------
' Français : Ce vbscript peut extraire de https://soundbible.com de nombreux sons en utilisant RegEx.
' et vous avez la possibilité de choisir de jouer (et / ou) de sauvegarder le son sur votre disque dur.
' Vbscript Créé par Hackoo le 04/09/2021 et testé sous Windows 10.
'===========================================================================================================
Option Explicit
Dim Title,Data,Array_Sounds,Sound,myURL,myFile,i,Ws,Copyright
Dim Answer,TimeOut,Confirm_Aborting_Script,MsgEN,MsgFR,Msg
Copyright = " " & chr(169) & " Hackoo 2021"

MsgEN = Array("Playing SoundBible & Downloading Sound","Do you want to download this sound ?",_
"Do you confirm to stop this script from running ?")

MsgFR = Array("Lecture de SoundBible et téléchargement du son","Souhaitez-vous télécharger ce son ?",_
"Confirmez-vous l'arrêt de l'exécution de ce script ?")

If Oslang = 1036 Then
    Msg = MsgFR ' French Array Message to be set
Else
    Msg = MsgEN ' English Array Message to be set
End If

Title = Msg(0) & Copyright

Set Ws = CreateObject("Wscript.Shell")
Data = GetSource("https://soundbible.com/tags-buzzer.html",1)
Array_Sounds = Split(Extract(Data,"data-source=\x22(.*)\x22"),vbCrlf)
Call SmartCreateFolder(".\SoundBible")

i = 0
TimeOut = 10 'The Timeout Time for the Popup to answer
For Each Sound in Array_Sounds
    If Sound <> "" Then
        i = i + 1
        Answer = Ws.Popup("["& i &"] - " & Msg(1) & vbCrlf &_
        Sound,TimeOut,Title,vbYesNoCancel+vbQuestion+vbSystemModal)
        myURL = "https://soundbible.com/" & Sound
        Data = GetSource(myURL,2)
        myFile = GetFilePath(myURL,".\SoundBible")
         Select Case Answer
            Case vbYes
                Call Play(myURL)
                Call SaveBinaryData(myFile,Data)
            Case vbNo
                Call Play(myURL)
            Case vbCancel
                Confirm_Aborting_Script = MsgBox(Msg(2),vbYesNo+vbExclamation,Title)
                If Confirm_Aborting_Script = vbYes Then wscript.Quit
            Case Else
                Call Play(myURL)
        End Select
    End If
Next
'--------------------------------------------------------------------------------------
Sub Play(URL)
    Dim Player
    Set Player = CreateObject("WMPlayer.OCX")
    Player.URL = URL
    Player.settings.volume = 100
    Player.Controls.play
    While Player.playState <> 1
        WScript.Sleep 100
    Wend
End Sub
'--------------------------------------------------------------------------------------
Function Extract(Data,Pattern)
    Dim oRE,oMatches,Match,colMatches,numMatches,numSubMatches,myMatch
    Dim i,j,subMatchesString
    set oRE = New RegExp
    oRE.IgnoreCase = True
    oRE.Global = True
    oRE.Pattern = Pattern
    set colMatches = oRE.Execute(Data)
   numMatches = colMatches.count
For i=0 to numMatches-1
    'Loop through each match
    Set myMatch = colMatches(i)
    numSubMatches = myMatch.submatches.count
    'Loop through each submatch in current match
    If numSubMatches > 0 Then
        For j=0 to numSubMatches-1
            subMatchesString = subMatchesString & myMatch.SubMatches(0) & vbcrlf
        Next
    End If
Next
Extract = subMatchesString
End Function
'--------------------------------------------------------------------------------------
Function GetSource(URL,TB)
On Error Resume Next
    Dim http
    Set http = CreateObject("Microsoft.XMLHTTP")
        http.open "GET", URL, False
        http.Send
        If TB = 1 Then 
            GetSource = http.ResponseText
        Else
            GetSource = http.ResponseBody
        End If
        If err.number <> 0 Then 
            MsgBox "Description : " & Err.Description & vbcrlf &_
            "Source : " & Err.Source,vbCritical,Title
            Wscript.Quit(1)
        End If
    Set http = Nothing  
End Function
'--------------------------------------------------------------------------------------
Function SaveBinaryData(FileName,Data)
' adTypeText for binary = 1
    Const adTypeText = 1
    Const adSaveCreateOverWrite = 2
' Create Stream object
    Dim BinaryStream
    Set BinaryStream = CreateObject("ADODB.Stream")
' Specify stream type - we want To save Data/string data.
    BinaryStream.Type = adTypeText
' Open the stream And write binary data To the object
    BinaryStream.Open
    BinaryStream.Write Data
' Save binary data To disk
    BinaryStream.SaveToFile FileName, adSaveCreateOverWrite
End Function
'--------------------------------------------------------------------------------------------
Function GetFilePath(myURL, myPath)
    Dim objFSO,strFile
    Set objFSO = CreateObject( "Scripting.FileSystemObject" )
    ' Check if the specified target file or folder exists,
    ' and build the fully qualified path of the target file
    If objFSO.FolderExists( myPath ) Then
        strFile = objFSO.BuildPath( myPath, Mid( myURL, InStrRev( myURL, "/" ) + 1 ) )
    ElseIf objFSO.FolderExists( Left( myPath, InStrRev( myPath, "\" ) - 1 ) ) Then
        strFile = myPath
    Else
        WScript.Echo "ERROR: Target folder not found."
        Exit Function
    End If
    GetFilePath = strFile
End Function
'--------------------------------------------------------------------------------------------
Sub SmartCreateFolder(strFolder)
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(strFolder) then
            SmartCreateFolder(.getparentfoldername(strFolder))
            .CreateFolder(strFolder)
        End If
    End With 
End Sub
'--------------------------------------------------------------------------------------------
Function OSLang()
    Dim dtmConvertedDate,strComputer,objWMIService,oss,os
    Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime")
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set oss = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
    For Each os in oss
        OSLang = os.OSLanguage
    Next
End Function
'--------------------------------------------------------------------------------------------