Windows 如何从运行在窗口中的VBScript发出嘟嘟声（或播放系统声音）？

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

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

---

下面是一个简单的例子：

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年3月9日：

”=============================================================此Vbscript的说明=======================================
'中文：此vbscript可以从https://soundbible.com 许多声音使用正则表达式。
您还可以选择在硬盘上播放（和/或）保存声音。
'Vbscript由Hackoo于2021年4月9日创建，并在Windows 10上测试。
'-----------------------------------------------------------------------------------------------------------
“弗朗索瓦：我的名字叫佩特莱尔https://soundbible.com 使用正则表达式的nombreux sons。
“你有没有可能选择你的工作呢。
“VBScript CR Pay-Par HakoO LE 04／09／2021 ET测试窗口10。
'===========================================================================================================
选项显式
标题、数据、数组、声音、声音、myURL、myFile、i、Ws、版权
暗应答，超时，确认\中止\脚本，MsgEN，MsgFR，Msg
版权所有=”“&chr（169）和“Hackoo 2021”
MsgEN=Array（“播放声音圣经和下载声音”，“是否要下载此声音？”_
“是否确认停止运行此脚本？”）
MsgFR=Array（“声音圣经和收费讲座”，“你是谁？”_
“确认您是否同意执行脚本？”）
如果奥斯陆=1036，则
Msg=MsgFR'要设置的法语数组消息
其他的
Msg=MsgEN'要设置的英文数组消息
如果结束
Title=Msg（0）和版权
设置Ws=CreateObject（“Wscript.Shell”）
数据=GetSource（“https://soundbible.com/tags-buzzer.html",1)
数组\u Sounds=Split（提取（数据，“数据源=\x22（.*）\x22”），vbCrlf）
调用SmartCreateFolder（“.\SoundBible”）
i=0
超时=10'弹出窗口应答的超时时间
对于数组中的每个声音\u声音
如果声音是“”，那么
i=i+1
Answer=Ws.Popup（“[”&i&“]-”&Msg（1）&vbCrlf&_
声音、超时、标题、vbYesNoCancel+vbQuestion+vbSystemModal）
myURL=”https://soundbible.com/“&声音
Data=GetSource（myURL，2）
myFile=GetFilePath（myURL，“.\SoundBible”）
选择案例答案
案例vbYes
呼叫播放（myURL）
调用SaveBinaryData（myFile，Data）
案例vbNo
呼叫播放（myURL）
案例vbCancel
确认_中止_脚本=MsgBox（消息（2），vbYesNo+vb惊叹号，标题）
如果Confirm\u Aborting\u Script=vbYes，则wscript.Quit
其他情况
呼叫播放（myURL）
结束选择
如果结束
下一个
'--------------------------------------------------------------------------------------
子播放（URL）
暗影播放器
Set Player=CreateObject（“WMPlayer.OCX”）
Player.URL=URL
Player.settings.volume=100
Player.Controls.play
而Player.playState 1
WScript.Sleep 100
温德
端接头
'--------------------------------------------------------------------------------------
函数提取（数据、模式）
Dim oRE，oMatches，Match，colMatches，Nummaches，numSubMatches，myMatch
尺寸i，j，子匹配字符串
set oRE=New RegExp
oRE.IgnoreCase=True
.Global=True
模式
set colMatches=oRE.Execute（数据）
numMatches=colMatches.count
对于i=0到numMatches-1
“在每一场比赛中循环
设置myMatch=colMatches（i）
numSubMatches=myMatch.submatches.count
'循环当前比赛中的每个子比赛
如果numSubMatches>0，则
对于j=0到numSubMatches-1
子匹配字符串=子匹配字符串和myMatch。子匹配（0）和vbcrlf
下一个
如果结束
下一个
提取=子匹配字符串
端函数
'--------------------------------------------------------------------------------------
函数GetSource（URL，TB）
出错时继续下一步
暗淡的http
设置http=CreateObject（“Microsoft.XMLHTTP”）
http.open“GET”，URL，False
http.Send
如果TB=1，则
GetSource=http.ResponseText
其他的
GetSource=http.ResponseBody
如果结束
如果错误号为0，则
MsgBox“说明：”&错误说明和vbcrlf&_
“源：”&错误源，vbCritical，标题
Wscript.Quit（1）
如果结束
设置http=Nothing
端函数
'--------------------------------------------------------------------------------------
函数SaveBinaryData（文件名、数据）
'二进制的adTypeText=1
常量adTypeText=1
常量adSaveCreateOverWrite=2
'创建流对象
暗二进制流
Set BinaryStream=CreateObject（“ADODB.Stream”）
'指定流类型-我们要保存数据/字符串数据。
BinaryStream.Type=adTypeText
'打开流并将二进制数据写入对象
二进制流，打开
写数据
'将二进制数据保存到磁盘
BinaryStream.SaveToFile文件名，adSaveCreateOverWrite
端函数
'--------------------------------------------------------------------------------------------
函数GetFilePath（myURL，myPath）
Dim objFSO，strFile
设置objFSO=CreateObject（“Scripting.FileSystemObject”）
'检查指定的目标文件或文件夹是否存在，
'并生成目标文件的完全限定路径
如果objFSO.FolderExists（myPath），那么
strFile=objFSO.BuildPath（myPath，Mid（myURL，InStrRev（myURL，“/”）+1））
ElseIf objFSO.FolderExists（左（myPath，InStrRev（myPath，“\”）-1））然后
strFile=myPath
其他的
WScript.Echo“错误：找不到目标文件夹。”
退出功能
如果结束
GetFilePath=strFile
E
'====================================== 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
'--------------------------------------------------------------------------------------------