Visual Basic for Applications/VBA 中可变蜂鸣声
此 VBA 代码模块检查了 Beep() API 的各种用途。其参数为频率和持续时间。它没有等待参数，因此无法产生和弦，只能产生单音。据称该代码在 Windows 7 及更高版本中运行良好，但在更早版本中可能会忽略参数。除了摩尔斯电码文本发送器外，还演示了简单的音乐音阶和旋律。.
过去，在使用 Beep API 时发现了许多问题。从 Windows 7 开始，微软对 Beep API 进行了重新编码，使其能够与计算机声卡一起工作。在 Windows 7 之前，API 只能与内置声卡一起工作。不幸的是，在从声卡到声卡的过渡过程中，一些计算机制造商仍然使用声卡，而另一些制造商则使用声卡。这是旧版 Windows 版本出现问题的根源。在使用最新版本的 Beep API 时，不应该遇到任何问题。
模块中提供了几个过程。将整个代码复制到标准模块中进行测试。过程如下
- Beeper() 是函数的基本形式。 运行它将在计算机的扬声器中发出简单的音调。注意，它不涉及 Windows 中内置的警报器，而是用于收听媒体的扬声器。声音的频率和持续时间都可以调整，虽然输出的一致性，设计用于选择的频率使用，不是很好。
- TestNotes() 扩展了基本格式。 运行此程序将产生向上和向下的音阶。有两种方法可以访问频率
- 第一个方法是简单地输入每个音符的精确频率，以一系列代码行表示； 这就是do re me 音阶的情况，即所谓的自然音，例如，C,D,E,F,G,A,B,C...。
- 另一个方法，当精确频率未知时，是使用公式根据音符相对于参考点的相对位置来计算频率。（参见图 1 和 2）。本例中的参考点是音符 A = 440 Hz。图 1 显示了围绕 440Hz 的三个八度音阶，图 2 显示了简谱中的音符如何与音符距离相关。音符距离值可用于计算任何其他音符的频率。例如，在图 2 中，请注意G 音符的距离为10；此距离以及所有其他音符距离都列在图 1 的表格中。当了解G 音符始终占据高音谱号的第二行时，可以使用音符和距离来标记简谱，以便于编码。
- SendMorse() 发出参数字符串的摩尔斯电码。 该过程提供基本的输出，频率 (Hz) 和点长 (毫秒) 可调。
- 延时使用Delay() 来实现元素间 (一个点)、字符间 (三个点) 和单词间 (七个点) 间隔，此外还有点和划的 1:3 比例。所有时间都来自一个短点元素的长度。可以在 Random() 中为所有时间添加随机元素，其中可以设置最大误差百分比；据说这更像人手而不是过于完美的程序。
- 惯例是用每分钟字数 来估计点持续时间，T = 1200 / W，其中T 是点持续时间（毫秒），W 是生成的每分钟字数。国际摩尔斯电码作为参考在图 3 中给出。
- 2018 年 12 月 24 日修改，为 SendMorse() 中的所有时间添加随机性
- 2018 年 12 月 24 日修改，在 SendMorse() 中添加了省略的 sCode 声明
- 2018 年 12 月 23 日修改，更正了 SendMorse() 数组 vSN 中的数据
- 2018 年 12 月 22 日修改，展示了在曲调中使用音符距离。
- 2018 年 12 月 21 日修改，更正了摩尔斯电码过程的时间错误。
运行TestBeeper()、TestNotes() 或 testSendMorse() 以运行各种过程。
Option Explicit
Public Declare PtrSafe Function BeepAPI Lib "kernel32" Alias "Beep" _
(ByVal Frequency As Long, ByVal Milliseconds As Long) As Long
Sub TestBeeper()
'run this to test beeper
Dim nFreq As Long, nDur As Long
nFreq = 800 'frequency (Hertz)
nDur = 500 'duration (milliseconds)
'call beeper function
Beeper nFreq, nDur
End Sub
Function Beeper(nF As Long, nD As Long) As Boolean
'makes a beep sound of selected frequency and duration
'This works for NT/2000/XP and beyond.
'Before that, frequency and duration ignored.
BeepAPI nF, nD
Beeper = True
End Function
Sub TestNotes()
'music notes played using known frequencies and those
'calculated from knowlege of their relative positions'
Dim vAN As Variant, vOTJ As Variant, vOTJD As Variant
Dim i As Long, nFreq As Long
Dim nDur As Long, nLen As Long
'sets the basic note duration
nDur = 500
'store the specific frequencies in array - zero based...
'these frequencies are for do,re,me,fa,so,la,te,do based on middle C =261.63Hz (262)
'CDEFGABC
vAN = Array(262, 294, 330, 349, 392, 440, 494, 523)
'or store a jingle in note difference notation. Ode To Joy on beeper.
vOTJ = Array(7, 7, 8, 10, 10, 8, 7, 5, 3, 3, 5, 7, 7, 5, 5) 'note positions from 440Hz
vOTJD = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2) 'durations
'scales up
'CDEFGABC
'do re me fa so la te do
For i = 0 To 7
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'scales down
'CBAGFEDC
'do te la so fa me re do
For i = 7 To 0 Step -1
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'34 notes, naturals, sharps and flats
'played using note position from 440Hz
For i = -5 To 28
nFreq = CInt(440 * 2 ^ (i / 12))
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'Ode to Joy - albeit crude, using note distance only
For i = 0 To 14
nFreq = CInt(440 * 2 ^ (vOTJ(i) / 12))
BeepAPI nFreq, 400 * vOTJD(i)
Next i
Delay 1000 'delay one second
'or use direct entries to make a custom sound
BeepAPI 262 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 262 * 2, 500
End Sub
Sub testSendMorse()
'run this to test the Morse code sender
'integers and simple alphabet only
Dim sIn As String
Dim start As Single, ends As Single
sIn = "The quick brown fox jumps over the lazy dog 0123456789 times"
'start = Timer
SendMorse sIn, 440, 120 'string,freq (Hz),dot length (mS)
'ends = Timer - start
'MsgBox ends
End Sub
Sub SendMorse(ByVal sIn As String, nUF As Single, nUL As Single)
'Sounds out Morse code for input string sIn
'Parmeters frequency(Hz) and dot length(mS)
Dim vSL As Variant, vSN As Variant, vM As Variant
Dim i As Long, j As Long, nAsc As Integer
Dim sWord As String, sCode As String
'check that there is a decent string input
If Trim(sIn) = "" Then
MsgBox "Illegal characters in input string - closing"
Exit Sub
End If
'load letter array with morse code- 1 for dot and 3 for dah
vSL = Array("13", "3111", "3131", "311", "1", "1131", "331", "1111", "11", _
"1333", "313", "1311", "33", "31", "333", "1331", "3313", "131", _
"111", "3", "113", "1113", "133", "3113", "3133", "3311") 'a,b,c,...z
'load number array with morse code- 1 for dot and 3 for dah
vSN = Array("33333", "13333", "11333", "11133", "11113", _
"11111", "31111", "33111", "33311", "33331") '0,1,2,...9
'split the input string into words
vM = Split(Trim(sIn), " ") 'zero based
For i = LBound(vM) To UBound(vM) 'step through words
'get one word at a time
sWord = LCase(vM(i)) 'current word
'get one chara at a time
For j = 1 To Len(sWord)
'look up chara asci code
nAsc = Asc(Mid(sWord, j, 1))
'get morse sequence from array
Select Case nAsc
Case 97 To 122 'a letter
sCode = vSL(nAsc - 97)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case 48 To 57 'an integer
sCode = vSN(nAsc - 48)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case Else
MsgBox "Illegal character in input" & vbCrLf & _
"Only A-Z and 0-9 permitted."
End Select
Next j
If i <> UBound(vM) Then Delay (nUL * 7) 'add 7 spaces between words
Next i
End Sub
Function MakeBeeps(ByVal sIn As String, ByVal nUL As Single, ByVal nUF As Single) As Boolean
'makes beep sounds for one character based on coded input string
Dim i As Long, j As Long, nLen As Long
Dim nT As Single, nE As Single
For i = 1 To Len(sIn)
'get character element
nLen = CInt(Mid(sIn, i, 1))
Select Case nLen
Case 1
BeepAPI nUF, nUL + Random(nUL)
If i <> Len(sIn) Then Delay nUL
Case 3
BeepAPI nUF, (3 * nUL) + Random(3 * nUL)
If i <> Len(sIn) Then Delay nUL
Case Else
MsgBox "error"
End Select
Next i
MakeBeeps = True
End Function
Function Random(nDot As Single) As Single
'adds a random variation to the timing
'used to better hide machine code signature
'nRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim nRand As Long, nPercent As Single
Dim nU As Long, nL As Long
'set a number here for max error percentage
'eg; 10 for ten percent error, 0 for none.
nPercent = 10 'max percent plus and minus
'initialize the random generator
Randomize
'generate small random number as the timing error
nRand = Int((nDot * nPercent / 100 + nDot * nPercent / 100 + 1) * Rnd - nDot * nPercent / 100)
Random = nRand
End Function
Sub Delay(nD As Single)
'delays for nD milliseconds
'randomness set in Random()
Dim start As Single
nD = nD + Random(nD) 'add randomness to intention
start = Timer ' Set start time.
Do While Timer < start + nD / 1000
DoEvents ' Yield to other processes.
Loop
End Sub