问题描述
如何让我的 doalert.vbs 脚本发出哔哔声（或至少播放系统声音）？
解决方法
这是一个简单的例子：
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,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
'--------------------------------------------------------------------------------------------